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-ffi
38
(use c-wrapper.config)
42
(export c-load-library
96
make-c-array ;deprecated
103
make-bit-field ;deprecated
121
make-c-func-ptr ;deprecated
123
make-c-func-vaargs-ptr ;deprecated
126
make-c-func-type ;deprecated
134
(dynamic-load "c-ffi")
137
(select-module c-wrapper.c-ffi)
139
(define (find-dylib-from-la lafile)
140
(call-with-input-file lafile
142
(let loop ((dlname #f)
145
(str (read-line in)))
147
(test (eof-object? str)
148
(if (and dlname libdir installed?)
149
(build-path libdir dlname)
151
((#/dlname='(.+)'/ str) (#f dn)
152
(loop dn libdir installed? (read-line in)))
153
((#/libdir='(.+)'/ str) (#f lb)
154
(loop dlname lb installed? (read-line in)))
155
((#/installed=yes/ str) (#f)
156
(loop dlname libdir #t (read-line in)))
158
(loop dlname libdir installed? (read-line in))))))))
160
(define (find-library lib paths)
161
(or (and-let* ((lafile (find-file-in-paths
162
(string-append lib ".la")
164
:pred file-is-readable?)))
165
(find-dylib-from-la lafile))
166
(find-file-in-paths lib
168
:pred file-is-readable?)
169
(find-file-in-paths (string-append lib "." DYLIBEXT)
171
:pred file-is-readable?)))
173
(define (%c-load-framework name)
176
(define (c-load-library libraries . keywords)
177
(define (try-ld-script dlfile)
179
(call-with-input-file dlfile
181
(let loop ((str (read-line in)))
183
(test (eof-object? str)
185
((#/GROUP\s*\((.*)\)/ str) (#f libs)
186
(or (and-let* ((dl (find (cut #/\.so/ <>)
187
(string-split libs #[,\s]))))
188
(dlopen dl (logior RTLD_NOW RTLD_GLOBAL)))
191
(loop (read-line in)))))))))
192
(define (lib-load lib search-paths)
193
(or (and-let* ((dlfile (cond
194
((string-scan lib "/")
195
(find-library lib '(".")))
197
(or (find-library lib (ld-library-paths))
198
(search-library-with-ldconfig lib)
201
(sys-library-paths)))))))
202
(handle (or (dlopen dlfile (logior RTLD_NOW RTLD_GLOBAL))
203
(try-ld-script dlfile))))
205
(errorf "can't load ~a ~a" lib (or (and-let* ((errmsg (dlerror)))
206
(string-append "(" errmsg ")"))
208
(let-keywords* keywords ((library-dirs '())
210
(let loop ((libs (if (list? libraries)
213
(paths (if (list? library-dirs)
214
(reverse library-dirs)
215
(list library-dirs)))
216
(rest-opts (string-split option #[\s])))
217
(define (opt) (car rest-opts))
220
(for-each (cut lib-load <> (reverse paths)) (reverse libs)))
221
((string-prefix? "-l" (opt))
222
(loop (cons (string-append "lib"
223
(substring (opt) 2 (string-length (opt)))
229
((string-prefix? "-L" (opt))
231
(cons (substring (opt) 2 (string-length (opt)))
234
((string-prefix? "-Wl," (opt))
237
(append (string-split (substring (opt) 4 (string-length (opt)))
240
((string=? (car rest-opts) "-framework")
241
(%c-load-framework (cadr rest-opts))
242
(loop libs paths (cddr rest-opts)))
244
(loop libs paths (cdr rest-opts)))))))
246
(define (c-ld option)
247
(c-load-library '() :option option))
249
(define (c-lookup-symbol sym)
250
(dlsym-default (symbol->string sym)))
252
;; for Objective-C functions
254
(error "Objective-C string is not supported."))
256
(define (@selector str)
257
(error "@selector is not supported."))
260
;; basic class and functions for C type system
262
(define-class <c-type-meta> (<class>)
263
((type-name :init-value #f
264
:accessor type-name-of)
265
(ffi-type :init-value #f
266
:init-keyword :ffi-type
267
:accessor ffi-type-of)))
269
(define-class <c-type> ()
270
((buffer :init-value #f
271
:init-keyword :buffer))
272
:metaclass <c-type-meta>)
274
(define buffer-of (getter-with-setter (lambda (obj)
275
(slot-ref obj 'buffer))
277
(slot-set! obj 'buffer v))))
279
(define-method object-equal? ((obj1 <c-type-meta>) (obj2 <c-type-meta>))
280
(eq? (type-name-of obj1) (type-name-of obj2)))
282
(define-method object-equal? ((obj1 <c-type>) (obj2 <c-type>))
283
(and (eq? (class-of obj1) (class-of obj2))
284
(equal? (buffer-of obj1) (buffer-of obj2))))
286
(define-method object-hash ((obj <c-type-meta>))
287
(hash (type-name-of obj)))
289
(define-method write-object ((obj <c-type-meta>) port)
290
(format port "#<~a>" (type-name-of obj)))
292
(define-method write-object ((obj <c-type>) port)
293
(format port "#<~a ~a>" (type-name-of (class-of obj)) (buffer-of obj)))
295
(define-method initialize ((obj <c-type>) initargs)
297
(unless (buffer-of obj)
298
(set! (buffer-of obj) (make-u8vector-nonatomic (c-sizeof obj)))))
300
(define-method c-sizeof ((obj <c-type-meta>))
302
((ffi-type-of obj) => (cut slot-ref <> 'size))
306
(define-method c-sizeof ((obj <c-type>))
307
(c-sizeof (class-of obj)))
309
(define (c-type? obj)
310
(is-a? obj <c-type>))
313
;; C value class (char, short, int, long, long long, float, double)
315
(define-class <c-value-meta> (<c-type-meta>)
318
(define-class <c-value> (<c-type>)
320
:metaclass <c-value-meta>)
322
(define (%signed-uvector-alias obj)
323
(case (slot-ref (ffi-type-of (class-of obj)) 'size)
324
((1) (uvector-alias <s8vector> (buffer-of obj)))
325
((2) (uvector-alias <s16vector> (buffer-of obj)))
326
((4) (uvector-alias <s32vector> (buffer-of obj)))
327
((8) (uvector-alias <s64vector> (buffer-of obj)))
329
(error "Unsupported size: "
330
(slot-ref (ffi-type-of (class-of obj)) 'size)))))
332
(define (%unsigned-uvector-alias obj)
333
(case (slot-ref (ffi-type-of (class-of obj)) 'size)
334
((1) (uvector-alias <u8vector> (buffer-of obj)))
335
((2) (uvector-alias <u16vector> (buffer-of obj)))
336
((4) (uvector-alias <u32vector> (buffer-of obj)))
337
((8) (uvector-alias <u64vector> (buffer-of obj)))
339
(error "Unsupported size: "
340
(slot-ref (ffi-type-of (class-of obj)) 'size)))))
342
(define-syntax define-c-value
343
(syntax-rules (signed unsigned)
346
(define-class name (<c-value>)
348
(set! (ffi-type-of name) ffi-type)
349
(set! (type-name-of name) (string->symbol
350
(substring (symbol->string 'name)
353
(symbol->string 'name))
355
((_ name ffi-type signed)
357
(define-c-value name ffi-type)
358
(define-method c-value-ref ((obj name))
359
(ref (%signed-uvector-alias obj) 0))
360
(define-method c-value-set! ((obj name) v)
362
(set! (ref (%unsigned-uvector-alias obj) 0) v)
363
(set! (ref (%signed-uvector-alias obj) 0) v)))))
364
((_ name ffi-type unsigned)
366
(define-c-value name ffi-type)
367
(define-method c-value-ref ((obj name))
368
(ref (%unsigned-uvector-alias obj) 0))
369
(define-method c-value-set! ((obj name) v)
371
(set! (ref (%unsigned-uvector-alias obj) 0) v)
372
(set! (ref (%signed-uvector-alias obj) 0) v)))))
373
((_ name ffi-type uvector-class)
375
(define-c-value name ffi-type)
376
(define-method c-value-ref ((obj name))
377
(ref (uvector-alias uvector-class (buffer-of obj)) 0))
378
(define-method c-value-set! ((obj name) v)
379
(set! (ref (uvector-alias uvector-class (buffer-of obj)) 0) v))))))
381
(define-class <c-longdouble> (<c-type>)
383
:metaclass <c-type-meta>)
384
(set! (ffi-type-of <c-longdouble>) (ffi-type-longdouble))
386
(define-c-value <c-float> (ffi-type-float) <f32vector>)
387
(define-c-value <c-double> (ffi-type-double) <f64vector>)
388
(define-c-value <c-uchar> (ffi-type-uchar) unsigned)
389
(define-c-value <c-char> (ffi-type-schar) signed)
390
(define-c-value <c-ushort> (ffi-type-ushort) unsigned)
391
(define-c-value <c-short> (ffi-type-sshort) signed)
392
(define-c-value <c-uint> (ffi-type-uint) unsigned)
393
(define-c-value <c-int> (ffi-type-sint) signed)
394
(define-c-value <c-ulong> (ffi-type-ulong) unsigned)
395
(define-c-value <c-long> (ffi-type-slong) signed)
396
(define-c-value <c-ulonglong> (ffi-type-ulonglong) unsigned)
397
(define-c-value <c-longlong> (ffi-type-slonglong) signed)
399
(define-method write-object ((obj <c-value>) port)
400
(format port "#<~a ~a>" (type-name-of (class-of obj)) (c-value-ref obj)))
402
(define-method ref ((obj <c-value>))
405
(define-method (setter ref) ((obj <c-value>) (v <real>))
406
(c-value-set! obj v))
408
(define-method object-apply ((obj <c-value>))
411
(define-method object-apply ((obj <c-value>) (v <real>))
412
(c-value-set! obj v))
414
(define-method post++ ((obj <c-value>))
415
(let ((v (make (class-of obj) :buffer (u8vector-copy (buffer-of obj)))))
416
(c-value-set! obj (+ (c-value-ref obj) 1))
419
(define-method post-- ((obj <c-value>))
420
(let ((v (make (class-of obj) :buffer (u8vector-copy (buffer-of obj)))))
421
(c-value-set! obj (- (c-value-ref obj) 1))
424
(define-method pre++ ((obj <c-value>))
425
(c-value-set! obj (+ (c-value-ref obj) 1))
428
(define-method pre-- ((obj <c-value>))
429
(c-value-set! obj (- (c-value-ref obj) 1))
435
(define-class <c-void-meta> (<c-type-meta>)
439
(define-class <c-void> (<c-type>)
441
:metaclass <c-void-meta>)
443
(set! (ffi-type-of <c-void>) (ffi-type-void))
444
(set! (type-name-of <c-void>) 'c-void)
446
(define-method write-object ((obj <c-void>) port)
447
(format port "#<~a>" (type-name-of (class-of obj))))
452
(define-class <c-basic-ptr-meta> (<c-type-meta>)
456
(define-class <c-basic-ptr> (<c-type>)
460
(define-method write-object ((obj <c-basic-ptr>) port)
461
(format port "#<~a 0x~x>" (type-name-of (class-of obj)) (c-ptr-ref obj)))
463
(define-method c-ptr-ref ((ptr <c-basic-ptr>))
464
(ref (%unsigned-uvector-alias ptr) 0))
466
(define-method c-ptr-set! ((obj <c-basic-ptr>) (v <integer>))
468
(set! (ref (%unsigned-uvector-alias obj) 0) v)
469
(set! (ref (%signed-uvector-alias obj) 0) v)))
472
(define-method c-ptr-set! ((obj <c-basic-ptr>) (v <c-basic-ptr>))
473
(u8vector-copy! (buffer-of obj) 0 (buffer-of v)))
475
(define-method ref ((obj <c-basic-ptr>))
478
(define-method (setter ref) ((obj <c-basic-ptr>) v)
484
(define-class <c-ptr-meta> (<c-basic-ptr-meta>)
485
((orig-c-type :accessor orig-c-type-of))
488
(define-class <c-ptr> (<c-basic-ptr>)
489
((finalizer :init-value #f
490
:accessor finalizer-of))
491
:metaclass <c-ptr-meta>)
494
(let ((tbl (make-hash-table 'equal?)))
496
(unless (hash-table-exists? tbl c-type)
498
tbl c-type (let ((class (make <c-ptr-meta>
500
:supers (list <c-ptr>)
502
:defined-modules (list (current-module)))))
503
(set! (ffi-type-of class) (ffi-type-pointer))
504
(set! (type-name-of class)
505
(string->symbol (format "c-ptr:<~a>"
506
(type-name-of c-type))))
507
(set! (orig-c-type-of class) c-type)
509
(hash-table-get tbl c-type))))
511
(define-method ptr ((c-type <c-type-meta>))
514
(define-method c-ptr-set! ((obj <c-ptr>) (v <string>))
515
(c-ptr-set! obj (cast (ptr <c-char>) v)))
517
(define-method ref ((obj <c-ptr>) (n <integer>))
518
(c-array-ref (cast (c-array (orig-c-type-of (class-of obj)) #f) obj) n))
520
(define-method post++ ((obj <c-ptr>))
521
(let ((v (make (class-of obj) :buffer (u8vector-copy (buffer-of obj)))))
522
(c-ptr-set! obj (+ (c-ptr-ref obj)
523
(c-sizeof (orig-c-type-of (class-of obj)))))
526
(define-method post-- ((obj <c-ptr>))
527
(let ((v (make (class-of obj) :buffer (u8vector-copy (buffer-of obj)))))
528
(c-ptr-set! obj (- (c-ptr-ref obj)
529
(c-sizeof (orig-c-type-of (class-of obj)))))
532
(define-method pre++ ((obj <c-ptr>))
533
(c-ptr-set! obj (+ (c-ptr-ref obj)
534
(c-sizeof (orig-c-type-of (class-of obj)))))
537
(define-method pre-- ((obj <c-ptr>))
538
(c-ptr-set! obj (- (c-ptr-ref obj)
539
(c-sizeof (orig-c-type-of (class-of obj)))))
542
(define (c-ptr+ ptr n)
543
(let ((newptr (make (class-of ptr))))
544
(c-ptr-set! newptr (+ (c-ptr-ref ptr)
545
(* (c-sizeof (orig-c-type-of (class-of ptr))) n)))
548
(define (c-ptr- ptr n)
551
(define (register-finalizer! ptrobj proc)
552
(set! (finalizer-of ptrobj) proc)
553
(%register-finalizer! ptrobj))
555
(define (unregister-finalizer! ptrobj)
556
(set! (finalizer-of ptrobj) #f)
557
(%unregister-finalizer! ptrobj))
559
(define (finalize! ptrobj)
560
(and-let* ((proc (finalizer-of ptrobj)))
561
(set! (finalizer-of ptrobj) #f)
563
(%unregister-finalizer! ptrobj))
565
(define (make-c-var identifier type)
566
(or (and-let* ((vptr (c-lookup-symbol identifier)))
567
(deref (cast (ptr type) vptr)))
568
(errorf "variable ~a is not found." identifier)))
573
(define-class <c-func-ptr-meta> (<c-basic-ptr-meta>)
574
((ret-type :accessor ret-type-of)
575
(arg-types :accessor arg-types-of)))
577
(define-method object-equal? ((obj1 <c-func-ptr-meta>) (obj2 <c-func-ptr-meta>))
578
(and (equal? (ret-type-of obj1) (ret-type-of obj2))
579
(equal? (arg-types-of obj1) (arg-types-of obj2))))
581
(define-method object-hash ((obj <c-func-ptr-meta>))
582
(logxor (hash (ret-type-of obj)) (hash (arg-types-of obj))))
584
(define-class <c-func-ptr> (<c-basic-ptr>)
586
:metaclass <c-func-ptr-meta>)
588
(define (normalize-arg-types arg-types)
591
(let ((t (if (pair? atype) (cadr atype) atype)))
593
((is-a? t <c-array-meta>)
595
(ptr (element-type-of t)))
599
(errorf "can't use the incomplete type ~a as a parameter" t))
604
(define (normalize-ret-type ret-type)
606
((is-a? ret-type <c-array-meta>)
608
(ptr (element-type-of ret-type)))
609
((= (c-sizeof ret-type) 0)
610
(errorf "can't use the incomplete type ~a as a return type" ret-type))
614
(define (c-func-ptr ret-type arg-types . _)
615
(let ((class (make <c-func-ptr-meta>
617
:supers (list <c-func-ptr>)
619
:defined-modules (list (current-module)))))
620
(set! (ffi-type-of class) (ffi-type-pointer))
621
(set! (type-name-of class) 'c-func-ptr)
622
(set! (ret-type-of class) (normalize-ret-type ret-type))
623
(set! (arg-types-of class) (normalize-arg-types arg-types))
627
(define make-c-func-ptr c-func-ptr)
629
(define (c-func-vaargs-ptr ret-type arg-types . _)
630
(c-func-ptr ret-type arg-types))
633
(define make-c-func-vaargs-ptr c-func-vaargs-ptr)
635
(define-class <c-func> ()
636
((ret-type :init-keyword :ret-type
637
:accessor ret-type-of)
638
(arg-types :init-keyword :arg-types
639
:accessor arg-types-of)))
641
(define (c-func ret-type arg-types . _)
642
(make <c-func> :ret-type ret-type :arg-types arg-types))
645
(define make-c-func-type c-func)
647
(define-method ptr ((func-type <c-func>))
648
(c-func-ptr (ret-type-of func-type)
649
(arg-types-of func-type)))
651
(define-method deref ((fptr <c-func-ptr>))
652
(let ((func-type (class-of fptr)))
653
(%make-c-func-vaargs fptr (ret-type-of func-type) (arg-types-of func-type))))
655
(define-method object-apply ((fptr <c-func-ptr>) . args)
656
(apply (deref fptr) args))
661
(define-class <c-array-meta> (<c-type-meta>)
662
((element-type :accessor element-type-of)
663
(size :accessor size-of)))
665
(define-method object-equal? ((obj1 <c-array-meta>) (obj2 <c-array-meta>))
666
(and (equal? (element-type-of obj1) (element-type-of obj2))
667
(equal? (size-of obj1) (size-of obj2))))
669
(define-method object-hash ((obj <c-array-meta>))
670
(logxor (hash (element-type-of obj)) (hash (size-of obj))))
672
(define-class <c-array> (<c-type> <sequence>)
676
(let ((tbl (make-hash-table 'equal?)))
677
(lambda (element-type size)
678
(let ((key (list element-type size)))
679
(unless (hash-table-exists? tbl key)
681
tbl key (let ((class (make <c-array-meta>
683
:supers (list <c-array>)
685
:defined-modules (list (current-module))))
686
(size (if size size 0)))
687
(set! (ffi-type-of class)
688
(make-ffi-array-type (ffi-type-of element-type) size))
689
(set! (type-name-of class)
690
(string->symbol (format "c-array:~a[~a]"
691
(type-name-of element-type)
693
(set! (element-type-of class) element-type)
694
(set! (size-of class) size)
696
(hash-table-get tbl key)))))
699
(define (make-c-array element-type size)
700
(c-array element-type size))
702
(define (c-array-ref obj index)
703
(let* ((start (* index (c-sizeof (element-type-of (class-of obj)))))
704
(end (+ start (c-sizeof (element-type-of (class-of obj))))))
705
(scm-cast (make (element-type-of (class-of obj))
706
:buffer (uvector-alias <u8vector>
707
(if (= (size-of (class-of obj)) 0)
708
(%expand-u8vector (buffer-of obj) end)
712
(define (c-array-set! obj index value)
713
(let* ((tstart (* index (c-sizeof (element-type-of (class-of obj)))))
714
(send (c-sizeof (element-type-of (class-of obj))))
715
(casted-value (cast (element-type-of (class-of obj)) value)))
717
(if (= (size-of (class-of obj)) 0)
718
(%expand-u8vector (buffer-of obj) (+ tstart send))
720
tstart (buffer-of casted-value) 0 send)))
722
(define (c-array-length array)
723
(size-of (class-of array)))
725
(define-method object-apply ((c-type <c-type-meta>) (size <integer>))
726
(c-array c-type size))
728
;; gauche.sequence support
729
(define-method call-with-iterator ((array <c-array>) proc . args)
730
(let-keywords* args ((start 0))
733
(<= (size-of array) i))
736
(c-array-ref array i)
739
(define-method size-of ((array <c-array>))
740
(c-array-length array))
742
(define-method referencer ((obj <c-array>)) c-array-ref)
744
(define-method modifier ((obj <c-array>)) c-array-set!)
750
(define-class <c-struct-meta> (<c-type-meta>)
751
((decl-alist :accessor decl-alist-of)
752
(unnamed-alist :accessor unnamed-alist-of)))
754
(define-class <c-struct> (<c-type>)
757
(define (c-struct-symbol tagname)
758
(string->symbol (format "<c-struct:~a>" tagname)))
760
(define-macro (define-c-struct tagname)
761
(let ((classname (c-struct-symbol tagname)))
763
(define-class ,classname (<c-struct>)
765
:metaclass <c-struct-meta>)
766
(set! ((with-module c-wrapper.c-ffi type-name-of) ,classname)
767
(string->symbol (string-append "c-struct:"
768
(symbol->string ',tagname)))))))
770
(define-class <bit-field> ()
771
((bits :init-keyword :bits
773
(signed? :init-keyword :signed?
775
(shift :accessor shift-of)
776
(leader? :accessor leader?)
777
(bit-mask :allocation :virtual
779
:slot-ref (lambda (obj)
780
(- (expt 2 (bits-of obj)) 1)))))
782
(define (bit-field? obj)
783
(is-a? obj <bit-field>))
785
(define (follower? obj)
788
(define-method ffi-type-of ((obj <bit-field>))
789
(ffi-type-of <c-uint>))
791
(define-method c-sizeof ((obj <bit-field>))
794
(define-method leader? ((obj <c-type-meta>))
797
(define (c-bit-field c-type num)
798
(make <bit-field> :bits num :signed? (eq? c-type <c-int>)))
801
(define make-bit-field c-bit-field)
803
(define (init-decl-alist! alist)
804
(define (dispatch rest accum)
808
((bit-field? (cdar rest))
809
(do-bit-field (cdar rest) (cdr rest) accum))
811
(dispatch (cdr rest) 0))))
812
(define (do-bit-field bit-field rest accum)
813
(if (< (* (c-sizeof <c-uint>) 8) (+ accum (bits-of bit-field)))
814
(do-bit-field bit-field rest 0)
816
(set! (shift-of bit-field) (if (big-endian?)
817
(- (* (c-sizeof <c-uint>) 8)
821
(set! (leader? bit-field) (= accum 0))
822
(dispatch rest (+ accum (bits-of bit-field))))))
825
(define (unnamed-symbol? sym)
826
(#/^%unnamed/ (symbol->string sym)))
828
(define (make-unnamed-alist decl-alist)
829
(define (%member-unnamed-alist type unnamed-name knil)
830
(fold (lambda (pair result)
831
(match-let (((sym . mem-type) pair))
832
(if (unnamed-symbol? sym)
833
(%member-unnamed-alist mem-type unnamed-name result)
834
(cons (cons sym unnamed-name) result))))
836
(decl-alist-of type)))
837
(fold (lambda (pair result)
838
(match-let (((sym . mem-type) pair))
839
(if (unnamed-symbol? sym)
840
(%member-unnamed-alist mem-type sym result)
845
(define (unnamed-member class name)
846
(assoc-ref (unnamed-alist-of class) name #f))
848
(define (init-c-struct! class alist)
849
(let ((decl-alist (init-decl-alist! alist)))
850
(set! (ffi-type-of class)
851
(make-ffi-struct-type (map (lambda (pair)
852
(ffi-type-of (cdr pair)))
853
(remove (lambda (pair)
854
(or (follower? (cdr pair))
855
;; remove zero-sized array
856
(= (c-sizeof (cdr pair)) 0)))
858
(set! (decl-alist-of class) decl-alist)
859
(set! (unnamed-alist-of class) (make-unnamed-alist decl-alist)))
862
(define-method align (offset (alignment <integer>))
863
(+ (logior (- offset 1) (- alignment 1)) 1))
865
(define-method align (offset (c-type <c-type-meta>))
866
(align offset (slot-ref (ffi-type-of c-type) 'alignment)))
868
(define-method align (offset (bit-field <bit-field>))
869
(if (leader? bit-field)
870
(align offset <c-uint>)
873
(define-method c-struct-get-value (obj offset (c-type <c-type-meta>))
874
(make c-type :buffer (uvector-alias <u8vector>
877
(+ offset (c-sizeof c-type)))))
879
(define-method c-struct-get-value (obj offset (bit-field <bit-field>))
880
(let* ((v (make <c-uint>
881
:buffer (uvector-alias <u8vector>
884
(+ offset (c-sizeof <c-uint>)))))
885
(n (logand (ash (c-value-ref v) (- (shift-of bit-field)))
886
(bit-mask-of bit-field))))
887
(if (and (signed? bit-field) (< (ash (bit-mask-of bit-field) -1) n))
888
(- -1 (logand (lognot n) (bit-mask-of bit-field)))
891
(define-method c-struct-set-value! (obj offset (c-type <c-type-meta>) value)
892
(u8vector-copy! (buffer-of obj) offset
893
(buffer-of (cast c-type value))
897
(define-method c-struct-set-value! (obj offset (bit-field <bit-field>) value)
898
(let1 intval (make <c-uint>
899
:buffer (u8vector-copy (buffer-of obj)
900
offset (+ offset (c-sizeof <c-uint>))))
901
(c-value-set! intval (logior (logand (c-value-ref intval)
902
(lognot (ash (bit-mask-of bit-field)
903
(shift-of bit-field))))
904
(ash (logand (cast <integer> value)
905
(bit-mask-of bit-field))
906
(shift-of bit-field))))
907
(u8vector-copy! (buffer-of obj) offset
908
(buffer-of intval) 0 (c-sizeof intval))))
910
(define (next-offset offset type rest)
914
((follower? (cdar rest))
917
(+ offset (c-sizeof type)))))
919
(define-syntax c-struct
922
(global-variable-ref (current-module) (c-struct-symbol tagname)))))
924
(define (offset&type struct-class name)
925
(let loop ((rest (decl-alist-of struct-class))
928
(errorf "~a doesn't have such element: ~a" struct-class name))
929
(let ((elem-name (caar rest))
930
(elem-type (cdar rest)))
931
(set! offset (align offset elem-type))
932
(if (eq? elem-name name)
933
(values offset elem-type)
934
(loop (cdr rest) (next-offset offset elem-type (cdr rest)))))))
936
(define (c-offsetof struct-class name)
937
(receive (offset elem-type) (offset&type struct-class name)
940
(define (c-struct-ref obj name . args)
941
(let-optionals* args ((auto-cast? #t))
942
(or (and-let* ((unnamed-name (unnamed-member (class-of obj) name)))
943
(ref (c-struct-ref obj unnamed-name) name auto-cast?))
944
(receive (offset elem-type) (offset&type (class-of obj) name)
945
(let ((result (c-struct-get-value obj offset elem-type)))
950
(define (c-struct-set! obj name value)
951
(or (and-let* ((unnamed-name (unnamed-member (class-of obj) name)))
952
(set! (ref (c-struct-ref obj unnamed-name) name) value))
953
(receive (offset elem-type) (offset&type (class-of obj) name)
954
(c-struct-set-value! obj offset elem-type value))))
956
(define-method ref ((obj <c-struct>) (name <symbol>) . rest)
957
(apply c-struct-ref obj name rest))
959
(define-method (setter ref) ((obj <c-struct>) (name <symbol>) value)
960
(c-struct-set! obj name value))
962
(define-method raw-ref ((obj <c-struct>) (name <symbol>))
963
(c-struct-ref obj name #f))
965
(define-method ref ((obj <c-ptr>) (name <symbol>))
966
(ref (deref obj) name))
968
(define-method (setter ref) ((obj <c-ptr>) (name <symbol>) value)
969
(set! (ref (deref obj) name) value))
974
(define-class <c-union-meta> (<c-type-meta>)
975
((decl-alist :accessor decl-alist-of)
976
(unnamed-alist :accessor unnamed-alist-of)))
978
(define-class <c-union> (<c-type>)
981
(define (c-union-symbol tagname)
982
(string->symbol (format "<c-union:~a>" tagname)))
984
(define-macro (define-c-union tagname)
985
(let ((classname (c-union-symbol tagname)))
987
(define-class ,classname (<c-union>)
989
:metaclass <c-union-meta>)
990
(set! ((with-module c-wrapper.c-ffi type-name-of) ,classname)
991
(string->symbol (string-append "c-union:"
992
(symbol->string ',tagname)))))))
994
(define (init-c-union! class decl-alist)
995
(set! (ffi-type-of class)
996
(make-ffi-struct-type
997
(list (ffi-type-of (fold (lambda (p c-type)
1000
(c-sizeof (cdr p))))
1005
(set! (decl-alist-of class) decl-alist)
1006
(set! (unnamed-alist-of class) (make-unnamed-alist decl-alist))
1009
(define-syntax c-union
1012
(global-variable-ref (current-module) (c-union-symbol tagname)))))
1014
(define (c-union-ref obj name . args)
1015
(let-optionals* args ((auto-cast? #t))
1016
(or (and-let* ((unnamed-name (unnamed-member (class-of obj) name)))
1017
(ref (c-union-ref obj unnamed-name) name auto-cast?))
1018
(or (and-let* ((pair (assq name (decl-alist-of (class-of obj)))))
1019
(let* ((elem-type (cdr pair))
1021
:buffer (uvector-alias <u8vector> (buffer-of obj)
1022
0 (c-sizeof elem-type)))))
1026
(errorf "~a doesn't have such element: ~a" (class-of obj) name)))))
1028
(define (c-union-set! obj name value)
1029
(or (and-let* ((unnamed-name (unnamed-member (class-of obj) name)))
1030
(set! (ref (c-union-ref obj unnamed-name) name) value))
1031
(or (and-let* ((pair (assq name (decl-alist-of (class-of obj)))))
1032
(let1 elem-type (cdr pair)
1033
(u8vector-copy! (buffer-of obj) 0
1034
(buffer-of (cast elem-type value))
1035
0 (c-sizeof elem-type))))
1036
(errorf "~a doesn't have such element: ~a" (class-of obj) name))))
1038
(define-method ref ((obj <c-union>) (name <symbol>) . rest)
1039
(apply c-union-ref obj name rest))
1041
(define-method (setter ref) ((obj <c-union>) (name <symbol>) value)
1042
(c-union-set! obj name value))
1044
(define-method raw-ref ((obj <c-union>) (name <symbol>))
1045
(c-union-ref obj name #f))
1050
(define-syntax c-enum
1055
(define (init-c-enum! class enum-symbols)
1059
;; functions to make pointer and dereference
1061
(define-method ptr ((obj <c-type>))
1064
(define-method deref ((obj <c-ptr>))
1067
(define-method (setter deref) ((obj <c-ptr>) value)
1068
(let ((deref-obj (deref obj))
1069
(casted-value (cast (orig-c-type-of (class-of obj)) value)))
1070
(u8vector-copy! (buffer-of deref-obj) 0 (buffer-of casted-value))))
1073
;; functions and macro to define C function and closure
1075
(define (errchk func . args)
1076
(receive (status result) (apply func args)
1078
((eq? status FFI_OK) result)
1079
((eq? status FFI_BAD_TYPEDEF)
1080
(error "One of the ffi_type objects that ffi_prep_cif came across is bad."))
1081
((eq? status FFI_BAD_ABI)
1082
(error "FFI_BAD_ABI"))
1084
(error "Unknown error: " status)))))
1086
(define (c++-type->str type)
1088
((is-a? type <c-ptr-meta>)
1089
(string-append "P" (type->str (orig-c-type-of type))))
1090
((is-a? type <c-struct-meta>)
1091
(let ((name ((#/<c-struct:(.*)>/ (symbol->string (class-name type))) 1)))
1092
(format "~a~a" (string-length name) name)))
1093
((is-a? type <c-union-meta>)
1094
(let ((name ((#/<c-union:(.*)>/ (symbol->string (class-name type))) 1)))
1095
(format "~a~a" (string-length name) name)))
1096
((is-a? type <c-array-meta>)
1097
(format "P~a" (type->str (element-type-of type))))
1098
((eq? type <c-void>) "v")
1099
((eq? type <c-uchar>) "h")
1100
((eq? type <c-char>) "c")
1101
((eq? type <c-short>) "s")
1102
((eq? type <c-ushort>) "t")
1103
((eq? type <c-int>) "i")
1104
((eq? type <c-uint>) "j")
1105
((eq? type <c-long>) "l")
1106
((eq? type <c-ulong>) "m")
1107
((eq? type <c-longlong>) "x")
1108
((eq? type <c-ulonglong>) "y")
1109
((eq? type <c-float>) "f")
1110
((eq? type <c-double>) "d")
1111
((eq? type <c-longdouble>) "e")
1112
((eq? type 'ellipsis) "z")))
1114
(define (c++-mangle name arg-types)
1115
(string->symbol (format "_Z~a~a~a" (string-length (symbol->string name)) name
1116
(apply string-append
1118
(if (null? arg-types)
1122
(define (make-c-func identifier ret-type arg-types . opts)
1123
(let-keywords* opts ((c++? #f))
1124
(let* ((fptr (or (c-lookup-symbol (if c++?
1125
(c++-mangle identifier arg-types)
1127
(errorf "function ~a is not found." identifier)))
1128
(nret-type (normalize-ret-type ret-type))
1129
(narg-types (normalize-arg-types arg-types))
1130
(cif (errchk ffi-prep-cif
1131
(ffi-type-of nret-type)
1132
(map ffi-type-of narg-types))))
1134
(unless (eq? (length narg-types) (length args))
1136
(errorf "wrong number of arguments: ~a requires ~a, but got ~a"
1140
(let ((rvalue (make nret-type)))
1141
(ffi-call cif fptr (ptr rvalue) (map ptr (map (lambda (c-type v)
1144
(scm-cast rvalue))))))
1146
(define (%make-c-func-vaargs fptr ret-type arg-types)
1147
(define (promote value)
1149
((is-a? value <integer>)
1150
(cast <c-int> value))
1151
((is-a? value <real>)
1152
(cast <c-double> value))
1153
((is-a? value <string>)
1154
(cast (ptr <c-char>) value))
1155
((memq (class-of value) (list <c-char> <c-short>))
1156
(cast <c-int> value))
1157
((memq (class-of value) (list <c-uchar> <c-ushort>))
1158
(cast <c-uint> value))
1159
((is-a? value <c-float>)
1160
(cast <c-double> value))
1161
((is-a? value <c-type>)
1164
(errorf "<c-type> required, but got ~s" value))))
1165
(let ((nret-type (normalize-ret-type ret-type))
1166
(narg-types (normalize-arg-types arg-types)))
1168
(unless (<= (length narg-types) (length args))
1169
(errorf "wrong number of arguments: ~a requires more than ~a, but got ~a"
1173
(receive (constant-args variable-args)
1174
(split-at args (length narg-types))
1175
(let* ((promoted-args (append (map (lambda (c-type v)
1177
narg-types constant-args)
1178
(map promote variable-args)))
1179
(cif (errchk ffi-prep-cif
1180
(ffi-type-of nret-type)
1182
(ffi-type-of (class-of obj)))
1184
(rvalue (make nret-type)))
1185
(ffi-call cif fptr (ptr rvalue) (map (lambda (v)
1188
(scm-cast rvalue))))))
1190
(define (make-c-func-vaargs identifier ret-type arg-types . opts)
1191
(let-keywords* opts ((c++? #f))
1192
(%make-c-func-vaargs (or (c-lookup-symbol
1194
(c++-mangle identifier
1195
(append arg-types '(ellipsis)))
1197
(errorf "function ~a is not found." identifier))
1201
(define-class <c-closure-key> ()
1202
((fp-class :init-keyword :fp-class
1203
:accessor fp-class-of)
1204
(proc :init-keyword :proc
1205
:accessor proc-of)))
1207
(define-method object-equal? ((obj1 <c-closure-key>) (obj2 <c-closure-key>))
1208
(and (equal? (fp-class-of obj1) (fp-class-of obj2))
1209
(eq? (proc-of obj1) (proc-of obj2))))
1211
(define-method object-hash ((obj <c-closure-key>))
1212
(hash (fp-class-of obj)))
1214
(define closure-table (make-hash-table 'equal?))
1216
(define (make-c-closure fp-class proc)
1217
(let ((key (make <c-closure-key> :fp-class fp-class :proc proc)))
1218
(unless (hash-table-exists? closure-table key)
1219
(let* ((cif (errchk ffi-prep-cif
1220
(ffi-type-of (ret-type-of fp-class))
1221
(map ffi-type-of (arg-types-of fp-class))))
1222
(closure (cast fp-class
1223
(errchk ffi-prep-closure cif
1225
(let ((rvalue (cast (ret-type-of fp-class)
1226
(apply proc (map (lambda (c-type pointer)
1227
(scm-cast (deref (cast (ptr c-type) pointer))))
1228
(arg-types-of fp-class)
1231
(hash-table-put! closure-table key closure)))
1232
(hash-table-get closure-table key)))
1234
(define (c-closure-free closure)
1235
(for-each (cut hash-table-delete! closure-table <>)
1236
(hash-table-fold closure-table
1237
(lambda (key val kons)
1238
(if (eq? val closure)
1246
(define-method cast (class value)
1247
(if (is-a? value class)
1249
(errorf "cast ~a to ~a is not allowed." value class)))
1251
(define-method cast ((c-type <c-type-meta>) (value <c-value>))
1252
(cast c-type (c-value-ref value)))
1254
(define-method cast ((c-type <c-value-meta>) (value <real>))
1255
(let ((new-value (make c-type)))
1256
(c-value-set! new-value value)
1259
(define-method cast ((c-type <c-value-meta>) (value <c-basic-ptr>))
1260
(let ((v (c-ptr-ref value))
1261
(new-value (make c-type)))
1262
(c-value-set! new-value v)
1265
(define-method cast ((c-type <c-value-meta>) (value <boolean>))
1266
(let ((new-value (make c-type)))
1267
(c-value-set! new-value (if value 1 0))
1270
(define-method cast ((c-type <c-basic-ptr-meta>) (num <integer>))
1272
(cast c-type (make-null-ptr))
1273
(let ((new-ptr (make c-type)))
1274
(c-ptr-set! new-ptr num)
1277
(define-method cast ((c-type <c-basic-ptr-meta>) (p <c-basic-ptr>))
1278
(make c-type :buffer (buffer-of p)))
1280
(define-method cast ((c-type <c-ptr-meta>) (str <string>))
1281
(let ((vec (make-u8vector (+ (string-size str) 1) 0)))
1282
(%ptr-uvector c-type (string->u8vector! vec 0 str))))
1284
(define-method cast ((c-type <c-ptr-meta>) (array <c-array>))
1285
(%ptr-uvector c-type (buffer-of array)))
1287
(define-method cast ((c-type <c-ptr-meta>) (array <uvector>))
1288
(%ptr-uvector c-type (uvector-alias <u8vector> array)))
1290
(define-method cast ((c-type <c-ptr-meta>) (seq <sequence>))
1291
(cast c-type (cast (c-array (orig-c-type-of c-type) (size-of seq)) seq)))
1293
(define-method cast ((c-type <c-ptr-meta>) (fptr <foreign-pointer>))
1294
(foreign-pointer->c-ptr c-type fptr))
1296
(define-method cast ((c-type <c-array-meta>) (seq <sequence>))
1297
(let ((array (make c-type)))
1298
(dotimes (i (size-of seq) array)
1299
(c-array-set! array i (ref seq i)))))
1301
(define-method cast ((c-type <c-array-meta>) (p <c-ptr>))
1302
(deref (cast (ptr c-type) p)))
1304
(define-method cast ((c-type <c-func-ptr-meta>) (proc <procedure>))
1305
(make-c-closure c-type proc))
1307
;; There is no conversion if you change a function-pointer's type to
1308
;; other function-pointer type.
1309
;; Some function pointers which allow any arguments are defined
1310
;; as "ret_type (*fn)()" in header files. This cast rule is for the case.
1311
(define-method cast ((c-type <c-func-ptr-meta>) (func-ptr <c-func-ptr>))
1314
;; This cast will be called when c-closure's return is void.
1315
(define-method cast ((c-type <c-void-meta>) value)
1318
(define-method cast (class (value <c-value>))
1320
((eq? class <integer>)
1321
(x->integer (c-value-ref value)))
1322
((memq class (class-precedence-list <real>))
1323
(c-value-ref value))
1324
((eq? class <boolean>)
1325
(if (= (c-value-ref value) 0) #f #t))
1329
(define-method cast (class (value <real>))
1331
((eq? class <integer>)
1333
((memq class (class-precedence-list <real>))
1335
((eq? class <boolean>)
1336
(if (= value 0) #f #t))
1340
(define-method cast (class (value <c-basic-ptr>))
1342
((memq class (class-precedence-list <integer>))
1344
((eq? class <string>)
1345
(ptr->string value))
1349
(define-method cast (class (value <c-array>))
1350
(cast class (ptr value)))
1352
(define-method cast ((coll-class <class>) (array <c-array>))
1353
(if (memq <collection> (class-precedence-list coll-class))
1354
(map-to coll-class scm-cast array)
1357
(define-method scm-cast ((value <c-value>))
1358
(c-value-ref value))
1360
(define-method scm-cast ((value <c-void>))
1363
(define-method scm-cast (obj)
1366
(define-method x->string ((obj <c-ptr>))
1367
(cast <string> obj))
1369
(define-method x->string ((obj <c-array>))
1370
(cast <string> (ptr obj)))
1372
(define-method x->number ((obj <c-value>))
1375
(provide "c-wrapper/c-ffi")
added
removed
lib/c-wrapper/c-ffi.scm
