diff --git a/lab/ypsilon-ffi/core.ikarus.ss b/lab/ypsilon-ffi/core.ikarus.ss
deleted file mode 100644
index 1347324..0000000
--- a/lab/ypsilon-ffi/core.ikarus.ss
+++ /dev/null
@@ -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))))))))))
-
-)
-
diff --git a/lab/ypsilon-ffi/ffi.scm b/lab/ypsilon-ffi/ffi.scm
deleted file mode 100644
index 9f4c6ed..0000000
--- a/lab/ypsilon-ffi/ffi.scm
+++ /dev/null
@@ -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]
diff --git a/lab/ypsilon-ffi/gears.scm b/lab/ypsilon-ffi/gears.scm
index 5be3dbf..5ca4185 100755
--- a/lab/ypsilon-ffi/gears.scm
+++ b/lab/ypsilon-ffi/gears.scm
@@ -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)
diff --git a/lab/ypsilon-ffi/gl.scm b/lab/ypsilon-ffi/gl.scm
index 45872b9..c59da6a 100644
--- a/lab/ypsilon-ffi/gl.scm
+++ b/lab/ypsilon-ffi/gl.scm
@@ -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"))
diff --git a/lab/ypsilon-ffi/glut-demo.scm b/lab/ypsilon-ffi/glut-demo.scm
index 89c079a..3770b1c 100644
--- a/lab/ypsilon-ffi/glut-demo.scm
+++ b/lab/ypsilon-ffi/glut-demo.scm
@@ -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))
diff --git a/lab/ypsilon-ffi/glut.scm b/lab/ypsilon-ffi/glut.scm
index 21fada9..44ec42a 100644
--- a/lab/ypsilon-ffi/glut.scm
+++ b/lab/ypsilon-ffi/glut.scm
@@ -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"))
diff --git a/lab/ypsilon-ffi/ypsilon-compat.ikarus.ss b/lab/ypsilon-ffi/ypsilon-compat.ikarus.ss
new file mode 100644
index 0000000..3ab205d
--- /dev/null
+++ b/lab/ypsilon-ffi/ypsilon-compat.ikarus.ss
@@ -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))])))
+
+)