1
;; -*- coding: utf-8; mode: scheme -*-
3
;; stubgen.scm - stub generator
5
;; Copyright (c) 2006 KOGURO, Naoki (naoki@koguro.net)
6
;; All rights reserved.
8
;; Redistribution and use in source and binary forms, with or without
9
;; modification, are permitted provided that the following conditions
12
;; 1. Redistributions of source code must retain the above copyright
13
;; notice, this list of conditions and the following disclaimer.
14
;; 2. Redistributions in binary form must reproduce the above copyright
15
;; notice, this list of conditions and the following disclaimer in the
16
;; documentation and/or other materials provided with the distribution.
17
;; 3. Neither the name of the authors nor the names of its contributors
18
;; may be used to endorse or promote products derived from this
19
;; software without specific prior written permission.
21
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27
;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28
;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36
(define-module c-wrapper.stubgen
39
(use gauche.parameter)
44
(use c-wrapper.c-parser)
45
(use @STUBGEN_FFI_MODULE@)
48
(export compile-wrapper)
51
(select-module c-wrapper.stubgen)
58
((eq? (car obj) 'quote)
64
(define *dummy-line* "/**/")
67
(define (get-c-name prefix scheme-name)
68
(with-output-to-string
70
(display (x->string prefix))
71
(with-input-from-string (x->string scheme-name)
73
(let loop ((c (read-char)))
74
(unless (eof-object? c)
76
((#\-) (let ((d (read-char)))
77
(cond ((eof-object? d)
80
(display "_TO") (loop (read-char)))
82
(display #\_) (loop d)))))
83
((#\?) (display #\P) (loop (read-char)))
84
((#\!) (display #\X) (loop (read-char)))
85
((#\<) (display "_LT") (loop (read-char)))
86
((#\>) (display "_GT") (loop (read-char)))
87
((#\* #\> #\@ #\$ #\% #\^ #\& #\* #\+ #\=
90
(display (number->string (char->integer c) 16))
92
(else (display c) (loop (read-char)))
99
(define stub-unit (make-parameter #f))
101
(define-class <stub-unit> ()
102
((stub-file :init-keyword :stub-file :init-value #f)
103
(module :init-keyword :module :init-value #f)
104
(header-comments :init-value '())
105
(footer-comments :init-value '())
106
(includes :init-value '())
107
(embedding-c-codes :init-value '())
108
(define-cprocs :init-value '())
109
(define-symbols :init-value '())
110
(initcodes :init-value '())
111
(value-table :init-form (make-hash-table))
112
(symbol-table :init-form (make-hash-table))
113
(string-table :init-form (make-hash-table 'string=?))
114
(memoise-table :init-form (make-hash-table 'equal?))
115
(cproc-table :init-form (make-hash-table))))
117
(define (make-stub-unit module stub-file)
118
(let ((unit (make <stub-unit> :stub-file stub-file :module module)))
119
(parameterize ((stub-unit unit))
120
(emit-header-comment #`";;;")
121
(emit-header-comment #`";;; ,(slot-ref unit 'stub-file)")
122
(emit-header-comment #`";;;")
124
(emit-include "stdlib.h")
125
(emit-include "gauche.h")
126
(emit-include "gauche/extend.h")
127
(emit-include "gauche/uvector.h")
129
(let ((cname (get-c-name "" (path-sans-extension stub-file))))
130
(emit-c-code "/* Hack for initialization stub */")
131
(emit-c-code "static void internal_init(ScmModule*);")
132
(emit-c-code "static ScmObj __c_wrapper_mod;")
133
(emit-c-code #`"void Scm_Init_,|cname|(void)")
135
(emit-c-code #`" SCM_INIT_EXTENSION(,|cname|);")
136
(emit-c-code #`" __c_wrapper_mod = SCM_OBJ(SCM_FIND_MODULE(\",|module|\",, 0));")
137
(emit-c-code #`" internal_init(SCM_MODULE(__c_wrapper_mod));")
139
(emit-c-code #`"#define Scm_Init_,|cname| internal_init"))
141
;; define helper functions
142
(emit-c-code "#define INIT_SYMVAL(var, sym) if (!var) { var = Scm_SymbolValue(SCM_MODULE(__c_wrapper_mod), SCM_SYMBOL(SCM_INTERN(sym))); }")
144
(emit-c-code "static ScmObj cw_boxvar(ScmObj klass, void *varptr)")
146
(emit-c-code " static ScmObj make_proc = NULL;")
147
(emit-c-code " static ScmObj csizeof_proc = NULL;")
148
(emit-c-code " ScmObj obj;")
149
(emit-c-code " ScmObj buf;")
150
(emit-c-code " size_t size;")
151
(emit-c-code " INIT_SYMVAL(make_proc, \"make\");")
152
(emit-c-code " INIT_SYMVAL(csizeof_proc, \"c-sizeof\");")
153
(emit-c-code " size = Scm_GetIntegerU(Scm_ApplyRec(csizeof_proc, SCM_LIST1(klass)));")
154
(emit-c-code " buf = Scm_MakeU8VectorFromArrayShared(size, varptr);")
155
(emit-c-code " obj = Scm_ApplyRec(make_proc, SCM_LIST3(klass, SCM_MAKE_KEYWORD(\"buffer\"), buf));")
156
(emit-c-code " SCM_RETURN(obj);")
159
(emit-c-code "static void cw_unbox(void *dest, ScmObj obj, size_t size)")
161
(emit-c-code " static ScmObj bufferof_proc = NULL;")
162
(emit-c-code " ScmObj buf;")
163
(emit-c-code " if (!bufferof_proc) {")
164
(emit-c-code " bufferof_proc = SCM_SYMBOL_VALUE(\"c-wrapper.c-ffi\", \"buffer-of\");")
166
(emit-c-code " buf = Scm_ApplyRec(bufferof_proc, SCM_LIST1(obj));")
167
(emit-c-code " memcpy(dest, SCM_UVECTOR_ELEMENTS(buf), size);")
170
(emit-footer-comment ";; Local variables:")
171
(emit-footer-comment ";; mode: scheme")
172
(emit-footer-comment ";; end:"))
175
(define-method emit-header-comment ((comment <string>))
176
(slot-push! (stub-unit) 'header-comments comment))
178
(define-method emit-footer-comment ((comment <string>))
179
(slot-push! (stub-unit) 'footer-comments comment))
181
(define-method emit-include ((header-file <string>))
182
(slot-push! (stub-unit) 'includes header-file))
184
(define-method emit-c-code ((c-code <string>))
185
(slot-push! (stub-unit) 'embedding-c-codes c-code))
187
(define-method emit-define-cproc ((name <symbol>) ret-type (arg-types <list>)
188
(args <list>) (body <string>))
190
((hash-table-exists? (slot-ref (stub-unit) 'cproc-table) name)
194
(slot-push! (stub-unit) 'define-cprocs
195
(with-output-to-string
197
(format #t "(define-cproc ~a ~a" name args)
198
(let ((bodies (string-split body #[\x0d\x0a])))
199
(format #t "~% (code ~s" (car bodies))
200
(for-each (cut format #t "~% ~s" <>) (cdr bodies))
201
(format #t "))~%")))))
202
(hash-table-put! (slot-ref (stub-unit) 'cproc-table) name
203
(cons ret-type arg-types)))))
205
(define-method emit-define-symbol ((name <symbol>) (varnam <symbol>))
206
(slot-push! (stub-unit) 'define-symbols
207
(format "(define-symbol ~a \"~a\")" name varnam)))
209
(define-method emit-initcode ((c-code <string>))
210
(slot-push! (stub-unit) 'initcodes c-code))
212
(define (write-stub dir)
213
(with-output-to-file (build-path dir (slot-ref (stub-unit) 'stub-file))
215
(for-each print (reverse (slot-ref (stub-unit) 'header-comments)))
216
(for-each (cut format #t "\"#include \\\"~a\\\"\"~%" <>)
217
(reverse (slot-ref (stub-unit) 'includes)))
218
(for-each (cut format #t "~s~%" <>)
219
(reverse (slot-ref (stub-unit) 'embedding-c-codes)))
220
(for-each print (reverse (slot-ref (stub-unit) 'define-symbols)))
221
(for-each print (reverse (slot-ref (stub-unit) 'define-cprocs)))
222
(for-each (lambda (line)
223
(unless (string=? line *dummy-line*)
224
(format #t "(initcode ~s)~%" (string-append line ";"))))
225
(reverse (slot-ref (stub-unit) 'initcodes)))
226
(for-each print (reverse (slot-ref (stub-unit) 'footer-comments))))))
230
(define (classname->ctype sym)
232
(('c-struct ('quote nam))
234
(('c-union ('quote nam))
240
(('c-func-ptr ret-type ('list ('list nam arg-type) ...))
242
(('c-func-ptr ret-type ('list arg-type ...))
263
"unsigned long long")
272
((= (lambda (sym) (#/^<(.*)>$/ (x->string sym))) rmatch)
275
(errorf "Unknown type ~a" sym)))))
277
(define-method emit-define-cproc ((name <symbol>) ret-type (arg-types <list>))
278
(let* ((narg-types (remove (cut equal? '<c-void> <>) arg-types))
279
(ret-ctype (classname->ctype ret-type))
280
(narg-ctypes (map classname->ctype narg-types))
281
(arg-objs (map (cut format "obj~a" <>) (iota (length narg-types))))
282
(arg-vars (map (cut format "v~a" <>) (iota (length narg-types))))
283
(body (with-output-to-string
285
(for-each (cut format #t "~a ~a;~%" <> <>)
286
narg-ctypes arg-vars)
287
(for-each (lambda (var obj type)
288
(format #t "cw_unbox(&~a, ~a, sizeof(~a));~%"
292
(cexpr ,(string->symbol obj))))
294
arg-vars arg-objs narg-types)
296
((equal? '<c-void> ret-type)
297
(format #t "(~a)(~a);~%"
298
name (string-join arg-vars ","))
299
(format #t "SCM_RETURN(SCM_UNDEFINED);"))
302
(format #t " ~a *result_buf = SCM_NEW2(~a*, sizeof(~a));~%"
303
ret-ctype ret-ctype ret-ctype)
304
(format #t " *result_buf = (~a) (~a)(~a);~%"
305
ret-ctype name (string-join arg-vars ","))
306
(format #t " SCM_RETURN(~a);~%"
309
(cexpr ,(format "cw_boxvar(~a, result_buf)"
310
(ccode-eval ret-type))))))
311
(format #t "}")))))))
312
(emit-define-cproc name ret-type arg-types
313
(map string->symbol arg-objs) body)))
315
(define (ccode-intern sym)
316
(let ((symbol-table (slot-ref (stub-unit) 'symbol-table)))
317
(symbol->string (or (hash-table-get symbol-table sym #f)
318
(let ((varnam (gensym "__c_wrapper_")))
319
(emit-define-symbol sym varnam)
320
(hash-table-put! symbol-table sym varnam)
323
(define (ccode-string str)
324
(let ((string-table (slot-ref (stub-unit) 'string-table)))
325
(format "SCM_OBJ(&~a)"
326
(or (hash-table-get string-table str #f)
327
(let ((varnam (gensym "__c_wrapper_"))
328
(len (string-length str)))
330
(format "static SCM_DEFINE_STRING_CONST(~a, ~s, ~a, ~a);"
332
(hash-table-put! string-table str varnam)
335
(define (ccode-lookup-value sym)
336
(let ((value-table (slot-ref (stub-unit) 'value-table)))
337
(or (hash-table-get value-table sym #f)
338
(let ((varnam (gensym "__c_wrapper_")))
339
(emit-c-code (format "static ScmObj ~a; /* ~a */" varnam sym))
342
"~a = Scm_SymbolValue(SCM_MODULE(__c_wrapper_mod), SCM_SYMBOL(~a))"
343
varnam (ccode-intern sym)))
344
(hash-table-put! value-table sym varnam)
345
(symbol->string varnam)))))
347
(define (ccode-define name cexpr)
348
(let ((varnam (gensym "__c_wrapper_"))
349
(value-table (slot-ref (stub-unit) 'value-table)))
350
(hash-table-put! value-table name varnam)
351
(emit-c-code (format "static ScmObj ~a; /* ~a */" varnam name))
352
(emit-initcode (format "~a = ~a" varnam cexpr))
353
(format "Scm_Define(SCM_MODULE(__c_wrapper_mod), SCM_SYMBOL(~a), ~a)"
354
(ccode-intern name) varnam)))
356
(define (ccode-memoise-apply proc args)
357
(let ((memoise-table (slot-ref (stub-unit) 'memoise-table)))
359
(or (hash-table-get memoise-table (cons proc args) #f)
360
(let ((varnam (gensym "__c_wrapper_")))
361
(emit-c-code (format "static ScmObj ~a; /* ~a */"
362
varnam (cons proc args)))
363
(emit-initcode (format "~a = ~a"
365
(ccode-eval `(apply ,proc (list ,@args)))))
366
(hash-table-put! memoise-table (cons proc args) varnam)
369
(define (ccode-eval expr)
371
((('with-module 'c-wrapper 'define-inline-cfunc)
372
name ret-type _ (arg-types ...) _ ...)
373
(emit-define-cproc name ret-type arg-types)
375
(('define name ('make-c-var _ type))
376
(ccode-define name (format "cw_boxvar(~a, (void*) &(~a))"
377
(ccode-eval type) name)))
378
(('define name ('make-c-func _ ret-type ('list arg-types ...)))
379
(emit-define-cproc name ret-type arg-types)
382
(ccode-define sym (ccode-eval expr)))
383
((('with-module 'c-wrapper 'define-enum) name val)
384
(ccode-define name (format "Scm_MakeInteger(~a)" name)))
385
(('init-c-struct! name members)
386
(ccode-eval `(apply init-c-struct! (list ,name ,members))))
387
(('init-c-union! name members)
388
(ccode-eval `(apply init-c-union! (list ,name ,members))))
390
(ccode-eval '<c-int>))
391
(('init-c-enum! name symbols)
394
"Scm_ExportAll(SCM_MODULE(__c_wrapper_mod))")
395
(('export symbols ...)
396
(format "Scm_ExportSymbols(SCM_MODULE(__c_wrapper_mod), ~a)"
397
(ccode-eval `(list ,@(map (lambda (x) `(quote ,x)) symbols)))))
399
(ccode-lookup-value x))
407
(format "SCM_MAKE_INT(~a)" x))
409
(format "Scm_ReadFromCString(\"~a\")" x))
413
(apply (cut format "SCM_LIST1(~a)" <>)
414
(map ccode-eval (cdr expr))))
416
(apply (cut format "SCM_LIST2(~a, ~a)" <> <>)
417
(map ccode-eval (cdr expr))))
419
(apply (cut format "SCM_LIST3(~a, ~a, ~a)" <> <> <>)
420
(map ccode-eval (cdr expr))))
422
(apply (cut format "SCM_LIST4(~a, ~a, ~a, ~a)" <> <> <> <>)
423
(map ccode-eval (cdr expr))))
425
(apply (cut format "SCM_LIST5(~a, ~a, ~a, ~a, ~a)" <> <> <> <> <>)
426
(map ccode-eval (cdr expr))))
427
(('list kar rest ...)
428
(format "Scm_Cons(~a, ~a)" (ccode-eval kar) (ccode-eval `(list ,@rest))))
434
(format "Scm_Cons(~a, ~a)" (ccode-eval kar) (ccode-eval kdr)))
436
(ccode-memoise-apply 'ptr (list ctype)))
438
(format "Scm_ApplyRec(~a, ~a)" (ccode-eval proc) (ccode-eval lst)))
440
(ccode-eval `(apply cast (list ,ctype ,val))))
442
(ccode-eval `(apply scm-cast (list ,val))))
443
(('c-bit-field ctype n)
444
(ccode-eval `(apply c-bit-field (list ,ctype ,n))))
445
(('c-array ctype size)
446
(ccode-memoise-apply 'c-array (list ctype size)))
447
(('c-func-ptr rettype argtypes)
448
(ccode-memoise-apply 'c-func-ptr (list rettype argtypes)))
449
(('c-struct ('quote name))
450
(ccode-eval ((with-module c-wrapper.c-ffi c-struct-symbol) name)))
451
(('c-union ('quote name))
452
(ccode-eval ((with-module c-wrapper.c-ffi c-union-symbol) name)))
453
(('make-c-func-vaargs name rettype argtypes)
454
(ccode-memoise-apply 'make-c-func-vaargs (list name rettype argtypes)))
458
(format "Scm_EvalRec(~a, SCM_OBJ(__c_wrapper_mod))"
463
`(cexpr ,(ccode-eval `(list ,@(map traverse obj)))))
466
,(ccode-eval `(cons ,(traverse (car obj))
467
,(traverse (cdr obj))))))
469
`(cexpr ,(ccode-eval `(quote ,obj))))
473
`(cexpr ,(ccode-eval obj)))
476
,(format "Scm_ReadFromCString(\"~s\")" obj)))))))
477
(ccode-eval (traverse expr)))))))
479
(define (wrapper->c headers include-dirs options import-arg export?)
480
(for-each emit-include headers)
481
(with-input-from-string (c-parse include-dirs headers options
482
import-arg export? (if import-arg
486
(port-for-each (lambda (expr)
487
(emit-initcode (ccode-eval expr))) read))))
489
(define (run-command command module compiled-lib headers include-dirs import-arg
490
export? cppflags cflags ldflags libs verbose?)
492
(c-ld (string-append ldflags libs)))
493
(let* ((extension (path-sans-extension compiled-lib))
494
(stub-file (path-swap-extension compiled-lib "stub"))
495
(cmdlines (case command
497
(list #`"gauche-package compile ,(if verbose? \"--verbose\" \"\") --cflags=\",|cflags|\" --cppflags=\",|cppflags|\" --ldflags=\",|ldflags|\" --libs=\",|libs|\" ,|extension| ,|stub-file|"))
499
(list #`"gauche-package compile --clean ,(if verbose? \"--verbose\" \"\") ,|extension| ,|stub-file|"
500
#`"rm -f ,|stub-file|")))))
501
(parameterize ((stub-unit (make-stub-unit module stub-file)))
502
(wrapper->c (listize headers)
503
(listize include-dirs)
504
(string-split cppflags #[\s])
507
(write-stub (sys-dirname compiled-lib))
508
(for-each (lambda (cmd)
511
(with-input-from-process cmd
513
(port-for-each print read-line))))
516
(define (compile-wrapper filename command
517
cflags-arg cppflags-arg ldflags-arg libs-arg verbose?)
518
(with-input-from-file filename
520
(let loop ((curmod 'user)
522
(cppflags (list cppflags-arg))
523
(ldflags (list ldflags-arg))
524
(libs (list libs-arg)))
529
(('define-module module lst ...)
530
(with-input-from-string (with-output-to-string
532
(for-each (cut format #t "~s" <>) lst)))
534
(loop module (read) cppflags ldflags libs)))
535
(loop curmod (read) cppflags ldflags libs))
537
(('use 'objc-wrapper)
538
(loop curmod (read) (append cppflags (list "-ObjC")) ldflags libs))
540
(('c-load-framework frameworks)
541
(loop curmod (read) cppflags ldflags
542
(append libs (map (lambda (fw)
543
#`"-framework ,|fw|")
544
(listize frameworks)))))
546
(('c-ld keywords ...)
547
(loop curmod `(c-load-library () ,@keywords)
548
cppflags ldflags libs))
550
(('c-load-library libs keywords ...)
551
(let-keywords* keywords ((library-dirs '())
554
(fold (lambda (filename ldflags&libs)
556
(decompose-path filename)
558
(append (car ldflags&libs)
559
(if (string=? dir ".")
561
(list #`"-L,|dir|")))
562
(append (cdr ldflags&libs)
563
(let ((name (regexp-replace #/lib(.*)/
565
(list #`"-l,|name|"))))))
566
(receive (libs ldflags)
567
(partition (cut string-prefix? "-l" <>)
568
(string-split option #[\s]))
571
(loop curmod (read) cppflags
572
(append ldflags (car ldflags&libs))
573
(append libs (cdr ldflags&libs))))))
575
(('c-include headers keywords ...)
576
(let-keywords* keywords ((include-dirs '())
578
(import-arg :import #f)
582
(let* ((options (string-split option #[\s]))
583
(cppflags-str (string-join (append cppflags options) " "))
584
(ldflags-str (string-join ldflags " "))
585
(libs-str (string-join libs " ")))
591
(eval import-arg (current-module))
593
cppflags-str "" ldflags-str libs-str
595
(loop curmod (read) cppflags ldflags libs))
597
(('c-load headers keywords ...)
598
(let-keywords* keywords ((cflags-str :cflags "")
600
(cppflags-str :cppflags "")
602
(ldflags-str :ldflags "")
607
(import-arg :import #f)
611
(lambda (flags str cmd)
612
(string-join (append (reverse flags)
615
(cmd => process-output->string)
623
(eval import-arg (current-module))
625
(append-cmd cppflags cppflags-str cppflags-cmd)
626
(append-cmd '() cflags-str cflags-cmd)
627
(append-cmd ldflags ldflags-str ldflags-cmd)
628
(append-cmd libs libs-str libs-cmd)
630
(loop curmod (read) cppflags ldflags libs))
632
(('select-module module)
633
(loop module (read) cppflags ldflags libs))
636
(loop curmod (read) cppflags ldflags libs)))))))
638
(provide "c-wrapper/stubgen")
added
removed
lib/c-wrapper/stubgen.scm.in
