1
;; -*- coding: utf-8; mode: scheme -*-
5
;; Copyright (c) 2006 KOGURO, Naoki (naoki@koguro.net)
7
;; Permission is hereby granted, free of charge, to any person
8
;; obtaining a copy of this software and associated
9
;; documentation files (the "Software"), to deal in the
10
;; Software without restriction, including without limitation
11
;; the rights to use, copy, modify, merge, publish, distribute,
12
;; sublicense, and/or sell copies of the Software, and to
13
;; permit persons to whom the Software is furnished to do so,
14
;; subject to the following conditions:
16
;; The above copyright notice and this permission notice shall
17
;; be included in all copies or substantial portions of the
20
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY
21
;; KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
22
;; WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
23
;; PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS
24
;; OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
25
;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
26
;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
27
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
31
(define-module c-wrapper.c-parser
43
(use c-wrapper.config)
48
(dynamic-load "c-parser")
51
(select-module c-wrapper.c-parser)
53
(debug-print-width #f)
55
(define-macro (profiler-on)
56
'(define-syntax profile
64
(define-macro (profiler-off)
65
'(define-syntax profile
72
(define (warning fmt . args)
75
(string-append "Warning: " fmt "~%")
78
(define (c-type->class-symbol type)
79
(string->symbol (string-append "<" (symbol->string type) ">")))
84
(define-class <parse-context> ()
87
(import-cond :init-value #f)
88
(export? :init-value #f)
89
(ignore-dlsym-check? :init-value #f)
92
(side-effect? :init-value #f)
93
(use-return? :init-value #f)
94
(use-jump? :init-value #f)
95
(use-iterator? :init-value #f)
96
(typedefed-identifiers :init-form (let ((tbl (make-hash-table)))
97
(for-each (cut hash-table-put! tbl <> #t)
108
(struct-pool :init-form (make-hash-table))
109
(union-pool :init-form (make-hash-table))
110
(value-pool :init-form (make-hash-table))
111
(arg-pool :init-form (make-hash-table))
112
(macro-queue :init-form (make-queue))
113
(import-pool :init-form (make-hash-table 'equal?))
114
(imported-pool :init-form (make-hash-table 'equal?))
115
(code-queue :init-form (let ((tail-cons '(#f)))
116
(cons tail-cons tail-cons)))
119
(last-token :init-value #f)
120
(lineno :init-value #f)
121
(filename :init-value #f)
122
(rest-chars :init-value '())
123
(input-port :init-value #f)))
127
(define-macro (define-context-accessor name)
128
`(define-syntax ,name
131
(slot-ref context ',name))
133
(slot-set! context ',name val)))))
135
(define-context-accessor side-effect?)
136
(define-context-accessor use-return?)
137
(define-context-accessor use-jump?)
138
(define-context-accessor use-iterator?)
139
(define-context-accessor import-cond)
140
(define-context-accessor export?)
141
(define-context-accessor last-token)
142
(define-context-accessor lineno)
143
(define-context-accessor filename)
144
(define-context-accessor rest-chars)
145
(define-context-accessor input-port)
146
(define-context-accessor typedefed-identifiers)
147
(define-context-accessor struct-pool)
148
(define-context-accessor union-pool)
149
(define-context-accessor value-pool)
150
(define-context-accessor arg-pool)
151
(define-context-accessor macro-queue)
152
(define-context-accessor import-pool)
153
(define-context-accessor ignore-dlsym-check?)
154
(define-context-accessor imported-pool)
156
(define (do-external-declaration decl-specs init-decl-list)
159
(for-each (lambda (init-decl)
160
(emit-define-extern decl-specs init-decl))
163
((('STRUCT tagname (elem-alist ...)))
164
(emit-init-struct tagname elem-alist)
166
((('STRUCT tagname #f))
167
(emit-alloc-struct tagname)
169
((('UNION tagname (elem-alist ...)))
170
(emit-init-union tagname elem-alist)
172
((('UNION tagname #f))
173
(emit-alloc-union tagname)
175
((('ENUM tagname (enum-alist ...)))
176
(emit-define-enum tagname enum-alist)
179
(emit-typedef (make-var-list type init-decl-list)))
183
(define (install-arg-pool init-decl-alist)
184
(for-each (lambda (alist)
185
(and-let* ((kv (assq 'identifier alist)))
186
(hash-table-put! (arg-pool) (cadr kv) #t)))
189
(define (parameter-decl type-spec-list decl)
190
(let ((v (make-var type-spec-list decl)))
191
;; ISO/IEC 9899:1999 6.7.5.3
193
(('c-func ret-type arg-types)
194
(set! (type-of v) `(make-c-func-ptr ,ret-type ,arg-types)))
195
(('c-func-vaargs ret-type arg-types)
196
(set! (type-of v) `(make-c-func-vaargs-ptr ,ret-type ,arg-types)))
199
(and-let* ((name (name-of v)))
200
(hash-table-put! (arg-pool) name #t))
203
(define (declaration specifiers declarator-list)
204
(install-arg-pool declarator-list)
205
(cons specifiers declarator-list))
207
(define (decl-identifier v)
208
(list (list 'identifier v)))
210
(define (decl-array v)
211
(list (list 'array (and v (%INT v)))))
213
(define (decl-func args)
214
(list (cons 'c-func args)))
216
(define (decl-func-vaargs args)
217
(list (cons 'c-func-vaargs args)))
222
(define (decl-keyword selector . typename-list)
223
(cons (list (string-append (x->string selector)
224
(if (null? typename-list) "" ":")))
227
(define (decl-bitfield decl n)
229
(cons (list 'bit-field n) decl)
230
(decl-bitfield (decl-identifier (gensym "%")) n)))
232
(define (decl-enum identifier lst)
233
(list 'ENUM (or identifier (gensym "%")) lst))
235
(define (decl-enumerator identifier expr)
236
(cons identifier expr))
238
(define (decl-init-value v)
239
(list 'init-value v))
241
(define (combine-decl-keyword decl1 . rest)
242
(let-optionals* rest ((decl2 #f))
244
(cons (append (car decl1) (car decl2))
245
(append (cdr decl1) (cdr decl2)))
248
(define (decl-objc-method ret-type decl-arg)
249
(list (car decl-arg) (cons ret-type (cdr decl-arg))))
251
(define (decl-struct-or-union struct-or-union identifier decl-list)
252
(list struct-or-union (or identifier (gensym "%")) decl-list))
255
(make-var '(id) '()))
260
`(cast <integer> ,v)))
267
(define (%SCM-CAST expr)
273
(('begin (or (? number? v) (? string? v)))
275
(('cast _ (? number? v))
280
(define (%IDENTIFIER v)
281
(if (registered-identifier? v) v #f))
283
(define-syntax define-maybe
285
((_ (name . args) . body)
286
(define (name . args)
291
(define-maybe (%MACRO-BODY body)
292
(if (null? (cdr body))
293
(%SCM-CAST (car body))
294
(%SCM-CAST `(begin ,@body))))
296
(define-maybe (%FUNCTION-BODY body)
297
`(call/cc (lambda (%return) ,body)))
299
(define-maybe (%OBJC-STRING v)
302
(define-maybe (%EXPR-IN-PARENS expr)
307
(define-maybe (%COMPOUND-STATEMENT statements)
308
`(begin ,@statements))
310
(define-maybe (%COMPOUND-STATEMENT-WITH-DECL decl-list statements)
313
(for-each (lambda (alist)
314
(for-each (lambda (declarator)
315
(let* ((v (make-var (car alist)
318
(identifier (name-of v))
319
(init-val (value-of v)))
320
;; TODO: typedef in compound_statement is not supported
322
`(,identifier (make ,type)))
325
`(set! (ref ,identifier)
329
`(let* ,(reverse var-list)
330
,@(reverse init-list)
333
(define-maybe (%REF-ARRAY v index)
334
`(ref ,v ,(%INT index)))
336
(define-maybe (%FUNCALL func names)
338
(cons (c-lookup-value func) names))
340
(define-maybe (%DOT-REF v name)
341
`(raw-ref ,v ',name))
343
(define-maybe (%PTR-REF p name)
344
`(raw-ref (deref ,p) ',name))
346
(define-maybe (%POST-INC v)
350
(define-maybe (%POST-DEC v)
354
(define-maybe (%LIST v)
357
(define-maybe (%ADD-LIST lst v)
358
(append lst (list v)))
360
(define-maybe (%PRE-INC v)
364
(define-maybe (%PRE-DEC v)
368
(define-maybe (%UNARY op v)
378
(define-maybe (%BIT-NOT v)
381
`(lognot ,(%INT v))))
383
(define-maybe (%SIZEOF-EXPR v)
386
(define-maybe (%SIZEOF-TYPE v)
387
`(c-sizeof ,(type-of v)))
389
(define-maybe (%CAST type-name expr)
390
`(cast ,(type-of type-name) ,expr))
392
(define-maybe (%MUL expr1 expr2)
393
(if (and (real? expr1) (real? expr2))
395
`(* ,(%REAL expr1) ,(%REAL expr2))))
397
(define-maybe (%DIV expr1 expr2)
398
(if (and (real? expr1) (real? expr2))
400
`(/ ,(%REAL expr1) ,(%REAL expr2))))
402
(define-maybe (%MOD expr1 expr2)
403
(if (and (integer? expr1) (integer? expr2))
405
`(modulo ,(%INT expr1) ,(%INT expr2))))
407
(define-maybe (%ADD expr1 expr2)
408
(if (and (real? expr1) (real? expr2))
410
`(if (is-a? ,expr1 <c-ptr>)
411
(c-ptr+ ,expr1 ,(%REAL expr2))
412
(+ (cast <real> ,expr1) ,(%REAL expr2)))))
414
(define-maybe (%SUB expr1 expr2)
415
(if (and (real? expr1) (real? expr2))
417
`(if (is-a? ,expr1 <c-ptr>)
418
(c-ptr- ,expr1 ,(%REAL expr2))
419
(- (cast <real> ,expr1) ,(%REAL expr2)))))
421
(define-maybe (%SHIFT-LEFT expr1 expr2)
422
(if (and (integer? expr1) (integer? expr2))
424
`(ash ,(%INT expr1) ,(%INT expr2))))
426
(define-maybe (%SHIFT-RIGHT expr1 expr2)
427
(if (and (integer? expr1) (integer? expr2))
428
(ash expr1 (- expr2))
429
`(ash ,(%INT expr1) (- ,(%INT expr2)))))
431
(define-maybe (%LT expr1 expr2)
432
(if (and (real? expr1) (real? expr2))
433
(if (< expr1 expr2) 1 0)
434
`(if (< ,(%REAL expr1) ,(%REAL expr2)) 1 0)))
436
(define-maybe (%GT expr1 expr2)
437
(if (and (real? expr1) (real? expr2))
438
(if (> expr1 expr2) 1 0)
439
`(if (> ,(%REAL expr1) ,(%REAL expr2)) 1 0)))
441
(define-maybe (%LE expr1 expr2)
442
(if (and (real? expr1) (real? expr2))
443
(if (<= expr1 expr2) 1 0)
444
`(if (<= ,(%REAL expr1) ,(%REAL expr2)) 1 0)))
446
(define-maybe (%GE expr1 expr2)
447
(if (and (real? expr1) (real? expr2))
448
(if (>= expr1 expr2) 1 0)
449
`(if (>= ,(%REAL expr1) ,(%REAL expr2)) 1 0)))
451
(define-maybe (%EQ expr1 expr2)
452
(if (and (real? expr1) (real? expr2))
453
(if (eq? expr1 expr2) 1 0)
454
`(if (equal? ,(%REAL expr1) ,(%REAL expr2)) 1 0)))
456
(define-maybe (%NE expr1 expr2)
457
(if (and (real? expr1) (real? expr2))
458
(if (eq? expr1 expr2) 0 1)
459
`(if (equal? ,(%REAL expr1) ,(%REAL expr2)) 0 1)))
461
(define-maybe (%BIT-AND expr1 expr2)
462
(if (and (integer? expr1) (integer? expr2))
464
`(logand ,(%INT expr1) ,(%INT expr2))))
466
(define-maybe (%BIT-XOR expr1 expr2)
467
(if (and (integer? expr1) (integer? expr2))
469
`(logxor ,(%INT expr1) ,(%INT expr2))))
471
(define-maybe (%BIT-OR expr1 expr2)
472
(if (and (integer? expr1) (integer? expr2))
474
`(logior ,(%INT expr1) ,(%INT expr2))))
476
(define-maybe (%LOG-AND expr1 expr2)
477
(let ((v (gensym "%")))
478
`(let ((,v ,(%REAL expr1)))
479
(if (eq? ,v 0) ,v ,expr2))))
481
(define-maybe (%LOG-OR expr1 expr2)
482
(let ((v (gensym "%")))
483
`(let ((,v ,(%REAL expr1)))
484
(if (eq? ,v 0) ,expr2 ,v))))
486
(define-maybe (%IF test then else)
487
`(if (eq? ,(%REAL test) 0) ,else ,then))
489
(define-maybe (%ASSIGN lhs rhs)
496
(((or 'ref 'raw-ref) x ...)
507
(define-maybe (%CONCAT-EXPR expr1 expr2)
508
`(begin ,expr1 ,expr2))
510
(define-maybe (%FOR init test update body)
512
`(call/cc (lambda (%break)
522
(define-maybe (%WHILE test statement)
524
`(call/cc (lambda (%break)
526
,(%IF test `(begin ,statement (%continue)) '(%break 0))))))
528
(define-maybe (%DO-WHILE test statement)
530
`(call/cc (lambda (%break)
531
(letrec ((%body (lambda () ,statement (%continue)))
532
(%continue (lambda ()
546
(define-maybe (%RETURN v)
550
(define-maybe (%QUOTE v)
553
(define-maybe (%APPEND v1 v2)
556
(define-maybe (%KEYWORD-ARG selector expr)
559
(define-maybe (%KEYWORD-ARG-WITHOUT-SELECTOR expr)
562
(define-maybe (%OBJC-MESSAGE-EXPR receiver args)
566
(define-maybe (%SELECTOR selector)
568
`(@selector ,selector))
572
(define (lexer-init port)
577
(define (clear-arg-pool)
578
(arg-pool (make-hash-table)))
580
(define (typedefed? symbol)
581
(hash-table-exists? (typedefed-identifiers) symbol))
583
(define (install-type symbol)
584
(hash-table-put! (typedefed-identifiers) symbol #t))
588
(load "c-wrapper/c-lex")
589
(load "c-wrapper/c-grammar.yy")
591
(define (enqueue-code obj write?)
592
(let ((new-tail (list (cons obj write?)))
593
(queue (slot-ref context 'code-queue)))
594
(set-cdr! (cdr queue) new-tail)
595
(set-cdr! queue new-tail)
598
(define (code-queue->list)
599
(cdar (slot-ref context 'code-queue)))
601
(define (register-identifier name value)
602
(let ((pair (or (hash-table-get (value-pool) name #f)
604
(set-car! pair value)
605
(hash-table-put! (value-pool) name pair))
608
(define (c-lookup-value v)
610
(('identity (? symbol? name))
611
(hash-table-get (value-pool) name #f))
615
(define (register-macro name)
616
(let ((pair (or (hash-table-get (value-pool) name #f)
619
(hash-table-put! (value-pool) name pair)))
621
(define (registered-identifier? name)
622
(or (hash-table-exists? (value-pool) name)
623
(hash-table-exists? (arg-pool) name)))
625
(define (enqueue-import-pool name data)
626
(hash-table-update! (import-pool) name
628
(append elem (list data)))
631
(define (dequeue-import-pool name)
633
(hash-table-update! (import-pool) name
638
(set! result (car elem))
644
(do ((data (dequeue-import-pool v) (dequeue-import-pool v)))
646
(traverse (cdr data))
647
(set-cdr! (car data) #t)
648
(when (and (export?) v)
649
(enqueue-code `(export ,v) #t))
650
(hash-table-put! (imported-pool) v #t)))
657
(if (memq (car v) '(c-struct c-union c-enum))
663
(define (emit-definition name define-list . rest)
664
(let-optionals* rest ((dependent-symbols define-list))
666
(let ((pair (enqueue-code define-list #f)))
667
(enqueue-import-pool name (cons pair dependent-symbols))
668
(when (or (hash-table-exists? (imported-pool) name)
672
(enqueue-code define-list #t)
673
(when (and (export?) name)
674
(enqueue-code `(export ,name) #t))))))
676
(define-method need-import? (name)
678
(need-import? name (import-cond))
681
(define-method need-import? (name (re <regexp>))
682
(re (x->string name)))
684
(define-method need-import? (name (col <collection>))
685
(find (cut need-import? name <>) col))
687
(define-method need-import? (name (sym <symbol>))
690
(define-method need-import? (name (str <string>))
691
(need-import? name (string->symbol str)))
693
(define-method need-import? (name (proc <procedure>))
694
(apply proc (list (filename) name)))
696
(define (make-var type-spec-list qualifiers)
697
(receive (typedef-list ts-list) (partition (cut eq? 'TYPEDEF <>) type-spec-list)
698
(receive (type identifier) (qualified-type (typespec->c-type ts-list)
702
(or (and-let* ((kv (assq 'init-value qualifiers)))
705
(not (null? typedef-list))))))
710
(define type-of (getter-with-setter (lambda (v)
714
(vector-set! v 1 type))))
722
(define (make-var-list type-spec-list qualifiers-list)
723
(map (cut make-var type-spec-list <>) qualifiers-list))
725
(define (qualified-type c-type qualifiers)
726
(let loop ((ret-type c-type)
731
(values ret-type identifier))
732
((('ptr) ('c-func args ...) x ...)
733
(values `(c-func-ptr ,(receive (ret-type _) (qualified-type c-type x)
735
,`(list ,@(map (lambda (v)
740
((('ptr) ('c-func-vaargs args ...) x ...)
741
(values `(c-func-vaargs-ptr ,(receive (ret-type _)
742
(qualified-type c-type x)
744
,`(list ,@(map (lambda (v)
749
((('c-func args ...) x ...)
750
(values `(c-func ,(receive (ret-type _) (qualified-type c-type x)
752
,`(list ,@(map (lambda (v)
757
((('c-func-vaargs args ...) x ...)
758
(values `(c-func-vaargs ,(receive (ret-type _) (qualified-type c-type x)
760
,`(list ,@(map (lambda (v)
766
(values `(ptr ,(receive (ret-type _) (qualified-type c-type x)
770
(values `(c-array ,(receive (ret-type _) (qualified-type c-type x)
774
((('bit-field n) x ...)
775
(loop `(c-bit-field ,ret-type ,n) identifier x))
776
((('init-value n) x ...)
777
(loop ret-type identifier x))
778
((('identifier name) x ...)
779
(loop ret-type name x)))))
781
(define (typespec->c-type type)
784
(('SIGNED 'char) '<c-char>)
785
(('UNSIGNED 'char) '<c-uchar>)
786
(('short) '<c-short>)
787
(('short 'int) '<c-short>)
788
(('SIGNED 'short) '<c-short>)
789
(('SIGNED 'short 'int) '<c-short>)
790
(('UNSIGNED 'short) '<c-ushort>)
791
(('UNSIGNED 'short 'int) '<c-ushort>)
793
(('SIGNED 'int) '<c-int>)
795
(('UNSIGNED 'int) '<c-uint>)
796
(('UNSIGNED) '<c-uint>)
798
(('long 'int) '<c-long>)
799
(('SIGNED 'long) '<c-long>)
800
(('SIGNED 'long 'int) '<c-long>)
801
(('long 'SIGNED 'int) '<c-long>)
802
(('UNSIGNED 'long) '<c-ulong>)
803
(('UNSIGNED 'long 'int) '<c-ulong>)
804
(('long 'UNSIGNED 'int) '<c-ulong>)
805
(('long 'long) '<c-longlong>)
806
(('long 'long 'int) '<c-longlong>)
807
(('SIGNED 'long 'long) '<c-longlong>)
808
(('SIGNED 'long 'long 'int) '<c-longlong>)
809
(('long 'long 'SIGNED 'int) '<c-longlong>)
810
(('UNSIGNED 'long 'long) '<c-ulonglong>)
811
(('UNSIGNED 'long 'long 'int) '<c-ulonglong>)
812
(('long 'long 'UNSIGNED 'int) '<c-ulonglong>)
813
(('float) '<c-float>)
814
(('double) '<c-double>)
815
(('long 'double) '<c-longdouble>)
818
(('__builtin_va_list) '(ptr <c-void>))
819
((('STRUCT tagname (elem-alist ...)))
820
(emit-init-struct tagname elem-alist)
821
`(c-struct ',tagname))
822
((('STRUCT tagname #f))
823
(emit-alloc-struct tagname)
824
`(c-struct ',tagname))
825
((('UNION tagname (elem-alist ...)))
826
(emit-init-union tagname elem-alist)
827
`(c-union ',tagname))
828
((('UNION tagname #f))
829
(emit-alloc-union tagname)
830
`(c-union ',tagname))
831
((('ENUM tagname (enum-alist ...)))
832
(emit-define-enum tagname enum-alist)
835
(c-type->class-symbol x))))
837
(define (make-member-alist elem-list)
839
`(cons ',(name-of elem) ,(type-of elem)))
842
(define (emit-alloc-struct tagname)
843
(unless (hash-table-exists? (struct-pool) tagname)
844
(hash-table-put! (struct-pool) tagname #t)
845
(emit-definition `(c-struct ',tagname) `(define-c-struct ,tagname))))
847
(define (emit-init-struct tagname member-list)
848
(emit-alloc-struct tagname)
849
(emit-definition `(c-struct ',tagname)
850
`(init-c-struct! (c-struct ',tagname)
851
(list ,@(make-member-alist member-list)))))
853
(define (emit-alloc-union tagname)
854
(unless (hash-table-exists? (union-pool) tagname)
855
(hash-table-put! (union-pool) tagname #t)
856
(emit-definition `(c-union ',tagname) `(define-c-union ,tagname))))
858
(define (emit-init-union tagname member-list)
859
(emit-alloc-union tagname)
860
(emit-definition `(c-union ',tagname)
861
`(init-c-union! (c-union ',tagname)
862
(list ,@(make-member-alist member-list)))))
864
(define (emit-define-enum tagname enum-alist)
865
(fold (lambda (p prev)
869
`(+ (scm-cast ,prev) 1)))))
870
(register-identifier (car p) v)
871
(emit-definition (car p) `((with-module c-wrapper define-enum) ,(car p) ,v))
875
(emit-definition `(c-enum ',tagname)
876
`(init-c-enum! (c-enum ',tagname)
877
(list ,@(map car enum-alist)))))
879
(define (emit-typedef var-list)
880
(for-each (lambda (v)
881
(let ((obj (match (type-of v)
882
(('c-func-ptr ret-type ('list ('list _ arg-type)
884
`(c-func-ptr ,ret-type (list ,@arg-type)))
885
(('c-func-vaargs-ptr ret-type
886
('list ('list _ arg-type)
888
`(c-func-ptr ,ret-type (list ,@arg-type)))
889
(('c-func ret-type ('list ('list _ arg-type)
891
`(c-func ,ret-type (list ,@arg-type)))
892
(('c-func-vaargs ret-type ('list ('list _ arg-type)
894
`(c-func ,ret-type (list ,@arg-type)))
897
(let ((sym (c-type->class-symbol (name-of v))))
898
(emit-definition sym `(define ,sym ,obj)))
899
(install-type (name-of v))))
902
(define (emit-define-inline type declarator function-body)
903
(define (make-bindings name-list type-list)
904
(let loop ((bindings '())
906
(name-rest name-list)
907
(type-rest type-list))
908
(if (null? name-rest)
910
(loop (cons `(,(car name-rest) (cast ,(car type-rest)
911
(list-ref %args ,i)))
916
(receive (c-type identifier)
917
(qualified-type (typespec->c-type type) declarator)
919
(('c-func-ptr ret-type ('list ('list ('quote names) types) ...))
920
(warning "'~a' is ignored. It appears in a function definition, but it is a pointer of a function in reality." identifier))
921
(('c-func ret-type ('list ('list ('quote names) types) ...))
922
(register-identifier identifier
924
(apply ,identifier args)))
925
(emit-definition identifier
926
`((with-module c-wrapper define-inline-cfunc)
927
,identifier ,ret-type ,names ,types
929
`(errorf "~a is not supported. Try cwcompile if you want to use." ,identifier)))))
930
(((? (lambda (v) (memq v '(c-func-vaargs-ptr func-vaargs))) v)
931
ret-type ('list ('list ('quote names) types) ...))
932
(warning "The inline function '~a' is ignored, because it gets variable arguments" identifier))
934
(warning "'~a' is ignored, it is not a function." identifier)))))
936
(define (emit-define-extern type init-decl)
937
(receive (c-type identifier)
938
(qualified-type (typespec->c-type type) init-decl)
939
(when (or (ignore-dlsym-check?)
940
(c-lookup-symbol identifier))
941
(and-let* ((obj (match c-type
942
(('c-func ret-type ('list ('list _ arg-type) ...))
943
`(make-c-func ',identifier
946
(('c-func-vaargs ret-type ('list ('list _ arg-type) ...))
947
`(make-c-func-vaargs ',identifier
951
`(make-c-var ',identifier ,c-type)))))
952
(register-identifier identifier obj)
953
(emit-definition identifier `(define ,identifier ,obj))))))
955
(define (emit-define-objc-class classname-list)
956
(for-each (lambda (classname)
958
(install-type classname)
959
(let ((sym (c-type->class-symbol classname)))
960
(emit-definition sym `(define ,sym (c-struct 'objc_object))))
961
(emit-definition classname
963
(objc-lookup-class ',classname)))))
966
(define (emit-objc-method keywords type-list)
967
(let ((name (apply string-append keywords)))
969
`(objc-register-method ,name
970
(list ,@(map type-of type-list))))))
972
(define (emit-define-cmacro name body)
973
(emit-definition name `(define ,name ,body)))
975
(define (emit-define-cfunclike-macro name args body)
976
(emit-definition name
977
`((with-module c-wrapper define-cfunclike-macro)
980
(define (macro-parse include-dirs headers options)
981
(call-with-process-io (cpp-command include-dirs headers options #f)
984
(let ((identifier-queue (make-queue)))
986
(for-each (lambda (macro-def)
987
(display (car macro-def) out)
989
(enqueue! identifier-queue (cdr macro-def)))
990
(queue->list (macro-queue)))
991
(close-output-port out)
992
;; skip the first line '# 1 "<stdin>"'
994
(skip (read-line in #t)))
999
((eq? (string-size line) 0)
1000
(skip (read-line in #t)))
1001
((not (eq? (string-byte-ref line 0) 35)) ;; '#' != 35 (ASCII)
1002
(skip (read-line in #t)))
1003
((string-incomplete? line)
1004
(skip (read-line in #t)))
1005
((string=? line "# 1 \"<stdin>\"")
1006
(parse-macro (read-line in #t)))
1008
(skip (read-line in #t)))))
1009
(define (parse-macro line)
1013
((queue-empty? identifier-queue)
1014
(error "[bug] lost macro body"))
1016
(let ((pos&name&args (dequeue! identifier-queue)))
1017
(filename (caar pos&name&args))
1018
(lineno (cdar pos&name&args))
1019
(parse-macro-body (string->symbol (cadr pos&name&args))
1020
(cddr pos&name&args)
1022
(parse-macro (read-line in #t)))))
1025
(define (parse-macro-body name args body-str)
1030
(and-let* ((body (call/cc (lambda (break)
1033
(for-each (lambda (arg)
1034
(hash-table-put! (arg-pool) arg #t))
1037
(with-input-from-string (string-append body-str
1040
(lexer-init (current-input-port))
1042
(c-grammar (lambda ()
1053
((or (and (not (use-iterator?)) (use-jump?))
1056
((and (not args) (not (side-effect?)))
1057
(register-identifier name body)
1058
(emit-define-cmacro name body))
1060
(register-macro name)
1061
(emit-define-cfunclike-macro name args body))
1066
;; In Linux, /usr/include/sys/types.h uses __attribute__ for these type definitions,
1067
;; but c-wrapper ignores __attribute__.
1069
(not (not (#/-linux-/ (gauche-config "--arch")))))
1071
(define (cpp-command include-dirs headers options . rest)
1072
(let-optionals* rest ((show-define? #t))
1073
(string-join (append (list GCC "'-D__attribute__(x)=' -E")
1075
'("-D__int8_t_defined")
1081
(map (cut format "-I~a" <>) include-dirs)
1082
(map (cut format "-include ~a" <>) headers)
1086
(define (install-predefined-types)
1088
(filename "/usr/include/sys/types.h")
1089
(for-each (lambda (pair)
1090
(emit-typedef (make-var-list (car pair)
1091
(%LIST (decl-identifier (cdr pair))))))
1092
'(((SIGNED char) . int8_t)
1093
((UNSIGNED char) . u_int8_t)
1094
((SIGNED short) . int16_t)
1095
((UNSIGNED short) . u_int16_t)
1096
((SIGNED int) . int32_t)
1097
((UNSIGNED int) . u_int32_t)
1098
((SIGNED long long) . int64_t)
1099
((UNSIGNED long long) . u_int64_t)))))
1101
(define (c-parse include-dirs headers options
1102
import-cond-arg export?-arg ignore-dlsym-check?-arg)
1103
(set! context (make <parse-context>))
1104
(import-cond import-cond-arg)
1105
(export? export?-arg)
1106
(ignore-dlsym-check? ignore-dlsym-check?-arg)
1107
(call-with-output-string
1108
(lambda (wrapper-out)
1109
(call-with-process-io (cpp-command include-dirs headers options)
1112
(close-output-port out)
1113
(with-input-from-port in
1116
(install-predefined-types)
1117
(c-grammar c-scan (lambda (msg . args)
1118
(errorf "~a:~a: ~a ~a (last token: ~s)"
1122
(if (null? args) "" args)
1123
(last-token)))))))))
1124
(macro-parse include-dirs headers options)
1126
(enqueue-code '(export-all) #t))
1127
(for-each (lambda (elem)
1129
(write (car elem) wrapper-out)))
1131
(set! context #f))))
1133
(provide "c-wrapper/c-parser")
added
removed
lib/c-wrapper/c-parser.scm
