rewrote ypsilon FFI compatibility layer to be simpler and to provide
better error checking.
This commit is contained in:
Abdulaziz Ghuloum
parent
9f53841fb9
commit
c8d0baa341
|
|
@ -1,273 +0,0 @@
|
|||
|
||||
(library (core)
|
||||
(export iota string-contains architecture-feature format
|
||||
flonum->float string->cstring load-shared-object
|
||||
lookup-shared-object
|
||||
stdcall-shared-object->void
|
||||
stdcall-shared-object->int
|
||||
stdcall-shared-object->intptr
|
||||
stdcall-shared-object->double
|
||||
make-callback
|
||||
usleep microsecond)
|
||||
(import (except (ikarus) library format)
|
||||
(except (ikarus system $foreign) make-callback))
|
||||
|
||||
(define (format what str . args)
|
||||
(import (ikarus))
|
||||
(cond
|
||||
[(eq? what #f)
|
||||
(apply printf str args)]
|
||||
[else
|
||||
(apply format str args)]))
|
||||
|
||||
(define (iota n i)
|
||||
(cond
|
||||
[(= n 0) '()]
|
||||
[else (cons i (iota (- n 1) (+ i 1)))]))
|
||||
|
||||
(define (architecture-feature what)
|
||||
(case what
|
||||
[(operating-system) "darwin"]
|
||||
[(alignof:int) 4]
|
||||
[(sizeof:int) 4]
|
||||
[else (error 'architecture-feature "invalid args" what)]))
|
||||
|
||||
(define (string-contains text s)
|
||||
(define (starts-at? i)
|
||||
(let f ([i i] [j 0])
|
||||
(cond
|
||||
[(= j (string-length s)) #t]
|
||||
[(= i (string-length text)) #f]
|
||||
[else
|
||||
(and (char=? (string-ref text i) (string-ref s j))
|
||||
(f (+ i 1) (+ j 1)))])))
|
||||
(let f ([i 0])
|
||||
(cond
|
||||
[(= i (string-length text)) #f]
|
||||
[(starts-at? i) #t]
|
||||
[else (f (+ i 1))])))
|
||||
|
||||
(define-record-type library (fields name pointer))
|
||||
|
||||
(define (load-shared-object libname)
|
||||
(make-library libname
|
||||
(or (dlopen libname)
|
||||
(error 'load-shared-object (dlerror) libname))))
|
||||
|
||||
(define-record-type shared-object
|
||||
(fields name lib [mutable proc] pointer))
|
||||
|
||||
(define (lookup-shared-object lib name)
|
||||
(define who 'lookup-shared-object)
|
||||
(unless (symbol? name) (die who "not a symbol" name))
|
||||
(unless (library? lib) (die who "not a library" lib))
|
||||
(make-shared-object name lib #f
|
||||
(or (dlsym (library-pointer lib) (symbol->string name))
|
||||
(error who
|
||||
(format #f "cannot find object ~a in library ~a"
|
||||
name (library-name lib))))))
|
||||
|
||||
|
||||
(define get-ffi
|
||||
(let ([ffis '()])
|
||||
(lambda (return-type arg-types)
|
||||
(let ([x (cons return-type arg-types)])
|
||||
(cond
|
||||
[(assoc x ffis) => cdr]
|
||||
[else
|
||||
(let ([ffi (make-ffi return-type arg-types)])
|
||||
(set! ffis (cons (cons x ffi) ffis))
|
||||
ffi)])))))
|
||||
|
||||
(define (arg->arg-type who)
|
||||
(define (err who x)
|
||||
(error 'arg->arg-type
|
||||
(format #f "cannot handle conversion for procedure ~a" who)
|
||||
x))
|
||||
(lambda (arg)
|
||||
(cond
|
||||
[(bytevector? arg) 'pointer]
|
||||
[(vector? arg) 'pointer]
|
||||
[(cstring? arg) 'pointer]
|
||||
[(pointer? arg) 'pointer]
|
||||
[(cfloat? arg) 'float]
|
||||
[(flonum? arg) 'double]
|
||||
[(or (fixnum? arg) (bignum? arg)) 'sint32]
|
||||
[else (err who arg)])))
|
||||
|
||||
|
||||
(define (convert-incoming type result)
|
||||
(define who 'convert-incoming)
|
||||
(case type
|
||||
[(void) (void)]
|
||||
[(sint32) result]
|
||||
[(pointer) result]
|
||||
[else (error who "unhandled type" type)]))
|
||||
|
||||
(define (convert-outgoing type arg)
|
||||
(define who 'convert-outgoing)
|
||||
(case type
|
||||
[(pointer)
|
||||
(cond
|
||||
[(bytevector? arg) (bytevector->blob arg)]
|
||||
[(vector? arg) (vector->blob arg)]
|
||||
[(cstring? arg) (cstring-pointer arg)]
|
||||
[(pointer? arg) arg]
|
||||
[else (error who "no converter for" type arg)])]
|
||||
[(sint32)
|
||||
(cond
|
||||
[(or (fixnum? arg) (bignum? arg)) arg]
|
||||
[else (error who "no converter for" type arg)])]
|
||||
[(float)
|
||||
(cond
|
||||
[(cfloat? arg) (cfloat-value arg)]
|
||||
[else (error who "no converter for" type arg)])]
|
||||
[(double)
|
||||
(cond
|
||||
[(flonum? arg) arg]
|
||||
[else (error who "no converter for" type arg)])]
|
||||
[else (error who "unhandled type" type)]))
|
||||
|
||||
(define (wrap-conversion who return-type arg-types f)
|
||||
(lambda args
|
||||
(unless (= (length args) (length arg-types))
|
||||
(error who "incorrect number of arguments" args))
|
||||
(let ([args (map convert-outgoing arg-types args)])
|
||||
(let ([result (apply f args)])
|
||||
(convert-incoming return-type result)))))
|
||||
|
||||
|
||||
(define (make-proc who obj return-type args)
|
||||
(let ([arg-types (map (arg->arg-type who) args)])
|
||||
(let ([ffi (get-ffi return-type arg-types)])
|
||||
(wrap-conversion
|
||||
(shared-object-name obj)
|
||||
return-type arg-types
|
||||
(ffi (shared-object-pointer obj))))))
|
||||
|
||||
|
||||
(define (get-proc who obj return-type args)
|
||||
(unless (shared-object? obj)
|
||||
(error who "not a shared object" obj))
|
||||
(or (shared-object-proc obj)
|
||||
(let ([p (make-proc who obj return-type args)])
|
||||
(shared-object-proc-set! obj p)
|
||||
p)))
|
||||
|
||||
|
||||
(define-record-type cstring (fields pointer))
|
||||
|
||||
|
||||
(define (string->cstring str)
|
||||
(let ([bv (string->utf8 str)])
|
||||
(let ([n (bytevector-length bv)])
|
||||
(let ([p (malloc (+ n 1))])
|
||||
(let f ([i 0])
|
||||
(unless (= i n)
|
||||
(pointer-set-char p i (bytevector-u8-ref bv i))
|
||||
(f (+ i 1))))
|
||||
(pointer-set-char p n 0)
|
||||
(make-cstring p)))))
|
||||
|
||||
|
||||
(define (bytevector->blob bv)
|
||||
(let ([n (bytevector-length bv)])
|
||||
(let ([p (malloc n)])
|
||||
(let f ([i 0])
|
||||
(unless (= i n)
|
||||
(pointer-set-char p i (bytevector-u8-ref bv i))
|
||||
(f (+ i 1))))
|
||||
p)))
|
||||
|
||||
|
||||
|
||||
(define (object->long x)
|
||||
(cond
|
||||
[(integer? x) x]
|
||||
[(cstring? x) (pointer->integer (cstring-pointer x))]
|
||||
[else (error 'object->pointer "cannot handle" x)]))
|
||||
|
||||
(define (vector->blob v)
|
||||
(let ([n (vector-length v)])
|
||||
(let ([p (malloc (* n 4))])
|
||||
(let f ([i 0] [j (- n 1)])
|
||||
(unless (= i n)
|
||||
(pointer-set-long p (* i 4)
|
||||
(object->long (vector-ref v j)))
|
||||
(f (+ i 1) (- j 1))))
|
||||
p)))
|
||||
|
||||
(define-record-type cfloat (fields value))
|
||||
|
||||
(define (flonum->float x)
|
||||
(cond
|
||||
[(flonum? x) (make-cfloat x)]
|
||||
[else (error 'flonum->float "invalid arg" x)]))
|
||||
|
||||
|
||||
(define (stdcall-shared-object->void proc . args)
|
||||
(apply (get-proc 'stdcall-shared-object->void proc 'void args) args))
|
||||
|
||||
|
||||
(define (stdcall-shared-object->int proc . args)
|
||||
(apply (get-proc 'stdcall-shared-object->int proc 'sint32 args) args))
|
||||
|
||||
(define (stdcall-shared-object->intptr proc . args)
|
||||
(apply (get-proc 'stdcall-shared-object->intptr proc 'pointer args) args))
|
||||
|
||||
(define (make-callback conv argcount proc)
|
||||
(import (ikarus system $foreign))
|
||||
(define who 'make-callback)
|
||||
(unless (procedure? proc) (error who "not a procedure" proc))
|
||||
(unless (eqv? 0 conv) (error who "invalid calling convention" conv))
|
||||
((make-callback 'sint32 (make-list argcount 'sint32)) proc))
|
||||
|
||||
|
||||
(define (stdcall-shared-object->double . args) (error '#f "invalid args" args))
|
||||
(define (usleep . args) (error '#f "invalid args" args))
|
||||
|
||||
(define (microsecond)
|
||||
(let ([t (current-time)])
|
||||
(+ (* (time-second t) 1000000)
|
||||
(div (time-nanosecond t) 1000))))
|
||||
|
||||
;(define-record-type carray (fields pointer))
|
||||
|
||||
;(define make-binary-array-of-int
|
||||
; (lambda argv
|
||||
; (let ((step (architecture-feature 'alignof:int))
|
||||
; (proc (case (architecture-feature 'sizeof:int)
|
||||
; ((4) pointer-set-int)
|
||||
; ((8) pointer-set-long)
|
||||
; (else
|
||||
; (syntax-violation 'make-binary-array-of-int "byte size of int not defined")))))
|
||||
; (let ((p (malloc (* step (length argv)))))
|
||||
; (let loop ((offset 0) (arg argv))
|
||||
; (cond ((null? arg) (make-carray p))
|
||||
; (else
|
||||
; (let ((value (car arg)))
|
||||
; (proc p offset value)
|
||||
; (loop (+ offset step) (cdr arg))))))))))
|
||||
;
|
||||
|
||||
;(define make-binary-array-of-char*
|
||||
; (lambda (ref . argv)
|
||||
; (assert (= ref 0))
|
||||
; (let ((step (architecture-feature 'alignof:int))
|
||||
; (proc (case (architecture-feature 'sizeof:int)
|
||||
; ((4) pointer-set-int)
|
||||
; ((8) pointer-set-long)
|
||||
; (else
|
||||
; (syntax-violation 'make-binary-array-of-char* "byte size of int not defined")))))
|
||||
; (let ((p (malloc (* step (length argv)))))
|
||||
; (let loop ((offset 0) (arg argv))
|
||||
; (cond ((null? arg) (make-carray p))
|
||||
; (else
|
||||
; (let ((value (car arg)))
|
||||
; (proc p offset
|
||||
; (pointer->integer
|
||||
; (cstring-pointer (string->cstring value))))
|
||||
; (loop (+ offset step) (cdr arg))))))))))
|
||||
|
||||
)
|
||||
|
||||
|
|
@ -1,196 +0,0 @@
|
|||
;;; Ypsilon Scheme System
|
||||
;;; Copyright (c) 2004-2008 Y.FUJITA, LittleWing Company Limited.
|
||||
;;; See license.txt for terms and conditions of use.
|
||||
|
||||
(library (ffi)
|
||||
|
||||
(export c-function c-argument
|
||||
on-windows on-darwin on-linux on-freebsd on-posix)
|
||||
|
||||
(import (rnrs) (core))
|
||||
|
||||
(define on-windows (and (string-contains (architecture-feature 'operating-system) "windows") #t))
|
||||
(define on-darwin (and (string-contains (architecture-feature 'operating-system) "darwin") #t))
|
||||
(define on-linux (and (string-contains (architecture-feature 'operating-system) "linux") #t))
|
||||
(define on-freebsd (and (string-contains (architecture-feature 'operating-system) "freebsd") #t))
|
||||
(define on-posix (not on-windows))
|
||||
|
||||
(define assert-bool
|
||||
(lambda (name n i)
|
||||
(cond ((boolean? i) (if i 1 0))
|
||||
(else
|
||||
(assertion-violation name (format "expected #t or #f, but got ~r, as argument ~s" i n))))))
|
||||
|
||||
(define assert-int
|
||||
(lambda (name n i)
|
||||
(cond ((and (integer? i) (exact? i)) i)
|
||||
(else
|
||||
(assertion-violation name (format "expected exact integer, but got ~r, as argument ~s" i n))))))
|
||||
|
||||
(define assert-float
|
||||
(lambda (name n f)
|
||||
(cond ((flonum? f) (flonum->float f))
|
||||
(else
|
||||
(assertion-violation name (format "expected flonum, but got ~r, as argument ~s" f n))))))
|
||||
|
||||
(define assert-double
|
||||
(lambda (name n f)
|
||||
(cond ((flonum? f) f)
|
||||
(else
|
||||
(assertion-violation name (format "expected flonum, but got ~r, as argument ~s" f n))))))
|
||||
|
||||
(define assert-string
|
||||
(lambda (name n s)
|
||||
(cond ((string? s) s)
|
||||
(else
|
||||
(assertion-violation name (format "expected string, but got ~r, as argument ~s" s n))))))
|
||||
|
||||
(define assert-bytevector
|
||||
(lambda (name n b)
|
||||
(cond ((bytevector? b) b)
|
||||
(else
|
||||
(assertion-violation name (format "expected bytevector, but got ~r, as argument ~s" b n))))))
|
||||
|
||||
(define assert-closure
|
||||
(lambda (name n p)
|
||||
(cond ((procedure? p) p)
|
||||
(else
|
||||
(assertion-violation name (format "expected procedure, but got ~r, as argument ~s" p n))))))
|
||||
|
||||
(define assert-int-vector
|
||||
(lambda (name n vect)
|
||||
(or (vector? vect)
|
||||
(assertion-violation name (format "expected vector, but got ~r, as argument ~s" vect n)))
|
||||
(let ((lst (vector->list vect)))
|
||||
(for-each (lambda (i)
|
||||
(or (and (integer? i) (exact? i))
|
||||
(assertion-violation name (format "expected list of exact integer, but got ~r, as argument ~s" vect n))))
|
||||
lst)
|
||||
lst)))
|
||||
|
||||
(define assert-string-vector
|
||||
(lambda (name n vect)
|
||||
(or (vector? vect)
|
||||
(assertion-violation name (format "expected vector, but got ~r, as argument ~s" vect n)))
|
||||
(let ((lst (vector->list vect)))
|
||||
(for-each (lambda (s)
|
||||
(or (string? s)
|
||||
(assertion-violation name (format "expected vector of string, but got ~r, as argument ~s" vect n))))
|
||||
lst)
|
||||
lst)))
|
||||
|
||||
(define int->bool
|
||||
(lambda (val)
|
||||
(not (= val 0))))
|
||||
|
||||
(define char*->string
|
||||
(lambda (val)
|
||||
(and val (bytevector->string val (make-transcoder (utf-8-codec))))))
|
||||
|
||||
(define make-binary-array-of-int
|
||||
(lambda argv
|
||||
(let ((step (architecture-feature 'alignof:int))
|
||||
(proc (case (architecture-feature 'sizeof:int)
|
||||
((4) bytevector-s32-native-set!)
|
||||
((8) bytevector-s64-native-set!)
|
||||
(else
|
||||
(syntax-violation 'make-binary-array-of-int "byte size of int not defined")))))
|
||||
(let ((bv (make-bytevector (* step (length argv)))))
|
||||
(let loop ((offset 0) (arg argv))
|
||||
(cond ((null? arg) bv)
|
||||
(else
|
||||
(let ((value (car arg)))
|
||||
(proc bv offset value)
|
||||
(loop (+ offset step) (cdr arg))))))))))
|
||||
|
||||
(define make-binary-array-of-char*
|
||||
(lambda (ref . argv)
|
||||
(apply vector
|
||||
ref
|
||||
(map (lambda (value) (string->cstring value)) argv))))
|
||||
|
||||
(define-syntax c-callback-arguments
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ args ...)
|
||||
(let ((lst (syntax->datum (syntax (args ...)))))
|
||||
(if (for-all (lambda (arg) (memq arg '(int void*))) lst)
|
||||
(datum->syntax #'k (length lst))
|
||||
(syntax-violation 'c-callback "expected list of int or void* for argument" x)))))))
|
||||
|
||||
(define-syntax c-argument
|
||||
(syntax-rules (int bool void* char* byte* double float c-callback __stdcall)
|
||||
((_ name n int var)
|
||||
(assert-int 'name n var))
|
||||
((_ name n bool var)
|
||||
(assert-bool 'name n var))
|
||||
((_ name n void* var)
|
||||
(assert-int 'name n var))
|
||||
((_ name n float var)
|
||||
(assert-float 'name n var))
|
||||
((_ name n double var)
|
||||
(assert-double 'name n var))
|
||||
((_ name n byte* var)
|
||||
(assert-bytevector 'name n var))
|
||||
((_ name n char* var)
|
||||
(string->cstring (assert-string 'name n var)))
|
||||
((_ name n [int] var)
|
||||
(apply make-binary-array-of-int (assert-int-vector 'name n var)))
|
||||
((_ name n [char*] var)
|
||||
(apply make-binary-array-of-char* 0 (assert-string-vector 'name n var)))
|
||||
((_ name n (*[char*]) var)
|
||||
(apply make-binary-array-of-char* 1 (assert-string-vector 'name n var)))
|
||||
((_ name n [c-callback void (args ...)] var)
|
||||
(make-callback 0 (c-callback-arguments args ...) (assert-closure 'name n var)))
|
||||
((_ name n [c-callback int (args ...)] var)
|
||||
(make-callback 0 (c-callback-arguments args ...) (assert-closure 'name n var)))
|
||||
((_ name n [c-callback void __stdcall (args ...)] var)
|
||||
(make-callback 1 (c-callback-arguments args ...) (assert-closure 'name n var)))
|
||||
((_ name n [c-callback int __stdcall (args ...)] var)
|
||||
(make-callback 1 (c-callback-arguments args ...) (assert-closure 'name n var)))))
|
||||
|
||||
(define-syntax c-function-stub
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ lib-handle lib-name (cast stub) func-name types ...)
|
||||
(with-syntax (((args ...) (generate-temporaries (syntax (types ...))))
|
||||
((n ...) (map (lambda (e) (datum->syntax #'k e)) (iota (length (syntax (types ...))) 1))))
|
||||
(syntax (let ((loc (lookup-shared-object lib-handle 'func-name)))
|
||||
(if loc
|
||||
(let () (define func-name
|
||||
(lambda (args ...)
|
||||
(cast (stub loc (c-argument func-name n types args) ...)))) func-name)
|
||||
(let () (define func-name
|
||||
(lambda x
|
||||
(error 'func-name (format "function not available in ~a" lib-name)))) func-name))))))
|
||||
((_ lib-handle lib-name stub func-name types ...)
|
||||
(syntax (c-function-stub lib-handle lib-name ((lambda (x) x) stub) func-name types ...))))))
|
||||
|
||||
(define-syntax c-function
|
||||
(syntax-rules (__stdcall void int double void* bool char*)
|
||||
((_ lib-handle lib-name void __stdcall func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name stdcall-shared-object->void func-name types ...))
|
||||
((_ lib-handle lib-name int __stdcall func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name stdcall-shared-object->int func-name types ...))
|
||||
((_ lib-handle lib-name double __stdcall func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name stdcall-shared-object->double func-name types ...))
|
||||
((_ lib-handle lib-name void* __stdcall func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name stdcall-shared-object->intptr func-name types ...))
|
||||
((_ lib-handle lib-name bool __stdcall func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name (int->bool stdcall-shared-object->int) func-name types ...))
|
||||
((_ lib-handle lib-name char* __stdcall func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name (char*->string stdcall-shared-object->char*) func-name types ...))
|
||||
((_ lib-handle lib-name void func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name call-shared-object->void func-name types ...))
|
||||
((_ lib-handle lib-name int func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name call-shared-object->int func-name types ...))
|
||||
((_ lib-handle lib-name double func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name call-shared-object->double func-name types ...))
|
||||
((_ lib-handle lib-name void* func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name call-shared-object->intptr func-name types ...))
|
||||
((_ lib-handle lib-name bool func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name (int->bool call-shared-object->int) func-name types ...))
|
||||
((_ lib-handle lib-name char* func-name (types ...))
|
||||
(c-function-stub lib-handle lib-name (char*->string call-shared-object->char*) func-name types ...))))
|
||||
|
||||
) ;[end]
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
#!/usr/bin/env ypsilon
|
||||
#!/usr/bin/env ikarus --r6rs-script
|
||||
;;
|
||||
;; 3-D gear wheels. This program is in the public domain.
|
||||
;;
|
||||
|
|
@ -10,7 +10,7 @@
|
|||
;; Port to Scheme/Gauche(GLUT) by YOKOTA Hiroshi
|
||||
;; Port to Ypsilon by YOKOTA Hiroshi
|
||||
|
||||
(import (core) (rnrs) (rnrs programs) (gl) (glut))
|
||||
(import (ypsilon-compat) (rnrs) (rnrs programs) (gl) (glut))
|
||||
|
||||
;; These constant values are not defined in Ypsilon yet
|
||||
(define pi 3.14159265358979323846)
|
||||
|
|
|
|||
|
|
@ -1236,7 +1236,7 @@
|
|||
glMultiTexCoord4sARB
|
||||
glMultiTexCoord4svARB)
|
||||
|
||||
(import (rnrs) (core) (ffi))
|
||||
(import (rnrs) (ypsilon-compat))
|
||||
|
||||
(define libGL (cond (on-darwin (load-shared-object "OpenGL.framework/OpenGL"))
|
||||
(on-windows (load-shared-object "opengl32.dll"))
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@
|
|||
;; Linux: libGL.so.1 libglut.so.3
|
||||
|
||||
|
||||
(import (core) (gl) (glut)
|
||||
(import (gl) (glut)
|
||||
(ypsilon-compat)
|
||||
(rename (except (rnrs) angle display)
|
||||
(reverse rnrs:reverse))
|
||||
(rnrs programs))
|
||||
|
|
|
|||
|
|
@ -175,7 +175,7 @@
|
|||
glutLeaveGameMode
|
||||
glutGameModeGet)
|
||||
|
||||
(import (rnrs) (core) (ffi))
|
||||
(import (rnrs) (ypsilon-compat))
|
||||
|
||||
(define libGLUT (cond (on-darwin (load-shared-object "GLUT.framework/GLUT"))
|
||||
(on-windows (load-shared-object "glut32.dll"))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,239 @@
|
|||
|
||||
(library (ypsilon-compat)
|
||||
(export on-windows on-darwin on-linux on-freebsd on-posix
|
||||
load-shared-object c-argument c-function
|
||||
microsecond usleep
|
||||
(rename (ypsilon:format format)))
|
||||
(import
|
||||
(ikarus system $foreign)
|
||||
(except (ikarus) library))
|
||||
|
||||
(define (microsecond)
|
||||
(let ([t (current-time)])
|
||||
(+ (* (time-second t) 1000000)
|
||||
(div (time-nanosecond t) 1000))))
|
||||
|
||||
(define (usleep . args) (error '#f "invalid args" args))
|
||||
|
||||
(define (ypsilon:format what str . args)
|
||||
(cond
|
||||
[(eq? what #f)
|
||||
(apply printf str args)]
|
||||
[else
|
||||
(apply format str args)]))
|
||||
|
||||
|
||||
(define (architecture-feature what)
|
||||
(case what
|
||||
[(operating-system) "darwin"]
|
||||
[(alignof:int) 4]
|
||||
[(sizeof:int) 4]
|
||||
[else (error 'architecture-feature "invalid args" what)]))
|
||||
|
||||
(define (string-contains text s)
|
||||
(define (starts-at? i)
|
||||
(let f ([i i] [j 0])
|
||||
(cond
|
||||
[(= j (string-length s)) #t]
|
||||
[(= i (string-length text)) #f]
|
||||
[else
|
||||
(and (char=? (string-ref text i) (string-ref s j))
|
||||
(f (+ i 1) (+ j 1)))])))
|
||||
(let f ([i 0])
|
||||
(cond
|
||||
[(= i (string-length text)) #f]
|
||||
[(starts-at? i) #t]
|
||||
[else (f (+ i 1))])))
|
||||
|
||||
(define on-windows (and (string-contains (architecture-feature 'operating-system) "windows") #t))
|
||||
(define on-darwin (and (string-contains (architecture-feature 'operating-system) "darwin") #t))
|
||||
(define on-linux (and (string-contains (architecture-feature 'operating-system) "linux") #t))
|
||||
(define on-freebsd (and (string-contains (architecture-feature 'operating-system) "freebsd") #t))
|
||||
(define on-posix (not on-windows))
|
||||
|
||||
|
||||
(define-record-type library (fields name pointer))
|
||||
|
||||
(define (load-shared-object libname)
|
||||
(make-library libname
|
||||
(or (dlopen libname)
|
||||
(error 'load-shared-object (dlerror) libname))))
|
||||
|
||||
(define (int? x) (or (fixnum? x) (bignum? x)))
|
||||
|
||||
(define (check-int who x)
|
||||
(cond
|
||||
[(int? x) x]
|
||||
[else (die who "not an int" x)]))
|
||||
|
||||
(define (vector-andmap f v)
|
||||
(andmap f (vector->list v)))
|
||||
|
||||
(define (check-int* who x)
|
||||
(cond
|
||||
[(and (vector? x) (vector-andmap int? x))
|
||||
(let ([n (vector-length x)])
|
||||
(let ([p (malloc (* n 4))])
|
||||
(let f ([i 0])
|
||||
(cond
|
||||
[(= i n) p]
|
||||
[else
|
||||
(pointer-set-int p (* i 4) (vector-ref x i))
|
||||
(f (+ i 1))]))))]
|
||||
[else (die who "not an int*" x)]))
|
||||
|
||||
(define (check-char* who x)
|
||||
(cond
|
||||
[(string? x)
|
||||
(check-byte* who (string->utf8 x))]
|
||||
[else (die who "not a char*" x)]))
|
||||
|
||||
|
||||
(define (check-char** who x)
|
||||
(cond
|
||||
[(and (vector? x) (vector-andmap string? x))
|
||||
(let ([n (vector-length x)])
|
||||
(let ([p (malloc (* n 4))])
|
||||
(let f ([i 0])
|
||||
(cond
|
||||
[(= i n) p]
|
||||
[else
|
||||
(pointer-set-int p (* i 4)
|
||||
(pointer->integer (check-char* who (vector-ref x i))))
|
||||
(f (+ i 1))]))))]
|
||||
[else (die who "not a char**" x)]))
|
||||
|
||||
(define (check-byte* who x)
|
||||
(cond
|
||||
[(bytevector? x)
|
||||
(let ([n (bytevector-length x)])
|
||||
(let ([p (malloc (+ n 1))])
|
||||
(pointer-set-char p n 0)
|
||||
(let f ([i 0])
|
||||
(cond
|
||||
[(= i n) p]
|
||||
[else
|
||||
(pointer-set-char p i (bytevector-u8-ref x i))
|
||||
(f (+ i 1))]))))]
|
||||
[else (die who "not a byte*" x)]))
|
||||
|
||||
(define (check-float who x)
|
||||
(cond
|
||||
[(flonum? x) x]
|
||||
[else (die who "not a flonum" x)]))
|
||||
|
||||
(define (check-double who x)
|
||||
(cond
|
||||
[(flonum? x) x]
|
||||
[else (die who "not a double" x)]))
|
||||
|
||||
(define-syntax check-callback
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ foreign-name val return-type (arg-type* ...))
|
||||
#'(let ([t val])
|
||||
(if (procedure? t)
|
||||
((make-callback
|
||||
(convert-type return-type)
|
||||
(list (convert-type arg-type*) ...))
|
||||
t)
|
||||
(error 'foreign-name "not a procedure" t)))])))
|
||||
|
||||
(define-syntax todo
|
||||
(syntax-rules ()
|
||||
[(_ name* ...)
|
||||
(begin
|
||||
(define (name* . args) (error 'name* "not implemented"))
|
||||
...)]))
|
||||
|
||||
(todo check-void* )
|
||||
|
||||
(define-syntax convert-arg
|
||||
(lambda (x)
|
||||
(syntax-case x (int char* byte* c-callback float double void*)
|
||||
[(_ form foreign-name val char*)
|
||||
#'(check-char* 'foreign-name val)]
|
||||
[(_ form foreign-name val byte*)
|
||||
#'(check-byte* 'foreign-name val)]
|
||||
[(_ form foreign-name val void*)
|
||||
#'(check-void* 'foreign-name val)]
|
||||
[(_ form foreign-name val int)
|
||||
#'(check-int 'foreign-name val)]
|
||||
[(_ form foreign-name val float)
|
||||
#'(check-float 'foreign-name val)]
|
||||
[(_ form foreign-name val double)
|
||||
#'(check-double 'foreign-name val)]
|
||||
[(_ form foreign-name val [int])
|
||||
#'(check-int* 'foreign-name val)]
|
||||
[(_ form foreign-name val [char*])
|
||||
#'(check-char** 'foreign-name val)]
|
||||
[(_ form foreign-name val [c-callback return-type (arg-types ...)])
|
||||
#'(check-callback foreign-name val return-type (arg-types ...))]
|
||||
[(_ form foreign-name val arg-type)
|
||||
(syntax-violation 'c-function "invalid argument type"
|
||||
#'form #'arg-type)])))
|
||||
|
||||
(define-syntax convert-type
|
||||
(lambda (x)
|
||||
(define ls
|
||||
'([void void]
|
||||
[char* pointer]
|
||||
[float float]
|
||||
[double double]
|
||||
[void* pointer]
|
||||
[byte* pointer]
|
||||
[int sint32]))
|
||||
(define (valid x)
|
||||
(cond
|
||||
[(and (list? x) (= (length x) 3) (eq? (car x) 'c-callback))
|
||||
(and (valid (cadr x))
|
||||
(andmap valid (caddr x))
|
||||
'pointer)]
|
||||
[(list? x)
|
||||
(and (andmap valid x) 'pointer)]
|
||||
[(assq x ls) => cadr]
|
||||
[else #f]))
|
||||
(syntax-case x (void)
|
||||
[(ctxt t)
|
||||
(cond
|
||||
[(valid (syntax->datum #'t)) =>
|
||||
(lambda (t)
|
||||
(with-syntax ([t (datum->syntax #'ctxt t)])
|
||||
#'(quote t)))]
|
||||
[else (syntax-violation #f "invalid type" #'t)])])))
|
||||
|
||||
(define (lookup-shared-object lib name)
|
||||
(define who 'lookup-shared-object)
|
||||
(unless (symbol? name) (die who "not a symbol" name))
|
||||
(unless (library? lib) (die who "not a library" lib))
|
||||
(or (dlsym (library-pointer lib) (symbol->string name))
|
||||
(error who
|
||||
(format #f "cannot find object ~a in library ~a"
|
||||
name (library-name lib)))))
|
||||
|
||||
|
||||
(define-syntax c-function
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ lib lib-name return-type conv foreign-name (arg-type* ...))
|
||||
(with-syntax ([x x]
|
||||
[(t* ...) (generate-temporaries #'(arg-type* ...))])
|
||||
#'(let ([callout
|
||||
((make-ffi
|
||||
(convert-type return-type)
|
||||
(list (convert-type arg-type*) ...))
|
||||
(lookup-shared-object lib 'foreign-name))])
|
||||
(lambda (t* ...)
|
||||
(let ([t* (convert-arg x foreign-name t* arg-type*)] ...)
|
||||
(let ([v (callout t* ...)])
|
||||
v)))))])))
|
||||
|
||||
(define-syntax c-argument
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ function-name argnum argtype argval)
|
||||
(begin
|
||||
(printf "syntax ~s\n" (syntax->datum x))
|
||||
#'(void))])))
|
||||
|
||||
)
|
||||
Loading…
Reference in New Issue