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.
|
;; 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 Scheme/Gauche(GLUT) by YOKOTA Hiroshi
|
||||||
;; Port to Ypsilon 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
|
;; These constant values are not defined in Ypsilon yet
|
||||||
(define pi 3.14159265358979323846)
|
(define pi 3.14159265358979323846)
|
||||||
|
|
|
||||||
|
|
@ -1236,7 +1236,7 @@
|
||||||
glMultiTexCoord4sARB
|
glMultiTexCoord4sARB
|
||||||
glMultiTexCoord4svARB)
|
glMultiTexCoord4svARB)
|
||||||
|
|
||||||
(import (rnrs) (core) (ffi))
|
(import (rnrs) (ypsilon-compat))
|
||||||
|
|
||||||
(define libGL (cond (on-darwin (load-shared-object "OpenGL.framework/OpenGL"))
|
(define libGL (cond (on-darwin (load-shared-object "OpenGL.framework/OpenGL"))
|
||||||
(on-windows (load-shared-object "opengl32.dll"))
|
(on-windows (load-shared-object "opengl32.dll"))
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,8 @@
|
||||||
;; Linux: libGL.so.1 libglut.so.3
|
;; Linux: libGL.so.1 libglut.so.3
|
||||||
|
|
||||||
|
|
||||||
(import (core) (gl) (glut)
|
(import (gl) (glut)
|
||||||
|
(ypsilon-compat)
|
||||||
(rename (except (rnrs) angle display)
|
(rename (except (rnrs) angle display)
|
||||||
(reverse rnrs:reverse))
|
(reverse rnrs:reverse))
|
||||||
(rnrs programs))
|
(rnrs programs))
|
||||||
|
|
|
||||||
|
|
@ -175,7 +175,7 @@
|
||||||
glutLeaveGameMode
|
glutLeaveGameMode
|
||||||
glutGameModeGet)
|
glutGameModeGet)
|
||||||
|
|
||||||
(import (rnrs) (core) (ffi))
|
(import (rnrs) (ypsilon-compat))
|
||||||
|
|
||||||
(define libGLUT (cond (on-darwin (load-shared-object "GLUT.framework/GLUT"))
|
(define libGLUT (cond (on-darwin (load-shared-object "GLUT.framework/GLUT"))
|
||||||
(on-windows (load-shared-object "glut32.dll"))
|
(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