Update to use foreign-c

Makefile

@@ -5,8 +5,8 @@ build:
 
 snow:
 	mkdir -p snow
-	cp -r ../r7rs-pffi/retropikzel snow/
-	cp -r ../pffi-srfi-170/srfi snow/
+	cp -r ../foreign-c/foreign snow/
+	cp -r ../foreign-c-srfi-170/srfi snow/
 
 # Does uninstall because without that the changes do not seem to update
 install: uninstall

compile-r7rs.scm

@@ -3,7 +3,7 @@
         (scheme read)
         (scheme write)
         (scheme process-context)
-        (retropikzel pffi)
+        (foreign c)
         (libs util)
         (libs data)
         (libs library-util)
@@ -123,13 +123,13 @@
   (exit 0))
 
 (cond-expand
-  (windows (pffi-define-library c-stdlib '("stdlib.h") "ucrtbase"))
-  (else (pffi-define-library c-stdlib
+  (windows (define-c-library c-stdlib '("stdlib.h") "ucrtbase"))
+  (else (define-c-library c-stdlib
                              '("stdlib.h")
                              "c"
                              '((additional-versions ("6"))))))
 
-(pffi-define c-system c-stdlib 'system 'int '(pointer))
+(define-c-procedure c-system c-stdlib 'system 'int '(pointer))
 
 #;(define search-library-files
   (lambda (directory)
@@ -223,7 +223,7 @@
                (display library-command)
                (newline)
                (display "Exit code         ")
-               (let ((output (c-system (pffi-string->pointer library-command))))
+               (let ((output (c-system (string->c-utf8 library-command))))
                  (when (not (= output 0))
                    (error "Problem compiling libraries, exiting" output))
                  (display output))
@@ -258,7 +258,7 @@
              (display "start")))
       (display scheme-command)))
   (cond ((string=? compilation-target "unix")
-         (c-system (pffi-string->pointer (string-append "chmod +x " output-file))))))
+         (c-system (string->c-utf8 (string-append "chmod +x " output-file))))))
 
 (when (and (equal? scheme-type 'compiler) input-file)
   (when (and output-file (file-exists? output-file))
@@ -270,6 +270,6 @@
   (display scheme-command)
   (newline)
   (display "Exit code         ")
-  (display (c-system (pffi-string->pointer scheme-command)))
+  (display (c-system (string->c-utf8 scheme-command)))
   (newline))
 

snow/foreign/c.sld

@@ -0,0 +1,330 @@
+(define-library
+  (foreign c)
+  (cond-expand
+    (chibi
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme process-context)
+              (chibi ast)
+              (scheme inexact)
+              (chibi))
+      (include-shared "c/lib/chibi"))
+    (chicken
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)
+              (chicken base)
+              (chicken foreign)
+              (chicken locative)
+              (chicken syntax)
+              (chicken memory)
+              (chicken random)))
+    #;(cyclone
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)
+              (cyclone foreign)
+              (scheme cyclone primitives)))
+    #;(gambit
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)
+              (only (gambit) c-declare c-lambda c-define define-macro)))
+    (gauche
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)
+              (gauche base)
+              (foreign c primitives gauche)))
+    #;(gerbil
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)))
+    (guile
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)
+              (system foreign)
+              (system foreign-library)
+              (only (guile) include-from-path)
+              (only (rnrs bytevectors)
+                    bytevector-uint-set!
+                    bytevector-uint-ref)))
+    (kawa
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)))
+    #;(larceny
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)
+              (rename (primitives r5rs:require) (r5rs:require require))
+              (primitives std-ffi)
+              (primitives foreign-procedure)
+              (primitives foreign-file)
+              (primitives foreign-stdlib)
+              (primitives system-interface)))
+    (mosh
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme inexact)
+              (scheme process-context)
+              (mosh ffi)))
+    (racket
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)
+              (only (racket base) system-type)
+              (ffi winapi)
+              (compatibility mlist)
+              (ffi unsafe)
+              (ffi vector)))
+    (sagittarius
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)
+              (except (sagittarius ffi) c-free c-malloc)
+              (sagittarius)))
+    #;(skint
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)))
+    (stklos
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)
+              (only (stklos)
+                    %make-callback
+                    make-external-function
+                    allocate-bytes
+                    free-bytes
+                    cpointer?
+                    cpointer-null?
+                    cpointer-data
+                    cpointer-data-set!
+                    cpointer-set!
+                    cpointer-ref
+                    void?))
+      (export ; calculate-struct-size-and-offsets
+              ;struct-make
+              get-environment-variable
+              file-exists?
+              make-external-function
+              foreign-c:string-split
+              c-bytevector-pointer-set!
+              c-bytevector-pointer-ref))
+    #;(tr7
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              ;(scheme inexact)
+              (scheme process-context)))
+    (ypsilon
+      (import (scheme base)
+              (scheme write)
+              (scheme char)
+              (scheme file)
+              (scheme inexact)
+              (scheme process-context)
+              (ypsilon c-ffi)
+              (ypsilon c-types)
+              (only (core) define-macro syntax-case))))
+  (export ;;;; Primitives 1
+          c-type-size
+          define-c-library
+          define-c-procedure
+          c-bytevector?
+          c-bytevector-u8-set!
+          c-bytevector-u8-ref
+          c-bytevector-pointer-set!
+          c-bytevector-pointer-ref
+
+          ;;;; Primitives 2
+          define-c-callback
+
+          ;;;; c-bytevector
+          make-c-null
+          c-null?
+          c-free
+          call-with-address-of
+
+          bytevector->c-bytevector
+          c-bytevector->bytevector
+
+          ;; TODO endianness
+          native-endianness
+          make-c-bytevector
+          ;; TODO c-bytevector=?
+          ;; TODO c-bytevector-fill!
+          ;; TODO c-bytevector-copy!
+          ;; TODO c-bytevector-copy
+          c-bytevector-s8-set!
+          c-bytevector-s8-ref
+          ;; TODO c-bytevector->u8-list
+          ;; TODO u8-list->c-bytevector
+
+          c-bytevector-uchar-ref
+          c-bytevector-char-ref
+          c-bytevector-char-set!
+          c-bytevector-uchar-set!
+
+          c-bytevector-uint-ref
+          c-bytevector-sint-ref
+          c-bytevector-sint-set!
+          c-bytevector-uint-set!
+          ;; TODO bytevector->uint-list
+          ;; TODO bytevector->sint-list
+          ;; TODO uint-list->bytevector
+          ;; TODO sint-list->bytevector
+
+          c-bytevector-u16-ref
+          c-bytevector-s16-ref
+          c-bytevector-u16-native-ref
+          c-bytevector-s16-native-ref
+          c-bytevector-u16-set!
+          c-bytevector-s16-set!
+          c-bytevector-u16-native-set!
+          c-bytevector-s16-native-set!
+
+          c-bytevector-u32-ref
+          c-bytevector-s32-ref
+          c-bytevector-u32-native-ref
+          c-bytevector-s32-native-ref
+          c-bytevector-u32-set!
+          c-bytevector-s32-set!
+          c-bytevector-u32-native-set!
+          c-bytevector-s32-native-set!
+
+          c-bytevector-u64-ref
+          c-bytevector-s64-ref
+          c-bytevector-s64-native-ref
+          c-bytevector-u64-native-ref
+          c-bytevector-u64-set!
+          c-bytevector-s64-set!
+          c-bytevector-u64-native-set!
+          c-bytevector-s64-native-set!
+
+          c-bytevector-ieee-single-native-ref
+          c-bytevector-ieee-single-ref
+
+          c-bytevector-ieee-double-native-ref
+          c-bytevector-ieee-double-ref
+
+          c-bytevector-ieee-single-native-set!
+          c-bytevector-ieee-single-set!
+
+          c-bytevector-ieee-double-native-set!
+          c-bytevector-ieee-double-set!
+
+          string->c-utf8
+          ;; TODO string->c-utf16
+          ;; TODO string->c-utf32
+
+          c-utf8->string
+          ;; TODO c-utf16->string
+          ;; TODO c-utf32->string
+
+
+          ;c-string-length ;; TODO Documentation, Testing
+
+          ;; c-struct
+          ;pffi-define-struct;define-c-struct
+          ;pffi-struct-pointer;c-struct-bytevector
+          ;pffi-struct-offset-get;c-struct-offset
+          ;pffi-struct-set!;c-struct-set!
+          ;pffi-struct-get;c-struct-get
+
+          ;; c-array
+          ;define-c-array (?)
+          ;pffi-array-allocate;make-c-array
+          ;pffi-array-pointer;c-array-pointer
+          ;pffi-array?;c-array?
+          ;pffi-pointer->array;c-bytevector->array
+          ;pffi-array-get;c-array-get
+          ;pffi-array-set!;c-array-set!
+          ;pffi-list->array;list->c-array
+          ;pffi-array->list;c-array->list
+
+          ;; c-variable
+          ;define-c-variable (?)
+          )
+  (cond-expand
+    (chicken-6 (include-relative "c/internal.scm"))
+    (else (include "c/internal.scm")))
+  (cond-expand
+    (chibi (include "c/primitives/chibi.scm"))
+    (chicken-5 (export foreign-declare
+                       foreign-safe-lambda
+                       void)
+               (include "c/primitives/chicken.scm"))
+    (chicken-6 (include-relative "c/primitives/chicken.scm"))
+    ;(cyclone (include "c/primitives/cyclone.scm"))
+    ;(gambit (include "c/primitives/gambit.scm"))
+    (gauche (include "c/primitives/gauche/define-c-procedure.scm"))
+    ;(gerbil (include "c/primitives/gerbil.scm"))
+    (guile (include "./c/primitives/guile.scm"))
+    (kawa (include "c/primitives/kawa.scm"))
+    ;(larceny (include "c/primitives/larceny.scm"))
+    (mosh (include "c/primitives/mosh.scm"))
+    (racket (include "c/primitives/racket.scm"))
+    (sagittarius (include "c/primitives/sagittarius.scm"))
+    ;(skint (include "c/primitives/skint.scm"))
+    (stklos (include "c/primitives/stklos.scm"))
+    ;(tr7 (include "c/primitives/tr7.scm"))
+    (ypsilon (export c-function c-callback)
+             (include "c/primitives/ypsilon.scm")))
+  (cond-expand
+    (chicken-6 (include-relative "c/main.scm")
+               (include-relative "c/c-bytevectors.scm")
+               (include-relative "c/pointer.scm")
+               ;(include-relative "c/array.scm")
+               ;(include-relative "c/struct.scm")
+               )
+    (else (include "c/main.scm")
+          ;(include "c/struct.scm")
+          (include "c/c-bytevectors.scm")
+          (include "c/pointer.scm")
+          ;(include "c/array.scm")
+          )))

snow/foreign/c/Makefile

@@ -1,8 +1,9 @@
 CC=gcc
 
-chibi: chibi-src/pffi.stub
-	chibi-ffi chibi-src/pffi.stub
-	${CC} -g3 -o chibi-pffi.so chibi-src/pffi.c -fPIC -lffi -shared
+chibi: primitives/chibi/foreign-c.stub
+	chibi-ffi primitives/chibi/foreign-c.stub
+	mkdir -p lib
+	${CC} -g3 -o lib/chibi.so primitives/chibi/foreign-c.c -fPIC -lffi -shared
 
 chicken:
 	@echo "Nothing to build for Chicken"
@@ -13,13 +14,17 @@ cyclone:
 gambit:
 	@echo "Nothing to build for Gambit"
 
-gauche: gauche-src/gauche-pffi.c gauche-src/gauchelib.scm
+gauche: primitives/gauche/foreign-c-primitives-gauche.c primitives/gauche/gauchelib.scm
 	gauche-package compile \
-		--srcdir=gauche-src \
+		--srcdir=primitives/gauche \
 		--cc=${CC} \
-		--cflags="-I./include" \
+		--cflags="-I./primitives/include" \
 		--libs=-lffi \
-		gauche-pffi gauche-pffi.c gauchelib.scm
+		foreign-c-primitives-gauche foreign-c-primitives-gauche.c gauchelib.scm
+	mkdir -p lib
+	mv foreign-c-primitives-gauche.so lib/gauche.so
+	mv foreign-c-primitives-gauche.o lib/gauche.o
+
 
 gerbil:
 	@echo "Nothing to build for Gerbil"
@@ -53,3 +58,7 @@ tr7:
 
 ypsilon:
 	@echo "Nothing to build for Ypsilon"
+
+clean:
+	@rm -rf primitives/chibi/foreign-c.c
+	@rm -rf lib

snow/foreign/c/array.scm

@@ -8,8 +8,8 @@
 (define pffi-list->array
   (lambda (type list-arg)
     (let* ((array-size (length list-arg))
-           (type-size (pffi-size-of type))
-           (array (pffi-pointer-allocate (* type-size array-size)))
+           (type-size (c-size-of type))
+           (array (make-c-bytevector (* type-size array-size)))
            (offset 0))
       (for-each
         (lambda (item)
@@ -25,7 +25,7 @@
 (define pffi-array->list
   (lambda (array)
     (letrec* ((type (pffi-array-type array))
-              (type-size (pffi-size-of type))
+              (type-size (c-size-of type))
               (max-offset (* type-size (pffi-array-size array)))
               (array-pointer (pffi-array-pointer array))
               (looper (lambda (offset result)
@@ -40,19 +40,19 @@
 
 (define pffi-array-allocate
   (lambda (type size)
-    (array-make type size (pffi-pointer-allocate-calloc size (pffi-size-of type)))))
+    (array-make type size (pffi-pointer-allocate-calloc size (c-size-of type)))))
 
 (define pffi-array-get
   (lambda (array index)
     (let ((type (pffi-array-type array)))
       (pffi-pointer-get (pffi-array-pointer array)
                         type
-                        (* (pffi-size-of type) index)))))
+                        (* (c-size-of type) index)))))
 
 (define pffi-array-set!
   (lambda (array index value)
     (let ((type (pffi-array-type array)))
       (pffi-pointer-set! (pffi-array-pointer array)
                         type
-                        (* (pffi-size-of type) index)
+                        (* (c-size-of type) index)
                         value))))

snow/foreign/c/internal.scm

@@ -0,0 +1,50 @@
+(define type->libffi-type-number
+  (lambda (type)
+    (cond ((equal? type 'int8) 1)
+          ((equal? type 'uint8) 2)
+          ((equal? type 'int16) 3)
+          ((equal? type 'uint16) 4)
+          ((equal? type 'int32) 5)
+          ((equal? type 'uint32) 6)
+          ((equal? type 'int64) 7)
+          ((equal? type 'uint64) 8)
+          ((equal? type 'char) 9)
+          ((equal? type 'unsigned-char) 10)
+          ((equal? type 'short) 11)
+          ((equal? type 'unsigned-short) 12)
+          ((equal? type 'int) 13)
+          ((equal? type 'unsigned-int) 14)
+          ((equal? type 'long) 15)
+          ((equal? type 'unsigned-long) 16)
+          ((equal? type 'float) 17)
+          ((equal? type 'double) 18)
+          ((equal? type 'void) 19)
+          ((equal? type 'pointer) 20)
+          ((equal? type 'pointer-address) 21)
+          ((equal? type 'callback) 22)
+          (else (error "Undefined type" type)))))
+
+(define c-bytevector-get
+  (lambda (pointer type offset)
+    (cond ((equal? type 'int8) (c-bytevector-s8-ref pointer offset))
+          ((equal? type 'uint8) (c-bytevector-u8-ref pointer offset))
+          ((equal? type 'int16) (c-bytevector-s16-ref pointer offset))
+          ((equal? type 'uint16) (c-bytevector-u16-ref pointer offset))
+          ((equal? type 'int32) (c-bytevector-s32-ref pointer offset))
+          ((equal? type 'uint32) (c-bytevector-u32-ref pointer offset))
+          ((equal? type 'int64) (c-bytevector-s64-ref pointer offset))
+          ((equal? type 'uint64) (c-bytevector-u64-ref pointer offset))
+          ((equal? type 'char) (integer->char (c-bytevector-s8-ref pointer offset)))
+          ((equal? type 'unsigned-char) (integer->char (c-bytevector-u8-ref pointer offset)))
+          ((equal? type 'short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'short)))
+          ((equal? type 'unsigned-short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-short)))
+          ((equal? type 'int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'int)))
+          ((equal? type 'unsigned-int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-int)))
+          ((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'long)))
+          ((equal? type 'unsigned-long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-long)))
+          ((equal? type 'float) (c-bytevector-ieee-single-native-ref pointer offset))
+          ((equal? type 'double) (c-bytevector-ieee-double-native-ref pointer offset))
+          ((equal? type 'pointer) (c-bytevector-pointer-ref pointer offset))
+          ((not (equal? type 'void)) (error "No such foreign type" type))
+          ;; Return unspecified on purpose if type is void
+          )))

snow/foreign/c/main.scm

@@ -1,81 +1,8 @@
-(cond-expand
-  (mosh (define pffi-init (lambda () #t)))
-  (chicken
-   (define-syntax pffi-init
-     (er-macro-transformer
-       (lambda (expr rename compare)
-         '(import (chicken foreign)
-                  (chicken memory))
-         #t))))
-  (gambit #t)
-  (ypsilon
-    (define-syntax pffi-init
-      (syntax-rules ()
-        ((_)
-         (import (ypsilon ffi)
-                 (ypsilon c-types))))))
-  (else (define pffi-init (lambda () #t))))
+(define c-type-size
+  (lambda (type)
+    (size-of-type type)))
 
-(define pffi-type?
-  (lambda (object)
-    (if (equal? (size-of-type object) #f)
-      #f
-      #t)))
-
-(define pffi-size-of
-  (lambda (object)
-    (cond ((pffi-struct? object) (pffi-struct-size object))
-          ((pffi-type? object) (size-of-type object))
-          (else (error "Not pffi-struct, pffi-enum of pffi-type" object)))))
-
-(define pffi-string->pointer
-  (lambda (str)
-    (letrec* ((str-length (string-length str))
-              (pointer (pffi-pointer-allocate (+ str-length 1)))
-              (looper (lambda (index)
-                        (when (< index str-length)
-                          (pffi-pointer-set! pointer
-                                             'char
-                                             index
-                                             (string-ref str index))
-                          (looper (+ index 1))))))
-      (looper 0)
-      (pffi-pointer-set! pointer 'char str-length #\null)
-      pointer)))
-
-(define pffi-pointer->string
-  (lambda (pointer)
-    (letrec* ((looper (lambda (index str)
-                        (let ((c (pffi-pointer-get pointer 'char index)))
-                          (if (char=? c #\null)
-                            str
-                            (looper (+ index 1) (cons c str)))))))
-      (list->string (reverse (looper 0 (list)))))))
-
-
-(define pffi-types
-  '(int8
-     uint8
-     int16
-     uint16
-     int32
-     uint32
-     int64
-     uint64
-     char
-     unsigned-char
-     short
-     unsigned-short
-     int
-     unsigned-int
-     long
-     unsigned-long
-     float
-     double
-     pointer
-     void))
-
-(define string-split
+(define foreign-c:string-split
   (lambda (str mark)
     (let* ((str-l (string->list str))
            (res (list))
@@ -93,16 +20,11 @@
       res)))
 
 (cond-expand
-  (gambit #t)
-  ((or chicken cyclone)
-   (define-syntax pffi-define-library
-     (syntax-rules ()
-       ((_ scheme-name headers object-name options)
-        (begin
-          (define scheme-name #t)
-          (pffi-shared-object-load headers))))))
+  (gambit #t) ; Defined in gambit.scm
+  (chicken #t) ; Defined in chicken.scm
+  (cyclone #t) ; Defined in cyclone.scm
   (else
-    (define-syntax pffi-define-library
+    (define-syntax define-c-library
       (syntax-rules ()
         ((_ scheme-name headers object-name options)
          (define scheme-name
@@ -124,8 +46,8 @@
                       (cond-expand
                         (windows
                           (append
-                            (if (get-environment-variable "PFFI_LOAD_PATH")
-                              (string-split (get-environment-variable "PFFI_LOAD_PATH") #\;)
+                            (if (get-environment-variable "FOREIGN_C_LOAD_PATH")
+                              (foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\;)
                               (list))
                             (if (get-environment-variable "SYSTEM")
                               (list (get-environment-variable "SYSTEM"))
@@ -144,15 +66,15 @@
                               (list))
                             (list ".")
                             (if (get-environment-variable "PATH")
-                              (string-split (get-environment-variable "PATH") #\;)
+                              (foreign-c:string-split (get-environment-variable "PATH") #\;)
                               (list))
                             (if (get-environment-variable "PWD")
                               (list (get-environment-variable "PWD"))
                               (list))))
                         (else
                           (append
-                           (if (get-environment-variable "PFFI_LOAD_PATH")
-                              (string-split (get-environment-variable "PFFI_LOAD_PATH") #\:)
+                           (if (get-environment-variable "FOREIGN_C_LOAD_PATH")
+                              (foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\:)
                               (list))
                             ; Guix
                             (list (if (get-environment-variable "GUIX_ENVIRONMENT")
@@ -161,7 +83,7 @@
                                   "/run/current-system/profile/lib")
                             ; Debian
                             (if (get-environment-variable "LD_LIBRARY_PATH")
-                              (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
+                              (foreign-c:string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
                               (list))
                             (list
                               ;;; x86-64
@@ -236,5 +158,5 @@
                  (exit 1))
                (cond-expand
                  (stklos shared-object)
-                 (else (pffi-shared-object-load shared-object
+                 (else (shared-object-load shared-object
                                         `((additional-versions ,additional-versions)))))))))))))

snow/foreign/c/pointer.scm

@@ -0,0 +1,122 @@
+(cond-expand
+  (windows (define-c-library libc
+                             '("stdlib.h" "string.h")
+                             "ucrtbase"
+                             '((additional-versions ("0" "6")))))
+  (else (define-c-library libc
+                          '("stdlib.h" "string.h")
+                          "c"
+                          '((additional-versions ("0" "6"))))))
+
+(define-c-procedure c-calloc libc 'calloc 'pointer '(int int))
+(define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int))
+(define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int))
+;(define-c-procedure c-memset-address libc 'memset 'pointer '(uint64 uint8 int))
+;(define-c-procedure c-printf libc 'printf 'int '(pointer pointer))
+(define-c-procedure c-malloc libc 'malloc 'pointer '(int))
+(define-c-procedure c-strlen libc 'strlen 'int '(pointer))
+
+(define make-c-bytevector
+  (lambda (k . byte)
+    (if (null? byte)
+      (c-malloc k)
+      (bytevector->c-bytevector (make-bytevector k (car byte))))))
+
+(define c-bytevector
+  (lambda bytes
+    (bytevector->c-bytevector (apply bytevector bytes))))
+
+(cond-expand
+  (else (define-c-procedure c-free libc 'free 'void '(pointer))))
+
+(define bytevector->c-bytevector
+  (lambda (bytes)
+    (letrec* ((bytes-length (bytevector-length bytes))
+              (pointer (make-c-bytevector bytes-length))
+              (looper (lambda (index)
+                        (when (< index bytes-length)
+                          (c-bytevector-u8-set! pointer
+                                                index
+                                                (bytevector-u8-ref bytes index))
+                          (looper (+ index 1))))))
+      (looper 0)
+      pointer)))
+
+(define c-bytevector->bytevector
+  (lambda (pointer size)
+    (letrec* ((bytes (make-bytevector size))
+              (looper (lambda (index)
+                        (let ((byte (c-bytevector-u8-ref pointer index)))
+                          (if (= index size)
+                            bytes
+                            (begin
+                              (bytevector-u8-set! bytes index byte)
+                              (looper (+ index 1))))))))
+      (looper 0))))
+
+(define c-string-length
+  (lambda (bytevector-var)
+    (c-strlen bytevector-var)))
+
+(define c-utf8->string
+  (lambda (c-bytevector)
+    (let ((size (c-strlen c-bytevector)))
+      (utf8->string (c-bytevector->bytevector c-bytevector size)))))
+
+(define string->c-utf8
+  (lambda (string-var)
+    (bytevector->c-bytevector (string->utf8 (string-append string-var (string #\null))))))
+
+(cond-expand
+  (kawa #t) ; FIXME
+  (chicken #t) ; FIXME
+  (else (define make-c-null
+          (lambda ()
+            (cond-expand (stklos (let ((pointer (make-c-bytevector 1)))
+                                   (free-bytes pointer)
+                                   pointer))
+                         (else (c-memset-address->pointer 0 0 0)))))))
+
+(cond-expand
+  (kawa #t) ; FIXME
+  (chicken #t) ; FIXME
+  (else (define c-null?
+          (lambda (pointer)
+            (if (c-bytevector? pointer)
+              (= (c-memset-pointer->address pointer 0 0) 0)
+              #f)))))
+
+#;(define c-bytevector->address
+  (lambda (c-bytevector)
+    (c-memset-pointer->address c-bytevector 0 0)))
+
+#;(define address->c-bytevector
+  (lambda (address)
+    (c-memset-address->pointer address 0 0)))
+
+#;(define c-bytevector-pointer-set!
+  (lambda (c-bytevector k pointer)
+    (c-bytevector-uint-set! c-bytevector
+                            0
+                            (c-bytevector->address pointer)
+                            (native-endianness)
+                            (c-type-size 'pointer))))
+
+#;(define c-bytevector-pointer-ref
+  (lambda (c-bytevector k)
+    (address->c-bytevector (c-bytevector-uint-ref c-bytevector
+                                                  0
+                                                  (native-endianness)
+                                                  (c-type-size 'pointer)))))
+
+(cond-expand
+  ;(kawa #t) ; Defined in kawa.scm
+  (else (define-syntax call-with-address-of
+          (syntax-rules ()
+            ((_ input-pointer thunk)
+             (let ((address-pointer (make-c-bytevector (c-type-size 'pointer))))
+               (c-bytevector-pointer-set! address-pointer 0 input-pointer)
+               (let ((result (apply thunk (list address-pointer))))
+                 (set! input-pointer (c-bytevector-pointer-ref address-pointer 0))
+                 (c-free address-pointer)
+                 result)))))))

snow/foreign/c/primitives/chibi.scm

@@ -19,46 +19,30 @@
           ((eq? type 'float) (size-of-float))
           ((eq? type 'double) (size-of-double))
           ((eq? type 'pointer) (size-of-pointer))
-          ((eq? type 'string) (size-of-pointer))
-          ((eq? type 'struct) (size-of-pointer))
+          ((eq? type 'pointer-address) (size-of-pointer))
           ((eq? type 'callback) (size-of-pointer))
           ((eq? type 'void) 0)
           (else #f))))
 
-(define pffi-shared-object-load
+(define shared-object-load
   (lambda (path options)
     (let ((shared-object (dlopen path RTLD-NOW))
           (maybe-error (dlerror)))
-      (when (not (pffi-pointer-null? maybe-error))
-        (error (pffi-pointer->string maybe-error)))
       shared-object)))
 
-(define pffi-pointer-null
-  (lambda ()
-    (pointer-null)))
-
-(define pffi-pointer-null?
-  (lambda (pointer)
-    (not pointer))) ; #f is null on Chibi
-
-(define pffi-pointer?
+(define c-bytevector?
   (lambda (object)
     (or (equal? object #f) ; False can be null pointer
         (pointer? object))))
 
-(define pffi-pointer-allocate
-  (lambda (size)
-    (pointer-allocate size)))
-
-(define pffi-pointer-address
-  (lambda (pointer)
-    (pointer-address pointer)))
-
-(define pffi-pointer-free
-  (lambda (pointer)
+#;(define c-free
+(lambda (pointer)
   (pointer-free pointer)))
 
-(define pffi-pointer-set!
+;(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
+;(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
+
+#;(define pointer-set!
   (lambda (pointer type offset value)
     (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
           ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
@@ -68,7 +52,7 @@
           ((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
           ((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
           ((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
-          ((equal? type 'char) (pointer-set-c-char! pointer offset value))
+          ((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value)))
           ((equal? type 'short) (pointer-set-c-short! pointer offset value))
           ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
           ((equal? type 'int) (pointer-set-c-int! pointer offset value))
@@ -80,7 +64,7 @@
           ((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
           ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
 
-(define pffi-pointer-get
+#;(define pointer-get
   (lambda (pointer type offset)
     (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
           ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
@@ -90,7 +74,7 @@
           ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
           ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
           ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
-          ((equal? type 'char) (pointer-ref-c-char pointer offset))
+          ((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset)))
           ((equal? type 'short) (pointer-ref-c-short pointer offset))
           ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
           ((equal? type 'int) (pointer-ref-c-int pointer offset))
@@ -102,14 +86,6 @@
           ((equal? type 'void) (pointer-ref-c-pointer pointer offset))
           ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
 
-#;(define pffi-string->pointer
-  (lambda (string-content)
-    (string-to-pointer string-content)))
-
-#;(define pffi-pointer->string
-  (lambda (pointer)
-    (pointer-to-string pointer)))
-
 (define pffi-type->native-type
   (lambda (type)
     (cond ((equal? type 'int8) 'int8_t)
@@ -131,14 +107,14 @@
           ((equal? type 'float) 'float)
           ((equal? type 'double) 'double)
           ((equal? type 'pointer) '(maybe-null void*))
-          ((equal? type 'string) 'string)
+          ((equal? type 'pointer-address) '(maybe-null void*))
           ((equal? type 'void) 'void)
           ((equal? type 'callback) '(maybe-null void*))
           (else (error "pffi-type->native-type -- No such pffi type" type)))))
 
-;; pffi-define
+;; define-c-procedure
 
-(define pffi-type->libffi-type
+#;(define type->libffi-type
   (lambda (type)
     (cond ((equal? type 'int8) (get-ffi-type-int8))
           ((equal? type 'uint8) (get-ffi-type-uint8))
@@ -161,13 +137,40 @@
           ((equal? type 'double) (get-ffi-type-double))
           ((equal? type 'void) (get-ffi-type-void))
           ((equal? type 'pointer) (get-ffi-type-pointer))
+          ((equal? type 'pointer-address) 1)
           ((equal? type 'callback) (get-ffi-type-pointer)))))
 
-(define argument->pointer
+#;(define type->libffi-type
+  (lambda (type)
+    (cond ((equal? type 'int8) 1)
+          ((equal? type 'uint8) 2)
+          ((equal? type 'int16) 3)
+          ((equal? type 'uint16) 4)
+          ((equal? type 'int32) 5)
+          ((equal? type 'uint32) 6)
+          ((equal? type 'int64) 7)
+          ((equal? type 'uint64) 8)
+          ((equal? type 'char) 9)
+          ((equal? type 'unsigned-char) 10)
+          ((equal? type 'short) 11)
+          ((equal? type 'unsigned-short) 12)
+          ((equal? type 'int) 13)
+          ((equal? type 'unsigned-int) 14)
+          ((equal? type 'long) 15)
+          ((equal? type 'unsigned-long) 16)
+          ((equal? type 'float) 17)
+          ((equal? type 'double) 18)
+          ((equal? type 'void) 19)
+          ((equal? type 'pointer) 20)
+          ((equal? type 'pointer-address) 21)
+          ((equal? type 'callback) 22)
+          (else (error "Undefined type" type)))))
+
+#;(define argument->pointer
   (lambda (value type)
     (cond ((procedure? value) (scheme-procedure-to-pointer value))
-          (else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
-                  (pffi-pointer-set! pointer type 0 value)
+          (else (let ((pointer (pointer-allocate (size-of-type type))))
+                  (pointer-set! pointer type 0 value)
                   pointer)))))
 
 (define make-c-function
@@ -175,27 +178,19 @@
     (dlerror) ;; Clean all previous errors
     (let ((c-function (dlsym shared-object c-name))
           (maybe-dlerror (dlerror)))
-      (when (not (pffi-pointer-null? maybe-dlerror))
-        (error (pffi-pointer->string maybe-dlerror)))
       (lambda arguments
-        (let ((return-value (pffi-pointer-allocate
-                              (if (equal? return-type 'void)
-                                0
-                                (size-of-type return-type)))))
+        (let* ((return-pointer
                  (internal-ffi-call (length argument-types)
-                             (pffi-type->libffi-type return-type)
-                             (map pffi-type->libffi-type argument-types)
+                                    (type->libffi-type-number return-type)
+                                    (map type->libffi-type-number argument-types)
                                     c-function
-                             return-value
-                             (map argument->pointer
-                                  arguments
-                                  argument-types))
-          (cond ((not (equal? return-type 'void))
-                 (pffi-pointer-get return-value return-type 0))))))))
+                                    (c-type-size return-type)
+                                    arguments)))
+          (c-bytevector-get return-pointer return-type 0))))))
 
-(define-syntax pffi-define
+(define-syntax define-c-procedure
   (syntax-rules ()
-    ((pffi-define scheme-name shared-object c-name return-type argument-types)
+    ((_ scheme-name shared-object c-name return-type argument-types)
      (define scheme-name
        (make-c-function shared-object
                         (symbol->string c-name)
@@ -206,8 +201,8 @@
   (lambda (return-type argument-types procedure)
     (scheme-procedure-to-pointer procedure)))
 
-(define-syntax pffi-define-callback
+(define-syntax define-c-callback
   (syntax-rules ()
-    ((pffi-define scheme-name return-type argument-types procedure)
+    ((_ scheme-name return-type argument-types procedure)
      (define scheme-name
        (make-c-callback return-type 'argument-types procedure)))))

snow/foreign/c/primitives/chibi/foreign-c.stub

@@ -0,0 +1,441 @@
+; vim: ft=scheme
+
+(c-system-include "stdint.h")
+(c-system-include "dlfcn.h")
+(c-system-include "stdio.h")
+(c-system-include "ffi.h")
+
+;; c-type-size
+(c-declare "
+    int size_of_int8_t() { return sizeof(int8_t); }
+    int size_of_uint8_t() { return sizeof(uint8_t); }
+    int size_of_int16_t() { return sizeof(int16_t); }
+    int size_of_uint16_t() { return sizeof(uint16_t); }
+    int size_of_int32_t() { return sizeof(int32_t); }
+    int size_of_uint32_t() { return sizeof(uint32_t); }
+    int size_of_int64_t() { return sizeof(int64_t); }
+    int size_of_uint64_t() { return sizeof(uint64_t); }
+    int size_of_char() { return sizeof(char); }
+    int size_of_unsigned_char() { return sizeof(unsigned char); }
+    int size_of_short() { return sizeof(short); }
+    int size_of_unsigned_short() { return sizeof(unsigned short); }
+    int size_of_int() { return sizeof(int); }
+    int size_of_unsigned_int() { return sizeof(unsigned int); }
+    int size_of_long() { return sizeof(long); }
+    int size_of_unsigned_long() { return sizeof(unsigned long); }
+    int size_of_float() { return sizeof(float); }
+    int size_of_double() { return sizeof(double); }
+    int size_of_pointer() { return sizeof(void*); }
+")
+
+(define-c int (size-of-int8_t size_of_int8_t) ())
+(define-c int (size-of-uint8_t size_of_uint8_t) ())
+(define-c int (size-of-int16_t size_of_int16_t) ())
+(define-c int (size-of-uint16_t size_of_uint16_t) ())
+(define-c int (size-of-int32_t size_of_int32_t) ())
+(define-c int (size-of-uint32_t size_of_uint32_t) ())
+(define-c int (size-of-int64_t size_of_int64_t) ())
+(define-c int (size-of-uint64_t size_of_uint64_t) ())
+(define-c int (size-of-char size_of_char) ())
+(define-c int (size-of-unsigned-char size_of_unsigned_char) ())
+(define-c int (size-of-short size_of_short) ())
+(define-c int (size-of-unsigned-short size_of_unsigned_short) ())
+(define-c int (size-of-int size_of_int) ())
+(define-c int (size-of-unsigned-int size_of_unsigned_int) ())
+(define-c int (size-of-long size_of_long) ())
+(define-c int (size-of-unsigned-long size_of_unsigned_long) ())
+(define-c int (size-of-float size_of_float) ())
+(define-c int (size-of-double size_of_double) ())
+(define-c int (size-of-pointer size_of_pointer) ())
+
+;; shared-object-load
+(define-c-const int (RTLD-NOW "RTLD_NOW"))
+(define-c (maybe-null pointer void*) dlopen (string int))
+(define-c (maybe-null pointer void*) dlerror ())
+
+;(c-declare "void* pointer_null() { return NULL; }")
+;(define-c (pointer void*) (pointer-null pointer_null) ())
+
+;(c-declare "int is_pointer_null(void* pointer) { if(pointer == NULL) { return 1; } else { return 0; }; }")
+;(define-c bool (is-pointer-null is_pointer_null) ((maybe-null pointer void*)))
+
+;(c-declare "void* pointer_allocate(int size) { return malloc(size); }")
+;(define-c (maybe-null pointer void*) (pointer-allocate pointer_allocate) (int))
+
+(c-declare "sexp is_pointer(struct sexp_struct* object) { if(sexp_cpointerp(object)) { return SEXP_TRUE; } else { return SEXP_FALSE; } }")
+(define-c sexp (pointer? is_pointer) (sexp))
+
+(c-declare "void c_bytevector_u8_set(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }")
+(define-c void (c-bytevector-u8-set! c_bytevector_u8_set) ((pointer void*) int uint8_t))
+
+(c-declare "int8_t c_bytevector_u8_ref (void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }")
+(define-c int8_t (c-bytevector-u8-ref c_bytevector_u8_ref) ((pointer void*) int))
+
+(c-declare "void c_bytevector_pointer_set (void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }")
+(define-c void (c-bytevector-pointer-set! c_bytevector_pointer_set) ((pointer void*) int (maybe-null pointer void*)))
+
+(c-declare "void* c_bytevector_pointer_ref (void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }")
+(define-c (maybe-null pointer void*) (c-bytevector-pointer-ref c_bytevector_pointer_ref) ((pointer void*) int))
+
+#;(c-declare "void* pointer_address(struct sexp_struct* pointer) {
+            return &sexp_cpointer_value(pointer);
+           }")
+;(define-c (maybe-null pointer void*) (pointer-address pointer_address) (sexp))
+
+;(c-declare "void pointer_free(void* pointer) { free(pointer); }")
+;(define-c void (pointer-free pointer_free) ((maybe-null pointer void*)))
+
+;; pointer-set!
+;(c-declare "void pointer_set_c_int8_t(void* pointer, int offset, int8_t value) { *(int8_t*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-int8_t! pointer_set_c_int8_t) ((pointer void*) int int8_t))
+;(c-declare "void pointer_set_c_uint8_t(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-uint8_t! pointer_set_c_uint8_t) ((pointer void*) int uint8_t))
+;
+;(c-declare "void pointer_set_c_int16_t(void* pointer, int offset, int16_t value) { *(int16_t*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-int16_t! pointer_set_c_int16_t) ((pointer void*) int int16_t))
+;(c-declare "void pointer_set_c_uint16_t(void* pointer, int offset, uint16_t value) { *(uint16_t*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-uint16_t! pointer_set_c_uint16_t) ((pointer void*) int uint16_t))
+;
+;(c-declare "void pointer_set_c_int32_t(void* pointer, int offset, int32_t value) { *(int32_t*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-int32_t! pointer_set_c_int32_t) ((pointer void*) int int32_t))
+;(c-declare "void pointer_set_c_uint32_t(void* pointer, int offset, uint32_t value) { *(uint32_t*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-uint32_t! pointer_set_c_uint32_t) ((pointer void*) int uint32_t))
+;
+;(c-declare "void pointer_set_c_int64_t(void* pointer, int offset, int64_t value) { *(int64_t*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-int64_t! pointer_set_c_int64_t) ((pointer void*) int int64_t))
+;(c-declare "void pointer_set_c_uint64_t(void* pointer, int offset, uint64_t value) { *(uint64_t*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-uint64_t! pointer_set_c_uint64_t) ((pointer void*) int uint64_t))
+;
+;(c-declare "void pointer_set_c_char(void* pointer, int offset, int8_t value) { *((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int int8_t))
+;(c-declare "void pointer_set_c_unsigned_char(void* pointer, int offset, unsigned char value) { *(unsigned char*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-unsigned-char! pointer_set_c_unsigned_char) ((pointer void*) int unsigned-char))
+;
+;(c-declare "void pointer_set_c_short(void* pointer, int offset, short value) { *(short*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-short! pointer_set_c_short) ((pointer void*) int short))
+;(c-declare "void pointer_set_c_unsigned_short(void* pointer, int offset, unsigned short value) { *(unsigned short*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-unsigned-short! pointer_set_c_unsigned_short) ((pointer void*) int unsigned-short))
+;
+;(c-declare "void pointer_set_c_int(void* pointer, int offset, int value) { *(int*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-int! pointer_set_c_int) ((pointer void*) int int))
+;(c-declare "void pointer_set_c_unsigned_int(void* pointer, int offset, unsigned int value) { *(unsigned int*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-unsigned-int! pointer_set_c_unsigned_int) ((pointer void*) int unsigned-int))
+;
+;(c-declare "void pointer_set_c_long(void* pointer, int offset, long value) { *(long*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-long! pointer_set_c_long) ((pointer void*) int long))
+;(c-declare "void pointer_set_c_unsigned_long(void* pointer, int offset, unsigned long value) { *(unsigned long*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-unsigned-long! pointer_set_c_unsigned_long) ((pointer void*) int unsigned-long))
+;
+;(c-declare "void pointer_set_c_float(void* pointer, int offset, float value) { *(float*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-float! pointer_set_c_float) ((pointer void*) int float))
+;
+;(c-declare "void pointer_set_c_double(void* pointer, int offset, double value) { *(double*)((char*)pointer + offset) = value; }")
+;(define-c void (pointer-set-c-double! pointer_set_c_double) ((pointer void*) int double))
+;
+;(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }")
+;(define-c void (pointer-set-c-pointer! pointer_set_c_pointer) ((pointer void*) int (maybe-null pointer void*)))
+;
+;;; pointer-get
+;(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }")
+;(define-c int8_t (pointer-ref-c-int8_t pointer_ref_c_int8_t) ((pointer void*) int))
+;(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { return *(uint8_t*)((char*)pointer + offset); }")
+;(define-c uint8_t (pointer-ref-c-uint8_t pointer_ref_c_uint8_t) ((pointer void*) int))
+;
+;(c-declare "int16_t pointer_ref_c_int16_t(void* pointer, int offset) { return *(int16_t*)((char*)pointer + offset); }")
+;(define-c int16_t (pointer-ref-c-int16_t pointer_ref_c_int16_t) ((pointer void*) int))
+;(c-declare "uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { return *(uint16_t*)((char*)pointer + offset); }")
+;(define-c uint16_t (pointer-ref-c-uint16_t pointer_ref_c_uint16_t) ((pointer void*) int))
+;
+;(c-declare "int32_t pointer_ref_c_int32_t(void* pointer, int offset) { return *(int32_t*)((char*)pointer + offset); }")
+;(define-c int32_t (pointer-ref-c-int32_t pointer_ref_c_int32_t) ((pointer void*) int))
+;(c-declare "uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { return *(uint32_t*)((char*)pointer + offset); }")
+;(define-c uint32_t (pointer-ref-c-uint32_t pointer_ref_c_uint32_t) ((pointer void*) int))
+;
+;(c-declare "int64_t pointer_ref_c_int64_t(void* pointer, int offset) { return *(int64_t*)((char*)pointer + offset); }")
+;(define-c int64_t (pointer-ref-c-int64_t pointer_ref_c_int64_t) ((pointer void*) int))
+;(c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { return *(uint64_t*)((char*)pointer + offset); }")
+;(define-c uint64_t (pointer-ref-c-uint64_t pointer_ref_c_uint64_t) ((pointer void*) int))
+;
+;(c-declare "int8_t pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); }")
+;(define-c int8_t (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int))
+;(c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { return *(unsigned char*)((char*)pointer + offset); }")
+;(define-c unsigned-char (pointer-ref-c-unsigned-char pointer_ref_c_unsigned_char) ((pointer void*) int))
+;
+;(c-declare "short pointer_ref_c_short(void* pointer, int offset) { return *(short*)((char*)pointer + offset); }")
+;(define-c short (pointer-ref-c-short pointer_ref_c_short) ((pointer void*) int))
+;(c-declare "unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { return *(unsigned short*)((char*)pointer + offset); }")
+;(define-c unsigned-short (pointer-ref-c-unsigned-short pointer_ref_c_unsigned_short) ((pointer void*) int))
+;
+;(c-declare "int pointer_ref_c_int(void* pointer, int offset) { return *(int*)((char*)pointer + offset); }")
+;(define-c int (pointer-ref-c-int pointer_ref_c_int) ((pointer void*) int))
+;(c-declare "unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { return *(unsigned int*)((char*)pointer + offset); }")
+;(define-c unsigned-int (pointer-ref-c-unsigned-int pointer_ref_c_unsigned_int) ((pointer void*) int))
+;
+;(c-declare "long pointer_ref_c_long(void* pointer, int offset) { return *(long*)((char*)pointer + offset); }")
+;(define-c long (pointer-ref-c-long pointer_ref_c_long) ((pointer void*) long))
+;(c-declare "unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { return *(unsigned long*)((char*)pointer + offset); }")
+;(define-c unsigned-long (pointer-ref-c-unsigned-long pointer_ref_c_unsigned_long) ((pointer void*) int))
+;
+;(c-declare "float pointer_ref_c_float(void* pointer, int offset) { return *(float*)((char*)pointer + offset); }")
+;(define-c float (pointer-ref-c-float pointer_ref_c_float) ((pointer void*) int))
+;
+;(c-declare "double pointer_ref_c_double(void* pointer, int offset) { return *(double*)((char*)pointer + offset); }")
+;(define-c double (pointer-ref-c-double pointer_ref_c_double) ((pointer void*) int))
+;
+;(c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }")
+;(define-c (maybe-null pointer void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int))
+
+;; define-c-procedure
+
+(c-declare "ffi_cif cif;")
+(define-c (pointer void*) dlsym ((maybe-null pointer void*) string))
+
+;(c-declare "void* get_ffi_type_int8() { return &ffi_type_sint8; }")
+;(define-c (pointer void*) (get-ffi-type-int8 get_ffi_type_int8) ())
+;(c-declare "void* get_ffi_type_uint8() { return &ffi_type_uint8; }")
+;(define-c (pointer void*) (get-ffi-type-uint8 get_ffi_type_uint8) ())
+;
+;(c-declare "void* get_ffi_type_int16() { return &ffi_type_sint16; }")
+;(define-c (pointer void*) (get-ffi-type-int16 get_ffi_type_int16) ())
+;(c-declare "void* get_ffi_type_uint16() { return &ffi_type_uint16; }")
+;(define-c (pointer void*) (get-ffi-type-uint16 get_ffi_type_uint16) ())
+;
+;(c-declare "void* get_ffi_type_int32() { return &ffi_type_sint32; }")
+;(define-c (pointer void*) (get-ffi-type-int32 get_ffi_type_int32) ())
+;(c-declare "void* get_ffi_type_uint32() { return &ffi_type_uint32; }")
+;(define-c (pointer void*) (get-ffi-type-uint32 get_ffi_type_uint32) ())
+;
+;(c-declare "void* get_ffi_type_int64() { return &ffi_type_sint64; }")
+;(define-c (pointer void*) (get-ffi-type-int64 get_ffi_type_int64) ())
+;(c-declare "void* get_ffi_type_uint64() { return &ffi_type_uint64; }")
+;(define-c (pointer void*) (get-ffi-type-uint64 get_ffi_type_uint64) ())
+;
+;(c-declare "void* get_ffi_type_char() { return &ffi_type_schar; }")
+;(define-c (pointer void*) (get-ffi-type-char get_ffi_type_char) ())
+;(c-declare "void* get_ffi_type_uchar() { return &ffi_type_uchar; }")
+;(define-c (pointer void*) (get-ffi-type-uchar get_ffi_type_uchar) ())
+;
+;(c-declare "void* get_ffi_type_short() { return &ffi_type_sshort; }")
+;(define-c (pointer void*) (get-ffi-type-short get_ffi_type_short) ())
+;(c-declare "void* get_ffi_type_ushort() { return &ffi_type_ushort; }")
+;(define-c (pointer void*) (get-ffi-type-ushort get_ffi_type_ushort) ())
+;
+;(c-declare "void* get_ffi_type_int() { return &ffi_type_sint; }")
+;(define-c (pointer void*) (get-ffi-type-int get_ffi_type_int) ())
+;(c-declare "void* get_ffi_type_uint() { return &ffi_type_uint; }")
+;(define-c (pointer void*) (get-ffi-type-uint get_ffi_type_uint) ())
+;
+;(c-declare "void* get_ffi_type_long() { return &ffi_type_slong; }")
+;(define-c (pointer void*) (get-ffi-type-long get_ffi_type_long) ())
+;
+;(c-declare "void* get_ffi_type_ulong() { return &ffi_type_ulong; }")
+;(define-c (pointer void*) (get-ffi-type-ulong get_ffi_type_ulong) ())
+;
+;(c-declare "void* get_ffi_type_float() { return &ffi_type_float; }")
+;(define-c (pointer void*) (get-ffi-type-float get_ffi_type_float) ())
+;
+;(c-declare "void* get_ffi_type_double() { return &ffi_type_double; }")
+;(define-c (pointer void*) (get-ffi-type-double get_ffi_type_double) ())
+;
+;(c-declare "void* get_ffi_type_void() { return &ffi_type_void; }")
+;(define-c (pointer void*) (get-ffi-type-void get_ffi_type_void) ())
+;
+;(c-declare "void* get_ffi_type_pointer() { return &ffi_type_pointer; }")
+;(define-c (pointer void*) (get-ffi-type-pointer get_ffi_type_pointer) ())
+
+(define-c-const int (FFI-OK "FFI_OK"))
+#;(c-declare
+  "int internal_ffi_prep_cif(unsigned int nargs, void* rtype, void* atypes[]) {
+    printf(\"A1: %u, A2: %u, nargs: %u\\n\", &ffi_type_pointer, atypes[0], nargs);
+    return ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
+  }")
+;(define-c int (internal-ffi-prep-cif internal_ffi_prep_cif) (unsigned-int (pointer void*) (array void*)))
+(c-declare
+  "void* internal_ffi_call(
+      unsigned int nargs,
+      unsigned int rtype,
+      unsigned int atypes[],
+      void* fn,
+      unsigned int rvalue_size,
+      struct sexp_struct* avalues[])
+    {
+    ffi_type* c_atypes[nargs];
+    void* c_avalues[nargs];
+
+    int8_t vals1[nargs];
+    uint8_t vals2[nargs];
+    int16_t vals3[nargs];
+    uint16_t vals4[nargs];
+    int32_t vals5[nargs];
+    uint32_t vals6[nargs];
+    int64_t vals7[nargs];
+    uint64_t vals8[nargs];
+    char vals9[nargs];
+    unsigned char vals10[nargs];
+    short vals11[nargs];
+    unsigned short vals12[nargs];
+    int vals13[nargs];
+    unsigned int vals14[nargs];
+    long vals15[nargs];
+    unsigned long vals16[nargs];
+    float vals17[nargs];
+    double vals18[nargs];
+    void* vals20[nargs];
+
+    for(int i = 0; i < nargs; i++) {
+      void* arg = NULL;
+      switch(atypes[i]) {
+        case 1:
+          c_atypes[i] = &ffi_type_sint8;
+          vals1[i] = (int8_t)sexp_sint_value(avalues[i]);
+          c_avalues[i] = &vals1[i];
+        break;
+        case 2:
+          c_atypes[i] = &ffi_type_uint8;
+          vals2[i] = (uint8_t)sexp_uint_value(avalues[i]);
+          c_avalues[i] = &vals2[i];
+        break;
+        case 3:
+          c_atypes[i] = &ffi_type_sint16;
+          vals3[i] = (int16_t)sexp_sint_value(avalues[i]);
+          c_avalues[i] = &vals3[i];
+        break;
+        case 4:
+          c_atypes[i] = &ffi_type_uint16;
+          vals4[i] = (uint16_t)sexp_uint_value(avalues[i]);
+          c_avalues[i] = &vals4[i];
+        break;
+        case 5:
+          c_atypes[i] = &ffi_type_sint32;
+          vals5[i] = (int32_t)sexp_sint_value(avalues[i]);
+          c_avalues[i] = &vals5[i];
+        break;
+        case 6:
+          c_atypes[i] = &ffi_type_uint32;
+          vals6[i] = (int64_t)sexp_uint_value(avalues[i]);
+          c_avalues[i] = &vals6[i];
+        break;
+        case 7:
+          c_atypes[i] = &ffi_type_sint64;
+          vals7[i] = (int64_t) sexp_sint_value(avalues[i]);
+          c_avalues[i] = &vals7[i];
+        break;
+        case 8:
+          c_atypes[i] = &ffi_type_uint64;
+          vals8[i] = (uint64_t)sexp_uint_value(avalues[i]);
+          c_avalues[i] = &vals8[i];
+        break;
+        case 9:
+          c_atypes[i] = &ffi_type_schar;
+          vals9[i] = (char)sexp_sint_value(avalues[i]);
+          c_avalues[i] = &vals9[i];
+        break;
+        case 10:
+          c_atypes[i] = &ffi_type_uchar;
+          vals10[i] = (unsigned char)sexp_uint_value(avalues[i]);
+        break;
+        case 11:
+          c_atypes[i] = &ffi_type_sshort;
+          vals11[i] = (short)sexp_sint_value(avalues[i]);
+        break;
+        case 12:
+          c_atypes[i] = &ffi_type_ushort;
+          vals12[i] = (unsigned short)sexp_uint_value(avalues[i]);
+        break;
+        case 13:
+          c_atypes[i] = &ffi_type_sint;
+          vals13[i] = (int)sexp_sint_value(avalues[i]);
+          c_avalues[i] = &vals13[i];
+        break;
+        case 14:
+          c_atypes[i] = &ffi_type_uint;
+          vals14[i] = (unsigned int)sexp_uint_value(avalues[i]);
+          c_avalues[i] = &vals14[i];
+        break;
+        case 15:
+          c_atypes[i] = &ffi_type_slong;
+          vals15[i] = (long)sexp_sint_value(avalues[i]);
+          c_avalues[i] = &vals15[i];
+        break;
+        case 16:
+          c_atypes[i] = &ffi_type_ulong;
+          vals16[i] = (unsigned long)sexp_uint_value(avalues[i]);
+          c_avalues[i] = &vals16[i];
+        break;
+        case 17:
+          c_atypes[i] = &ffi_type_float;
+          vals17[i] = (float)sexp_flonum_value(avalues[i]);
+        break;
+        case 18:
+          c_atypes[i] = &ffi_type_double;
+          vals18[i] = (double)sexp_flonum_value(avalues[i]);
+        break;
+        case 19:
+          c_atypes[i] = &ffi_type_void;
+          arg = NULL;
+        break;
+        case 20:
+          c_atypes[i] = &ffi_type_pointer;
+          vals20[i] = sexp_cpointer_value(avalues[i]);
+          c_avalues[i] = &vals20[i];
+        break;
+        default:
+          printf(\"Undefined argument type integer: %i, index: %i\\n\", atypes[i], i);
+          //c_avalues[i] = sexp_cpointer_value(avalues[i]);
+        break;
+      }
+    }
+
+    ffi_type* c_rtype = &ffi_type_void;
+    switch(rtype) {
+      case 1: c_rtype = &ffi_type_sint8; break;
+      case 2: c_rtype = &ffi_type_uint8; break;
+      case 3: c_rtype = &ffi_type_sint16; break;
+      case 4: c_rtype = &ffi_type_uint16; break;
+      case 5: c_rtype = &ffi_type_sint32; break;
+      case 6: c_rtype = &ffi_type_uint32; break;
+      case 7: c_rtype = &ffi_type_sint64; break;
+      case 8: c_rtype = &ffi_type_uint64; break;
+      case 9: c_rtype = &ffi_type_schar; break;
+      case 10: c_rtype = &ffi_type_uchar; break;
+      case 11: c_rtype = &ffi_type_sshort; break;
+      case 12: c_rtype = &ffi_type_ushort; break;
+      case 13: c_rtype = &ffi_type_sint; break;
+      case 14: c_rtype = &ffi_type_uint; break;
+      case 15: c_rtype = &ffi_type_slong; break;
+      case 16: c_rtype = &ffi_type_ulong; break;
+      case 17: c_rtype = &ffi_type_float; break;
+      case 18: c_rtype = &ffi_type_double; break;
+      case 19: c_rtype = &ffi_type_void; break;
+      case 20: c_rtype = &ffi_type_pointer; break;
+      default:
+        printf(\"Undefined return type: %i\\n\", rtype);
+        c_rtype = &ffi_type_pointer;
+      break;
+    }
+
+    int r = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, c_rtype, c_atypes);
+
+    void* rvalue = malloc(rvalue_size);
+    ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues);
+    return rvalue;
+  }")
+(define-c (maybe-null pointer void*)
+          (internal-ffi-call internal_ffi_call)
+          (unsigned-int
+            unsigned-int
+            (array unsigned-int)
+            (pointer void*)
+            unsigned-int
+            (array sexp)))
+
+(c-declare
+  "void* scheme_procedure_to_pointer(sexp proc) {
+    if(sexp_procedurep(proc) == 1) {
+      return 0;  //&sexp_unbox_fixnum(proc);
+    } else {
+      printf(\"NOT A FUNCTION\\n\");
+    }
+    return (void*)proc;
+  }")
+(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp))

snow/foreign/c/primitives/chicken.scm

@@ -1,13 +1,13 @@
 
-(define pffi-type->native-type ; Chicken has this procedure in three places
+(define type->native-type ; Chicken has this procedure in three places
   (lambda (type)
     (cond ((equal? type 'int8) 'byte)
           ((equal? type 'uint8) 'unsigned-byte)
-          ((equal? type 'int16) 'int16_t)
-          ((equal? type 'uint16) 'uint16_t)
-          ((equal? type 'int32) 'int32)
-          ((equal? type 'uint32) 'unsigned-int32)
-          ((equal? type 'int64) 'integer-64)
+          ((equal? type 'int16) 'short)
+          ((equal? type 'uint16) 'unsigned-short)
+          ((equal? type 'int32) 'integer32)
+          ((equal? type 'uint32) 'unsigned-integer32)
+          ((equal? type 'int64) 'integer64)
           ((equal? type 'uint64) 'unsigned-integer64)
           ((equal? type 'char) 'char)
           ((equal? type 'unsigned-char) 'unsigned-char)
@@ -23,24 +23,24 @@
           ((equal? type 'void) 'void)
           ((equal? type 'callback) 'c-pointer)
           ((equal? type 'struct) 'c-pointer)
-          (else (error "pffi-type->native-type -- No such pffi type" type)))) )
+          (else (error "type->native-type -- No such pffi type" type)))))
 
-(define pffi-pointer?
+(define c-bytevector?
   (lambda (object)
     (pointer? object)))
 
-(define-syntax pffi-define
+(define-syntax define-c-procedure
   (er-macro-transformer
     (lambda (expr rename compare)
-      (let* ((pffi-type->native-type ; Chicken has this procedure in three places
+      (let* ((type->native-type ; Chicken has this procedure in three places
                (lambda (type)
                  (cond ((equal? type 'int8) 'byte)
                        ((equal? type 'uint8) 'unsigned-byte)
-                       ((equal? type 'int16) 'int16_t)
-                       ((equal? type 'uint16) 'uint16_t)
-                       ((equal? type 'int32) 'int32)
-                       ((equal? type 'uint32) 'unsigned-int32)
-                       ((equal? type 'int64) 'integer-64)
+                       ((equal? type 'int16) 'short)
+                       ((equal? type 'uint16) 'unsigned-short)
+                       ((equal? type 'int32) 'integer32)
+                       ((equal? type 'uint32) 'unsigned-integer32)
+                       ((equal? type 'int64) 'integer64)
                        ((equal? type 'uint64) 'unsigned-integer64)
                        ((equal? type 'char) 'char)
                        ((equal? type 'unsigned-char) 'unsigned-char)
@@ -56,13 +56,13 @@
                        ((equal? type 'void) 'void)
                        ((equal? type 'callback) 'c-pointer)
                        ((equal? type 'struct) 'c-pointer)
-                       (else (error "pffi-type->native-type -- No such pffi type" type)))))
+                       (else (error "type->native-type -- No such pffi type" type)))))
              (scheme-name (list-ref expr 1))
              (c-name (symbol->string (cadr (list-ref expr 3))))
-             (return-type (pffi-type->native-type (cadr (list-ref expr 4))))
+             (return-type (type->native-type (cadr (list-ref expr 4))))
              (argument-types (if (null? (cdr (list-ref expr 5)))
                                (list)
-                               (map pffi-type->native-type
+                               (map type->native-type
                                     (cadr (list-ref expr 5))))))
         (if (null? argument-types)
           `(define ,scheme-name
@@ -70,18 +70,18 @@
           `(define ,scheme-name
              (foreign-safe-lambda ,return-type ,c-name ,@ argument-types)))))))
 
-(define-syntax pffi-define-callback
+(define-syntax define-c-callback
   (er-macro-transformer
     (lambda (expr rename compare)
-      (let* ((pffi-type->native-type ; Chicken has this procedure in three places
+      (let* ((type->native-type ; Chicken has this procedure in three places
                (lambda (type)
                  (cond ((equal? type 'int8) 'byte)
                        ((equal? type 'uint8) 'unsigned-byte)
-                       ((equal? type 'int16) 'int16_t)
-                       ((equal? type 'uint16) 'uint16_t)
-                       ((equal? type 'int32) 'int32)
-                       ((equal? type 'uint32) 'unsigned-int32)
-                       ((equal? type 'int64) 'integer-64)
+                       ((equal? type 'int16) 'short)
+                       ((equal? type 'uint16) 'unsigned-short)
+                       ((equal? type 'int32) 'integer32)
+                       ((equal? type 'uint32) 'unsigned-integer32)
+                       ((equal? type 'int64) 'integer64)
                        ((equal? type 'uint64) 'unsigned-integer64)
                        ((equal? type 'char) 'char)
                        ((equal? type 'unsigned-char) 'unsigned-char)
@@ -97,10 +97,10 @@
                        ((equal? type 'void) 'void)
                        ((equal? type 'callback) 'c-pointer)
                        ((equal? type 'struct) 'c-pointer)
-                       (else (error "pffi-type->native-type -- No such pffi type" type)))))
+                       (else (error "type->native-type -- No such pffi type" type)))))
              (scheme-name (list-ref expr 1))
-             (return-type (pffi-type->native-type (cadr (list-ref expr 2))))
-             (argument-types (map pffi-type->native-type (cadr (list-ref expr 3))))
+             (return-type (type->native-type (cadr (list-ref expr 2))))
+             (argument-types (map type->native-type (cadr (list-ref expr 3))))
              (argument-names (cadr (list-ref expr 4)))
              (arguments (map
                           (lambda (name type)
@@ -136,46 +136,18 @@
           ((equal? type 'string) (foreign-value "sizeof(void*)" int))
           ((equal? type 'callback) (foreign-value "sizeof(void*)" int)))))
 
-#;(define pffi-pointer-allocate
-  (lambda (size)
-    (allocate size)))
-
-(define pffi-pointer-address
-  (lambda (pointer)
-    (pointer->address pointer)))
-
-(define pffi-pointer-null
+(define make-c-null
   (lambda ()
     (address->pointer 0)))
 
-;(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
-;(pffi-define puts #f 'puts 'int (list 'pointer))
-;(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
+(define-syntax define-c-library
+     (syntax-rules ()
+       ((_ scheme-name headers object-name options)
+        (begin
+          (define scheme-name #t)
+          (shared-object-load headers)))))
 
-#;(define pffi-string->pointer
-  (lambda (string-content)
-    (let* ((size (string-length string-content))
-           (pointer (pffi-pointer-allocate (+ size 1))))
-      (memset pointer 0 (+ size 1))
-      (strncpy-ps pointer (location string-content) size)
-      ;(puts pointer)
-      pointer)))
-
-#;(define pffi-string->pointer
-  (foreign-lambda* c-pointer
-                   ((c-string str))
-                   "C_return((void*)str);"))
-
-
-;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
-;(pffi-define strlen #f 'strlen 'int (list 'pointer))
-
-#;(define pffi-pointer->string
-  (foreign-lambda* c-string
-                   ((c-pointer p))
-                   "C_return((char*)p);"))
-
-(define-syntax pffi-shared-object-load
+(define-syntax shared-object-load
   (er-macro-transformer
     (lambda (expr rename compare)
       (let* ((headers (cadr (car (cdr expr)))))
@@ -185,13 +157,7 @@
                   `(foreign-declare ,(string-append "#include <" header ">")))
                 headers))))))
 
-#;(define pffi-pointer-free
-  (lambda (pointer)
-    (if (not (pointer? pointer))
-      (error "pffi-pointer-free -- Argument is not pointer" pointer))
-    (free pointer)))
-
-(define pffi-pointer-null?
+(define c-null?
   (lambda (pointer)
     (if (and (not (pointer? pointer))
              pointer)
@@ -199,7 +165,23 @@
       (or (not pointer) ; #f counts as null pointer on Chicken
           (= (pointer->address pointer) 0)))))
 
-(define pffi-pointer-set!
+(define c-bytevector-u8-ref
+  (lambda (c-bytevector k)
+   (pointer-u8-ref (pointer+ c-bytevector k))))
+
+(define c-bytevector-u8-set!
+  (lambda (c-bytevector k byte)
+    (pointer-u8-set! (pointer+ c-bytevector k) byte)))
+
+(define c-bytevector-pointer-ref
+  (lambda (c-bytevector k)
+   (address->pointer (pointer-u64-ref (pointer+ c-bytevector k)))))
+
+(define c-bytevector-pointer-set!
+  (lambda (c-bytevector k pointer)
+    (pointer-u64-set! (pointer+ c-bytevector k) (pointer->address pointer))))
+
+#;(define pffi-pointer-set!
   (lambda (pointer type offset value)
     (cond
       ((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
@@ -221,7 +203,7 @@
       ((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value))
       ((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value))))))
 
-(define pffi-pointer-get
+#;(define pffi-pointer-get
   (lambda (pointer type offset)
     (cond
       ((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset)))
@@ -242,8 +224,3 @@
       ((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset)))
       ((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
       ((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))))))
-
-(define pffi-struct-dereference
-  (lambda (struct)
-    (pffi-pointer-address (pffi-struct-pointer struct))))
-

snow/foreign/c/primitives/cyclone.scm

@@ -1,4 +1,4 @@
-(define pffi-type->native-type
+(define type->native-type
   (lambda (type)
     (cond ((equal? type 'int8) int)
           ((equal? type 'uint8) int)
@@ -20,26 +20,26 @@
           ((equal? type 'double) double)
           ((equal? type 'pointer) opaque)
           ((equal? type 'void) c-void)
-          ((equal? type 'struct) 'c-pointer)
-          (else (error "pffi-type->native-type -- No such pffi type" type)))))
+          ((equal? type 'callback) opaque)
+          (else (error "type->native-type -- No such type" type)))))
 
-(define pffi-pointer?
+(define c-bytevector?
   (lambda (object)
     (opaque? object)))
 
-(define-syntax pffi-define
+(define-syntax define-c-procedure
   (er-macro-transformer
     (lambda (expr rename compare)
-      (let* ((pffi-type->native-type
+      (let* ((type->native-type
                (lambda (type)
-                 (cond ((equal? type 'int8) 'byte)
-                       ((equal? type 'uint8) 'unsigned-byte)
-                       ((equal? type 'int16) 'int16_t)
-                       ((equal? type 'uint16) 'uint16_t)
-                       ((equal? type 'int32) 'int32)
-                       ((equal? type 'uint32) 'unsigned-int32)
-                       ((equal? type 'int64) 'integer-64)
-                       ((equal? type 'uint64) 'unsigned-integer64)
+                 (cond ((equal? type 'int8) 'int)
+                       ((equal? type 'uint8) 'int)
+                       ((equal? type 'int16) 'int)
+                       ((equal? type 'uint16) 'int)
+                       ((equal? type 'int32) 'int)
+                       ((equal? type 'uint32) 'int)
+                       ((equal? type 'int64) 'int)
+                       ((equal? type 'uint64) 'int)
                        ((equal? type 'char) 'char)
                        ((equal? type 'unsigned-char) 'unsigned-char)
                        ((equal? type 'short) 'short)
@@ -50,26 +50,26 @@
                        ((equal? type 'unsigned-long) 'unsigned-long)
                        ((equal? type 'float) 'float)
                        ((equal? type 'double) 'double)
-                       ((equal? type 'pointer) 'c-pointer)
-                       ((equal? type 'void) 'void)
-                       ((equal? type 'struct) 'c-pointer)
-                       (else (error "pffi-type->native-type -- No such pffi type" type)))))
-             (scheme-name (car (cdr expr)))
+                       ((equal? type 'pointer) 'opaque)
+                       ((equal? type 'void) 'c-void)
+                       ((equal? type 'callback) 'opaque)
+                       (else (error "type->native-type -- No such type" type)))))
+             (scheme-name (cadr expr))
              (c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
-             (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
+             (return-type (type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
              (argument-types
-               (let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
+               (let ((types (cadr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
                  (if (null? types)
                    '()
-                   (map pffi-type->native-type (map car (map cdr types)))))))
+                   (map type->native-type types)))))
         (if (null? argument-types)
           `(c-define ,scheme-name ,return-type ,c-name)
           `(c-define ,scheme-name
-                     ,return-type ,c-name ,@ argument-types))))))
+                     ,return-type ,c-name ,@argument-types))))))
 
-(define pffi-define-callback
+(define define-c-callback
   (lambda (scheme-name return-type argument-types procedure)
-    (error "pffi-define-callback not yet implemented on Cyclone")))
+    (error "define-callback not yet implemented on Cyclone")))
 
 (define size-of-type
   (lambda (type)
@@ -93,284 +93,280 @@
           ((equal? type 'double) (c-value "sizeof(double)" int))
           ((equal? type 'pointer) (c-value "sizeof(void*)" int)))))
 
-#;(define-c pffi-pointer-allocate
-          "(void *data, int argc, closure _, object k, object size)"
-          "make_c_opaque(opq, malloc(obj_obj2int(size)));
+(define-c pointer-address
+          "(void *data, int argc, closure _, object k, object pointer)"
+          "make_c_opaque(opq, &(void*)opaque_ptr(pointer));
           return_closcall1(data, k, &opq);")
 
-(define pffi-pointer-null
+(define pointer-null
   (lambda ()
     (make-opaque)))
 
-#;(define-c pffi-string->pointer
-          "(void *data, int argc, closure _, object k, object s)"
-          "make_c_opaque(opq, string_str(s));
-          return_closcall1(data, k, &opq);")
+(define-syntax define-c-library
+     (syntax-rules ()
+       ((_ scheme-name headers object-name options)
+        (begin
+          (define scheme-name #t)
+          (shared-object-load headers)))))
 
-#;(define-c pffi-pointer->string
-          "(void *data, int argc, closure _, object k, object p)"
-          "make_string(s, opaque_ptr(p));
-          return_closcall1(data, k, &s);")
-
-(define-syntax pffi-shared-object-load
+(define-syntax shared-object-load
   (er-macro-transformer
     (lambda (expr rename compare)
-      `(begin
-         ,@ (map
+      (let* ((headers (cadr (cadr expr)))
+             (includes (map
                          (lambda (header)
                            `(include-c-header ,(string-append "<" header ">")))
-              (cdr (car (cdr expr))))))))
+                         headers)))
+        `(,@includes)))))
 
-#;(define-c pffi-pointer-free
-          "(void *data, int argc, closure _, object k, object pointer)"
-          "free(opaque_ptr(pointer));
-          return_closcall1(data, k, make_boolean(boolean_t));")
-
-(define pffi-pointer-null?
+(define pointer-null?
   (lambda (pointer)
     (and (opaque? pointer)
          (opaque-null? pointer))))
 
-(define-c pffi-pointer-int8-set!
+(define-c pointer-int8-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-uint8-set!
+(define-c pointer-uint8-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-int16-set!
+(define-c pointer-int16-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-uint16-set!
+(define-c pointer-uint16-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-int32-set!
+(define-c pointer-int32-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-uint32-set!
+(define-c pointer-uint32-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-int64-set!
+(define-c pointer-int64-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-uint64-set!
+(define-c pointer-uint64-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-char-set!
+(define-c pointer-char-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "char* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2char(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-short-set!
+(define-c pointer-short-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "short* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-unsigned-short-set!
+(define-c pointer-unsigned-short-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-int-set!
+(define-c pointer-int-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "int* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-unsigned-int-set!
+(define-c pointer-unsigned-int-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-long-set!
+(define-c pointer-long-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "long* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-unsigned-long-set!
+(define-c pointer-unsigned-long-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = obj_obj2int(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-float-set!
+(define-c pointer-float-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "float* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = double_value(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-double-set!
+(define-c pointer-double-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "double* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = double_value(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define-c pffi-pointer-pointer-set!
+(define-c pointer-pointer-set!
           "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
           "uintptr_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           *p = (uintptr_t)&opaque_ptr(value);
           return_closcall1(data, k, make_boolean(boolean_t));")
 
-(define pffi-pointer-set!
+(define pointer-set!
   (lambda (pointer type offset value)
     (cond
-      ((equal? type 'int8) (pffi-pointer-int8-set! pointer offset value))
-      ((equal? type 'uint8) (pffi-pointer-uint8-set! pointer offset value))
-      ((equal? type 'int16) (pffi-pointer-int16-set! pointer offset value))
-      ((equal? type 'uint16) (pffi-pointer-uint16-set! pointer offset value))
-      ((equal? type 'int32) (pffi-pointer-int32-set! pointer offset value))
-      ((equal? type 'uint32) (pffi-pointer-uint32-set! pointer offset value))
-      ((equal? type 'int64) (pffi-pointer-int64-set! pointer offset value))
-      ((equal? type 'uint64) (pffi-pointer-uint64-set! pointer offset value))
-      ((equal? type 'char) (pffi-pointer-char-set! pointer offset value))
-      ((equal? type 'short) (pffi-pointer-short-set! pointer offset value))
-      ((equal? type 'unsigned-short) (pffi-pointer-unsigned-short-set! pointer offset value))
-      ((equal? type 'int) (pffi-pointer-int-set! pointer offset value))
-      ((equal? type 'unsigned-int) (pffi-pointer-unsigned-int-set! pointer offset value))
-      ((equal? type 'long) (pffi-pointer-long-set! pointer offset value))
-      ((equal? type 'unsigned-long) (pffi-pointer-unsigned-long-set! pointer offset value))
-      ((equal? type 'float) (pffi-pointer-float-set! pointer offset value))
-      ((equal? type 'double) (pffi-pointer-double-set! pointer offset value))
-      ((equal? type 'pointer) (pffi-pointer-pointer-set! pointer offset value)))))
+      ((equal? type 'int8) (pointer-int8-set! pointer offset value))
+      ((equal? type 'uint8) (pointer-uint8-set! pointer offset value))
+      ((equal? type 'int16) (pointer-int16-set! pointer offset value))
+      ((equal? type 'uint16) (pointer-uint16-set! pointer offset value))
+      ((equal? type 'int32) (pointer-int32-set! pointer offset value))
+      ((equal? type 'uint32) (pointer-uint32-set! pointer offset value))
+      ((equal? type 'int64) (pointer-int64-set! pointer offset value))
+      ((equal? type 'uint64) (pointer-uint64-set! pointer offset value))
+      ((equal? type 'char) (pointer-char-set! pointer offset value))
+      ((equal? type 'short) (pointer-short-set! pointer offset value))
+      ((equal? type 'unsigned-short) (pointer-unsigned-short-set! pointer offset value))
+      ((equal? type 'int) (pointer-int-set! pointer offset value))
+      ((equal? type 'unsigned-int) (pointer-unsigned-int-set! pointer offset value))
+      ((equal? type 'long) (pointer-long-set! pointer offset value))
+      ((equal? type 'unsigned-long) (pointer-unsigned-long-set! pointer offset value))
+      ((equal? type 'float) (pointer-float-set! pointer offset value))
+      ((equal? type 'double) (pointer-double-set! pointer offset value))
+      ((equal? type 'pointer) (pointer-pointer-set! pointer offset value)))))
 
-(define-c pffi-pointer-int8-get
+(define-c pointer-int8-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-uint8-get
+(define-c pointer-uint8-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-int16-get
+(define-c pointer-int16-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-uint16-get
+(define-c pointer-uint16-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-int32-get
+(define-c pointer-int32-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-uint32-get
+(define-c pointer-uint32-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-int64-get
+(define-c pointer-int64-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-uint64-get
+(define-c pointer-uint64-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-char-get
+(define-c pointer-char-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "char* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_char2obj(*p));")
 
-(define-c pffi-pointer-short-get
+(define-c pointer-short-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "short* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-unsigned-short-get
+(define-c pointer-unsigned-short-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-int-get
+(define-c pointer-int-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "int* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-unsigned-int-get
+(define-c pointer-unsigned-int-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-long-get
+(define-c pointer-long-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "long* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-unsigned-long-get
+(define-c pointer-unsigned-long-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset);
           return_closcall1(data, k, obj_int2obj(*p));")
 
-(define-c pffi-pointer-float-get
+(define-c pointer-float-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "float* p = opaque_ptr(pointer) + obj_obj2int(offset);
           alloca_double(d, *p);
           return_closcall1(data, k, d);")
 
-(define-c pffi-pointer-double-get
+(define-c pointer-double-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "double* p = opaque_ptr(pointer) + obj_obj2int(offset);
           alloca_double(d, *p);
           return_closcall1(data, k, d);")
 
-(define-c pffi-pointer-pointer-get
+(define-c pointer-pointer-get
           "(void *data, int argc, closure _, object k, object pointer, object offset)"
           "make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset));
           return_closcall1(data, k, &opq);")
 
-(define pffi-pointer-get
+#;(define c-bytevector-u8-set! pointer-uint8-set!)
+(define c-bytevector-u8-ref pointer-uint8-get)
+
+(define pointer-get
   (lambda (pointer type offset)
     (cond
-      ((equal? type 'int8) (pffi-pointer-int8-get pointer offset))
-      ((equal? type 'uint8) (pffi-pointer-uint8-get pointer offset))
-      ((equal? type 'int16) (pffi-pointer-int16-get pointer offset))
-      ((equal? type 'uint16) (pffi-pointer-uint16-get pointer offset))
-      ((equal? type 'int32) (pffi-pointer-int32-get pointer offset))
-      ((equal? type 'uint32) (pffi-pointer-uint32-get pointer offset))
-      ((equal? type 'int64) (pffi-pointer-int64-get pointer offset))
-      ((equal? type 'uint64) (pffi-pointer-uint64-get pointer offset))
-      ((equal? type 'char) (pffi-pointer-char-get pointer offset))
-      ((equal? type 'short) (pffi-pointer-short-get pointer offset))
-      ((equal? type 'unsigned-short) (pffi-pointer-unsigned-short-get pointer offset))
-      ((equal? type 'int) (pffi-pointer-int-get pointer offset))
-      ((equal? type 'unsigned-int) (pffi-pointer-unsigned-int-get pointer offset))
-      ((equal? type 'long) (pffi-pointer-long-get pointer offset))
-      ((equal? type 'unsigned-long) (pffi-pointer-unsigned-long-get pointer offset))
-      ((equal? type 'float) (pffi-pointer-float-get pointer offset))
-      ((equal? type 'double) (pffi-pointer-double-get pointer offset))
-      ((equal? type 'pointer) (pffi-pointer-pointer-get pointer offset)))))
+      ((equal? type 'int8) (pointer-int8-get pointer offset))
+      ((equal? type 'uint8) (pointer-uint8-get pointer offset))
+      ((equal? type 'int16) (pointer-int16-get pointer offset))
+      ((equal? type 'uint16) (pointer-uint16-get pointer offset))
+      ((equal? type 'int32) (pointer-int32-get pointer offset))
+      ((equal? type 'uint32) (pointer-uint32-get pointer offset))
+      ((equal? type 'int64) (pointer-int64-get pointer offset))
+      ((equal? type 'uint64) (pointer-uint64-get pointer offset))
+      ((equal? type 'char) (pointer-char-get pointer offset))
+      ((equal? type 'short) (pointer-short-get pointer offset))
+      ((equal? type 'unsigned-short) (pointer-unsigned-short-get pointer offset))
+      ((equal? type 'int) (pointer-int-get pointer offset))
+      ((equal? type 'unsigned-int) (pointer-unsigned-int-get pointer offset))
+      ((equal? type 'long) (pointer-long-get pointer offset))
+      ((equal? type 'unsigned-long) (pointer-unsigned-long-get pointer offset))
+      ((equal? type 'float) (pointer-float-get pointer offset))
+      ((equal? type 'double) (pointer-double-get pointer offset))
+      ((equal? type 'pointer) (pointer-pointer-get pointer offset)))))

snow/foreign/c/primitives/gambit.scm

@@ -1,11 +1,6 @@
 (c-declare "#include <stdlib.h>")
 (c-declare "#include <stdint.h>")
 
-(define-macro
-  (pffi-init)
-  `(begin (c-define-type pointer (pointer void))
-          (c-define-type callback (pointer void))))
-
 (define size-of-int8_t (c-lambda () int "___return(sizeof(int8_t));"))
 (define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_t));"))
 (define size-of-int16_t (c-lambda () int "___return(sizeof(int16_t));"))
@@ -52,16 +47,18 @@
           (else (error "Can not get size of unknown type" type)))))
 
 (define-macro
-  (pffi-define-library name headers object-name . options)
-  `(begin (define ,name #t)
-          (c-declare ,(apply string-append
+  (define-c-library name headers object-name . options)
+  (begin
+    (let ((c-code (apply string-append
                          (map
                            (lambda (header)
                              (string-append "#include <" header ">" (string #\newline)))
-                               (cdr headers))))))
+                           (car (cdr headers))))))
+      `(begin (define ,name #t) (c-declare ,c-code)))))
+
 
 (define pointer? (c-lambda ((pointer void)) bool  "___return(1);"))
-(define pffi-pointer?
+(define c-bytevector?
   (lambda (object)
     (call-with-current-continuation
       (lambda (k)
@@ -69,19 +66,8 @@
           (lambda (x) #f)
           (lambda () (pointer? object)))))))
 
-(define pffi-pointer-null (c-lambda () (pointer void) "void* p = NULL; ___return(p);"))
-
-(define pointer-null? (c-lambda ((pointer void)) bool  "if(___arg1 == NULL) {  ___return(1); } else { ___return(0); }"))
-(define pffi-pointer-null?
-  (lambda (pointer)
-    (and (pffi-pointer? pointer)
-         (pointer-null? pointer))))
-
-;(define pffi-pointer-allocate (c-lambda (int) (pointer void) "void* p = malloc(___arg1); ___return(p);"))
-
-(define pffi-pointer-address (c-lambda ((pointer void)) ptrdiff_t "void* p = ___arg1; ___return((intptr_t)&p);"))
-
-;(define pffi-pointer-free (c-lambda ((pointer void)) void "free(___arg1);"))
+#;(define c-bytevector-u8-set! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
+(define c-bytevector-u8-ref (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));"))
 
 (define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
 (define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
@@ -167,31 +153,87 @@
           ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
 
 (define-macro
-  (pffi-define scheme-name shared-object c-name return-type argument-types)
-  (letrec* ((native-argument-types
+  (define-c-procedure scheme-name shared-object c-name return-type argument-types)
+  (begin
+    (letrec* ((pffi-type->native-type
+                (lambda (type)
+                  (cond ((equal? type 'int8) 'byte)
+                        ((equal? type 'uint8) 'unsigned-int8)
+                        ((equal? type 'int16) 'int16_t)
+                        ((equal? type 'uint16) 'uint16_t)
+                        ((equal? type 'int32) 'int32)
+                        ((equal? type 'uint32) 'unsigned-int32)
+                        ((equal? type 'int64) 'int64)
+                        ((equal? type 'uint64) 'unsigned-int64)
+                        ((equal? type 'char) 'char)
+                        ((equal? type 'unsigned-char) 'unsigned-char)
+                        ((equal? type 'short) 'short)
+                        ((equal? type 'unsigned-short) 'unsigned-short)
+                        ((equal? type 'int) 'int)
+                        ((equal? type 'unsigned-int) 'unsigned-int)
+                        ((equal? type 'long) 'long)
+                        ((equal? type 'unsigned-long) 'unsigned-long)
+                        ((equal? type 'float) 'float)
+                        ((equal? type 'double) 'double)
+                        ((equal? type 'pointer) '(pointer void))
+                        ((equal? type 'void) 'void)
+                        ((equal? type 'callback) '(pointer void))
+                        (else (error "pffi-type->native-type -- No such pffi type" type)))))
+              (native-argument-types
                 (if (equal? '(list) argument-types)
                   (list)
-                (let ((types (map cdr (cdr argument-types))))
-                  (if (null? types) types (map car types)))))
-            (native-return-type (car (cdr return-type)))
-            (c-arguments (lambda (index argument-count result)
-                           (if (> index argument-count)
+                  (let ((types (map pffi-type->native-type (cadr argument-types))))
+                    (if (null? types) types types))))
+              (native-return-type (pffi-type->native-type (cadr return-type)))
+              (argument-count (length native-argument-types))
+              (c-arguments (lambda (index result)
+                             (if (>= index argument-count)
                                result
                                (c-arguments (+ index 1)
-                                          argument-count
                                             (string-append result
                                                            "___arg"
-                                                         (number->string index)
-                                                         (if (< index argument-count)
+                                                           (number->string (+ index 1))
+                                                           (if (<= index (- argument-count 2))
                                                              ", "
                                                              ""))))))
               (c-code (string-append
                         (if (equal? 'void (cadr return-type)) "" "___return(")
                         (symbol->string (cadr c-name))
-                      "(" (c-arguments 1 (- (length argument-types) 1) "") ")"
+                        "(" (c-arguments 0 "") ")"
                         (if (equal? 'void (cadr return-type)) "" ")")
                         ";")))
       `(define ,scheme-name
          (c-lambda ,native-argument-types
                    ,native-return-type
-                 ,c-code))))
+                   ,c-code)))))
+
+(define-macro
+  (define-c-callback scheme-name return-type argument-types procedure)
+  (let* ((type->native-type
+           (lambda (type)
+             (cond ((equal? type 'int8) 'byte)
+                   ((equal? type 'uint8) 'unsigned-int8)
+                   ((equal? type 'int16) 'int16_t)
+                   ((equal? type 'uint16) 'uint16_t)
+                   ((equal? type 'int32) 'int32)
+                   ((equal? type 'uint32) 'unsigned-int32)
+                   ((equal? type 'int64) 'int64)
+                   ((equal? type 'uint64) 'unsigned-int64)
+                   ((equal? type 'char) 'char)
+                   ((equal? type 'unsigned-char) 'unsigned-char)
+                   ((equal? type 'short) 'short)
+                   ((equal? type 'unsigned-short) 'unsigned-short)
+                   ((equal? type 'int) 'int)
+                   ((equal? type 'unsigned-int) 'unsigned-int)
+                   ((equal? type 'long) 'long)
+                   ((equal? type 'unsigned-long) 'unsigned-long)
+                   ((equal? type 'float) 'float)
+                   ((equal? type 'double) 'double)
+                   ((equal? type 'pointer) '(pointer void))
+                   ((equal? type 'void) 'void)
+                   ((equal? type 'callback) '(pointer void))
+                   (else (error "pffi-type->native-type -- No such pffi type" type)))))
+         (native-return-type (type->native-type (cadr return-type)))
+         (native-argument-types (map type->native-type (cadr argument-types))))
+    `(define ,scheme-name ,procedure
+       #;(c-callback ,native-return-type ,native-argument-types ,procedure))))

snow/foreign/c/primitives/gauche.scm

@@ -1,20 +1,27 @@
-(define-module retropikzel.pffi.gauche
+(define-module foreign.c.primitives.gauche
                (export size-of-type
-                       pffi-shared-object-load
-                       pffi-pointer-null
-                       pffi-pointer-null?
-                       pffi-pointer-allocate
-                       pffi-pointer-address
-                       pffi-pointer?
-                       pffi-pointer-free
-                       pffi-pointer-set!
-                       pffi-pointer-get
-                       pffi-string->pointer
-                       pffi-pointer->string
-                       pffi-define))
+                       shared-object-load
+                       c-bytevector-u8-set!
+                       c-bytevector-u8-ref
+                       c-bytevector-pointer-set!
+                       c-bytevector-pointer-ref
+                       ;pointer-null
+                       ;pointer-null?
+                       ;make-c-bytevector
+                       ;pointer-address
+                       c-bytevector?
+                       c-free
+                       ;pointer-set!
+                       ;pointer-get
+                       ;define-c-procedure
+                       define-c-callback
+                       dlerror
+                       dlsym
+                       internal-ffi-call
+                       ))
 
-(select-module retropikzel.pffi.gauche)
-(dynamic-load "retropikzel/pffi/gauche-pffi")
+(select-module foreign.c.primitives.gauche)
+(dynamic-load "foreign/c/lib/gauche")
 
 (define size-of-type
   (lambda (type)
@@ -41,35 +48,28 @@
       ((equal? type 'pointer) (size-of-pointer))
       ((equal? type 'void) (size-of-void)))))
 
-(define pffi-shared-object-load
+#;(define shared-object-load
   (lambda (path options)
     (shared-object-load path)))
 
-(define pffi-pointer-null
-  (lambda ()
-    (pointer-null)))
-
-(define pffi-pointer-null?
-  (lambda (pointer)
-    (pointer-null? pointer)))
-
-(define pffi-pointer-allocate
+#;(define make-c-bytevector
   (lambda (size)
     (pointer-allocate size)))
 
-(define pffi-pointer-address
-  (lambda (object)
-    (pointer-address object)))
-
-(define pffi-pointer?
+(define c-bytevector?
   (lambda (pointer)
     (pointer? pointer)))
 
-(define pffi-pointer-free
+#;(define c-free
   (lambda (pointer)
     (pointer-free pointer)))
 
-(define pffi-pointer-set!
+(define c-bytevector-u8-set! pointer-set-uint8!)
+(define c-bytevector-u8-ref pointer-get-uint8)
+(define c-bytevector-pointer-set! pointer-set-pointer!)
+(define c-bytevector-pointer-ref pointer-get-pointer)
+
+#;(define pointer-set!
   (lambda (pointer type offset value)
     (cond ((equal? type 'int8) (pointer-set-int8! pointer offset value))
           ((equal? type 'uint8) (pointer-set-uint8! pointer offset value))
@@ -91,7 +91,7 @@
           ((equal? type 'void) (pointer-set-pointer! pointer offset value))
           ((equal? type 'pointer) (pointer-set-pointer! pointer offset value)))))
 
-(define pffi-pointer-get
+#;(define pointer-get
   (lambda (pointer type offset)
     (cond ((equal? type 'int8) (pointer-get-int8 pointer offset))
           ((equal? type 'uint8) (pointer-get-uint8 pointer offset))
@@ -113,7 +113,7 @@
           ((equal? type 'void) (pointer-get-pointer pointer offset))
           ((equal? type 'pointer) (pointer-get-pointer pointer offset)))))
 
-(define pffi-type->libffi-type
+#;(define type->libffi-type
   (lambda (type)
     (cond ((equal? type 'int8) (get-ffi-type-int8))
           ((equal? type 'uint8) (get-ffi-type-uint8))
@@ -138,51 +138,45 @@
           ((equal? type 'pointer) (get-ffi-type-pointer))
           ((equal? type 'callback) (get-ffi-type-pointer)))))
 
-(define argument->pointer
+#;(define type->libffi-type
+  (lambda (type)
+    (cond ((equal? type 'int8) 1)
+          ((equal? type 'uint8) 2)
+          ((equal? type 'int16) 3)
+          ((equal? type 'uint16) 4)
+          ((equal? type 'int32) 5)
+          ((equal? type 'uint32) 6)
+          ((equal? type 'int64) 7)
+          ((equal? type 'uint64) 8)
+          ((equal? type 'char) 9)
+          ((equal? type 'unsigned-char) 10)
+          ((equal? type 'bool) 11)
+          ((equal? type 'short) 12)
+          ((equal? type 'unsigned-short) 13)
+          ((equal? type 'int) 14)
+          ((equal? type 'unsigned-int) 15)
+          ((equal? type 'long) 16)
+          ((equal? type 'unsigned-long) 17)
+          ((equal? type 'float) 18)
+          ((equal? type 'double) 19)
+          ((equal? type 'void) 20)
+          ((equal? type 'pointer) 21)
+          ((equal? type 'callback) 21))))
+
+#;(define argument->pointer
   (lambda (value type)
     (cond ((procedure? value) (scheme-procedure-to-pointer value))
-          (else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
-                  (pffi-pointer-set! pointer type 0 value)
+          (else (let ((pointer (make-c-bytevector (size-of-type type))))
+                  (pointer-set! pointer type 0 value)
                   pointer)))))
 
-(define make-c-function
-  (lambda (shared-object c-name return-type argument-types)
-    (dlerror) ;; Clean all previous errors
-    (let ((c-function (dlsym shared-object c-name))
-          (maybe-dlerror (dlerror)))
-      (when (not (pffi-pointer-null? maybe-dlerror))
-        (error (pffi-pointer->string maybe-dlerror)))
-      (lambda arguments
-        (let ((return-value (pffi-pointer-allocate
-                              (if (equal? return-type 'void)
-                                0
-                                (size-of-type return-type)))))
-          (internal-ffi-call (length argument-types)
-                             (pffi-type->libffi-type return-type)
-                             (map pffi-type->libffi-type argument-types)
-                             c-function
-                             return-value
-                             (map argument->pointer
-                                  arguments
-                                  argument-types))
-          (cond ((not (equal? return-type 'void))
-                 (pffi-pointer-get return-value return-type 0))))))))
-
-(define-syntax pffi-define
-  (syntax-rules ()
-    ((pffi-define scheme-name shared-object c-name return-type argument-types)
-     (define scheme-name
-       (make-c-function shared-object
-                        (symbol->string c-name)
-                        return-type
-                        argument-types)))))
 
 (define make-c-callback
   (lambda (return-type argument-types procedure)
     (scheme-procedure-to-pointer procedure)))
 
-(define-syntax pffi-define-callback
+(define-syntax define-c-callback
   (syntax-rules ()
-    ((pffi-define scheme-name return-type argument-types procedure)
+    ((_ scheme-name return-type argument-types procedure)
      (define scheme-name
        (make-c-callback return-type 'argument-types procedure)))))

snow/foreign/c/primitives/gauche/define-c-procedure.scm

@@ -0,0 +1,25 @@
+;;;; This file is dependent on content of other files added trough (include...)
+;;;; And that's why it is separated
+
+(define make-c-function
+  (lambda (shared-object c-name return-type argument-types)
+    (dlerror) ;; Clean all previous errors
+    (let ((c-function (dlsym shared-object c-name))
+          (maybe-dlerror (dlerror)))
+      (lambda arguments
+        (let ((return-pointer (internal-ffi-call (length argument-types)
+                                                 (type->libffi-type-number return-type)
+                                                 (map type->libffi-type-number argument-types)
+                                                 c-function
+                                                 (size-of-type return-type)
+                                                 arguments)))
+          (c-bytevector-get return-pointer return-type 0))))))
+
+(define-syntax define-c-procedure
+  (syntax-rules ()
+    ((_ scheme-name shared-object c-name return-type argument-types)
+     (define scheme-name
+       (make-c-function shared-object
+                        (symbol->string c-name)
+                        return-type
+                        argument-types)))))

snow/foreign/c/primitives/gauche/gauchelib.scm

@@ -0,0 +1,101 @@
+(in-module foreign.c.primitives.gauche)
+
+(inline-stub
+ (.include "foreign-c-primitives-gauche.h")
+ (define-cproc size-of-int8 () size_of_int8)
+ (define-cproc size-of-uint8 () size_of_uint8)
+ (define-cproc size-of-int16 () size_of_int16)
+ (define-cproc size-of-uint16 () size_of_int16)
+ (define-cproc size-of-int32 () size_of_int32)
+ (define-cproc size-of-uint32 () size_of_int32)
+ (define-cproc size-of-int64 () size_of_int64)
+ (define-cproc size-of-uint64 () size_of_int64)
+ (define-cproc size-of-char () size_of_char)
+ (define-cproc size-of-unsigned-char () size_of_unsigned_char)
+ (define-cproc size-of-short () size_of_short)
+ (define-cproc size-of-unsigned-short () size_of_unsigned_short)
+ (define-cproc size-of-int () size_of_int)
+ (define-cproc size-of-unsigned-int () size_of_unsigned_int)
+ (define-cproc size-of-long () size_of_long)
+ (define-cproc size-of-unsigned-long () size_of_unsigned_long)
+ (define-cproc size-of-float () size_of_float)
+ (define-cproc size-of-double () size_of_double)
+ (define-cproc size-of-string () size_of_string)
+ (define-cproc size-of-pointer () size_of_pointer)
+ (define-cproc size-of-void () size_of_void)
+ (define-cproc shared-object-load (path::<string> options) shared_object_load)
+ ;(define-cproc pointer-null () pointer_null)
+ ;(define-cproc pointer-null? (pointer) is_pointer_null)
+ ;(define-cproc pointer-allocate (size::<int>) pointer_allocate)
+ ;(define-cproc pointer-address (object) pointer_address)
+ (define-cproc pointer? (pointer) is_pointer)
+ ;(define-cproc pointer-free (pointer) pointer_free)
+
+ ;(define-cproc pointer-set-int8! (pointer offset::<int> value::<int8>) pointer_set_int8)
+ (define-cproc pointer-set-uint8! (pointer offset::<int> value::<int8>) pointer_set_uint8)
+ ;(define-cproc pointer-set-int16! (pointer offset::<int> value::<int16>) pointer_set_int16)
+ ;(define-cproc pointer-set-uint16! (pointer offset::<int> value::<int16>) pointer_set_uint16)
+ ;(define-cproc pointer-set-int32! (pointer offset::<int> value::<int32>) pointer_set_int32)
+ ;(define-cproc pointer-set-uint32! (pointer offset::<int> value::<int32>) pointer_set_uint32)
+ ;(define-cproc pointer-set-int64! (pointer offset::<int> value::<int64>) pointer_set_int64)
+ ;(define-cproc pointer-set-uint64! (pointer offset::<int> value::<int64>) pointer_set_uint64)
+ ;(define-cproc pointer-set-char! (pointer offset::<int> value::<char>) pointer_set_char)
+ ;(define-cproc pointer-set-unsigned-char! (pointer offset::<int> value::<char>) pointer_set_unsigned_char)
+ ;(define-cproc pointer-set-short! (pointer offset::<int> value::<short>) pointer_set_short)
+ ;(define-cproc pointer-set-unsigned-short! (pointer offset::<int> value::<short>) pointer_set_unsigned_short)
+ ;(define-cproc pointer-set-int! (pointer offset::<int> value::<int>) pointer_set_int)
+ ;(define-cproc pointer-set-unsigned-int! (pointer offset::<int> value::<int>) pointer_set_unsigned_int)
+ ;(define-cproc pointer-set-long! (pointer offset::<int> value::<long>) pointer_set_long)
+ ;(define-cproc pointer-set-unsigned-long! (pointer offset::<int> value::<long>) pointer_set_unsigned_long)
+ ;(define-cproc pointer-set-float! (pointer offset::<int> value::<float>) pointer_set_float)
+ ;(define-cproc pointer-set-double! (pointer offset::<int> value::<double>) pointer_set_double)
+ (define-cproc pointer-set-pointer! (pointer offset::<int> value) pointer_set_pointer)
+
+ ;(define-cproc pointer-get-int8 (pointer offset::<int>) pointer_get_int8)
+ (define-cproc pointer-get-uint8 (pointer offset::<int>) pointer_get_uint8)
+ ;(define-cproc pointer-get-int16 (pointer offset::<int>) pointer_get_int16)
+ ;(define-cproc pointer-get-uint16 (pointer offset::<int>) pointer_get_uint16)
+ ;(define-cproc pointer-get-int32 (pointer offset::<int>) pointer_get_int32)
+ ;(define-cproc pointer-get-uint32 (pointer offset::<int>) pointer_get_uint32)
+ ;(define-cproc pointer-get-int64 (pointer offset::<int>) pointer_get_int64)
+ ;(define-cproc pointer-get-uint64 (pointer offset::<int>) pointer_get_uint64)
+ ;(define-cproc pointer-get-char (pointer offset::<int>) pointer_get_char)
+ ;(define-cproc pointer-get-unsigned-char (pointer offset::<int>) pointer_get_unsigned_char)
+ ;(define-cproc pointer-get-short (pointer offset::<int>) pointer_get_short)
+ ;(define-cproc pointer-get-unsigned-short (pointer offset::<int>) pointer_get_unsigned_short)
+ ;(define-cproc pointer-get-int (pointer offset::<int>) pointer_get_int)
+ ;(define-cproc pointer-get-unsigned-int (pointer offset::<int>) pointer_get_unsigned_int)
+ ;(define-cproc pointer-get-long (pointer offset::<int>) pointer_get_long)
+ ;(define-cproc pointer-get-unsigned-long (pointer offset::<int>) pointer_get_unsigned_long)
+ ;(define-cproc pointer-get-float (pointer offset::<int>) pointer_get_float)
+ ;(define-cproc pointer-get-double (pointer offset::<int>) pointer_get_double)
+ (define-cproc pointer-get-pointer (pointer offset::<int>) pointer_get_pointer)
+
+ (define-cproc dlerror () internal_dlerror)
+ (define-cproc dlsym (shared-object c-name) internal_dlsym)
+ (define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call)
+ (define-cproc scheme-procedure-to-pointer (procedure) scheme_procedure_to_pointer)
+
+ ;(define-cproc get-ffi-type-int8 () get_ffi_type_int8)
+ ;(define-cproc get-ffi-type-uint8 () get_ffi_type_uint8)
+ ;(define-cproc get-ffi-type-int16 () get_ffi_type_int16)
+ ;(define-cproc get-ffi-type-uint16 () get_ffi_type_uint16)
+ ;(define-cproc get-ffi-type-int32 () get_ffi_type_int32)
+ ;(define-cproc get-ffi-type-uint32 () get_ffi_type_uint32)
+ ;(define-cproc get-ffi-type-int64 () get_ffi_type_int64)
+ ;(define-cproc get-ffi-type-uint64 () get_ffi_type_uint64)
+ ;(define-cproc get-ffi-type-char () get_ffi_type_char)
+ ;(define-cproc get-ffi-type-unsigned-char () get_ffi_type_unsigned_char)
+ ;(define-cproc get-ffi-type-short () get_ffi_type_short)
+ ;(define-cproc get-ffi-type-unsigned-short () get_ffi_type_unsigned_short)
+ ;(define-cproc get-ffi-type-int () get_ffi_type_int)
+ ;(define-cproc get-ffi-type-unsigned-int () get_ffi_type_unsigned_int)
+ ;(define-cproc get-ffi-type-long () get_ffi_type_long)
+ ;(define-cproc get-ffi-type-unsigned-long () get_ffi_type_unsigned_long)
+ ;(define-cproc get-ffi-type-float () get_ffi_type_float)
+ ;(define-cproc get-ffi-type-double () get_ffi_type_double)
+ ;(define-cproc get-ffi-type-void() get_ffi_type_void)
+ ;(define-cproc get-ffi-type-pointer () get_ffi_type_pointer)
+
+ ;(define-cproc procedure-to-pointer (procedure) procedure_to_pointer)
+ )

snow/foreign/c/primitives/gerbil.scm

@@ -0,0 +1,29 @@
+(define pffi-type->native-type
+  (lambda (type)
+    (error "Not defined")))
+
+(define c-bytevector?
+  (lambda (object)
+    (error "Not defined")))
+
+(define-syntax define-c-procedure
+  (syntax-rules ()
+    ((_ scheme-name shared-object c-name return-type argument-types)
+     (error "Not defined"))))
+
+(define size-of-type
+  (lambda (type)
+    (error "Not defined")))
+
+(define pffi-shared-object-load
+  (lambda (header path)
+    (error "Not defined")))
+
+(define pffi-pointer-set!
+  (lambda (pointer type offset value)
+    (let ((p pointer))
+      (error "Not defined"))))
+
+(define pffi-pointer-get
+  (lambda (pointer type offset)
+    (error "Not defined")))

snow/foreign/c/primitives/guile.scm

@@ -0,0 +1,126 @@
+(define type->native-type
+  (lambda (type)
+    (cond ((equal? type 'int8) int8)
+          ((equal? type 'uint8) uint8)
+          ((equal? type 'int16) int16)
+          ((equal? type 'uint16) uint16)
+          ((equal? type 'int32) int32)
+          ((equal? type 'uint32) uint32)
+          ((equal? type 'int64) int64)
+          ((equal? type 'uint64) uint64)
+          ((equal? type 'char) int8)
+          ((equal? type 'unsigned-char) uint8)
+          ((equal? type 'short) short)
+          ((equal? type 'unsigned-short) unsigned-short)
+          ((equal? type 'int) int)
+          ((equal? type 'unsigned-int) unsigned-int)
+          ((equal? type 'long) long)
+          ((equal? type 'unsigned-long) unsigned-long)
+          ((equal? type 'float) float)
+          ((equal? type 'double) double)
+          ((equal? type 'pointer) '*)
+          ((equal? type 'void) void)
+          ((equal? type 'callback) '*)
+          ((equal? type 'struct) '*)
+          (else #f))))
+
+(define c-bytevector?
+  (lambda (object)
+    (pointer? object)))
+
+(define-syntax define-c-procedure
+  (syntax-rules ()
+    ((_ scheme-name shared-object c-name return-type argument-types)
+     (define scheme-name
+       (foreign-library-function shared-object
+                                 (symbol->string c-name)
+                                 #:return-type (type->native-type return-type)
+                                 #:arg-types (map type->native-type argument-types))))))
+
+(define-syntax define-c-callback
+  (syntax-rules ()
+    ((_ scheme-name return-type argument-types procedure)
+     (define scheme-name
+       (procedure->pointer (type->native-type return-type)
+                           procedure
+                           (map type->native-type argument-types))))))
+
+(define size-of-type
+  (lambda (type)
+    (let ((native-type (type->native-type type)))
+      (cond ((equal? native-type void) 0)
+            (native-type (sizeof native-type))
+            (else #f)))))
+
+(define shared-object-load
+  (lambda (path options)
+    (load-foreign-library path)))
+
+(define c-bytevector-u8-set!
+  (lambda (c-bytevector k byte)
+    (let ((p (pointer->bytevector c-bytevector (+ k 100))))
+      (bytevector-u8-set! p k byte))))
+
+(define c-bytevector-u8-ref
+  (lambda (c-bytevector k)
+    (let ((p (pointer->bytevector c-bytevector (+ k 100))))
+      (bytevector-u8-ref p k))))
+
+(define c-bytevector-pointer-set!
+  (lambda (c-bytevector k pointer)
+    (c-bytevector-uint-set! c-bytevector
+                            k
+                            (pointer-address pointer)
+                            (native-endianness)
+                            (size-of-type 'pointer))))
+
+(define c-bytevector-pointer-ref
+  (lambda (c-bytevector k)
+    (make-pointer (c-bytevector-uint-ref c-bytevector
+                                         k
+                                         (native-endianness)
+                                         (size-of-type 'pointer)))))
+
+#;(define pointer-set!
+(lambda (pointer type offset value)
+  (let ((p (pointer->bytevector pointer (+ offset 100))))
+    (cond ((equal? type 'int8) (bytevector-s8-set! p offset value))
+          ((equal? type 'uint8) (bytevector-u8-set! p offset value))
+          ((equal? type 'int16) (bytevector-s16-set! p offset value (native-endianness)))
+          ((equal? type 'uint16) (bytevector-u16-set! p offset value (native-endianness)))
+          ((equal? type 'int32) (bytevector-s32-set! p offset value (native-endianness)))
+          ((equal? type 'uint32) (bytevector-u32-set! p offset value (native-endianness)))
+          ((equal? type 'int64) (bytevector-s64-set! p offset value (native-endianness)))
+          ((equal? type 'uint64) (bytevector-u64-set! p offset value (native-endianness)))
+          ((equal? type 'char) (bytevector-s8-set! p offset (char->integer value)))
+          ((equal? type 'short) (bytevector-s8-set! p offset value))
+          ((equal? type 'unsigned-short) (bytevector-u8-set! p offset value))
+          ((equal? type 'int) (bytevector-sint-set! p offset value (native-endianness) (size-of-type type)))
+          ((equal? type 'unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (size-of-type type)))
+          ((equal? type 'long) (bytevector-s64-set! p offset value (native-endianness)))
+          ((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
+          ((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness)))
+          ((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness)))
+          ((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))))))
+
+#;(define pointer-get
+(lambda (pointer type offset)
+  (let ((p (pointer->bytevector pointer (+ offset 100))))
+    (cond ((equal? type 'int8) (bytevector-s8-ref p offset))
+          ((equal? type 'uint8) (bytevector-u8-ref p offset))
+          ((equal? type 'int16) (bytevector-s16-ref p offset (native-endianness)))
+          ((equal? type 'uint16) (bytevector-u16-ref p offset (native-endianness)))
+          ((equal? type 'int32) (bytevector-s32-ref p offset (native-endianness)))
+          ((equal? type 'uint32) (bytevector-u32-ref p offset (native-endianness)))
+          ((equal? type 'int64) (bytevector-s64-ref p offset (native-endianness)))
+          ((equal? type 'uint64) (bytevector-u64-ref p offset (native-endianness)))
+          ((equal? type 'char) (integer->char (bytevector-s8-ref p offset)))
+          ((equal? type 'short) (bytevector-s8-ref p offset))
+          ((equal? type 'unsigned-short) (bytevector-u8-ref p offset))
+          ((equal? type 'int) (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))
+          ((equal? type 'unsigned-int) (bytevector-uint-ref p offset (native-endianness) (size-of-type type)))
+          ((equal? type 'long) (bytevector-s64-ref p offset (native-endianness)))
+          ((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
+          ((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness)))
+          ((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness)))
+          ((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))))))

snow/foreign/c/primitives/include/foreign-c-primitives-gauche.h

@@ -26,16 +26,17 @@ extern ScmObj size_of_double();
 extern ScmObj size_of_string();
 extern ScmObj size_of_pointer();
 extern ScmObj size_of_void();
-extern ScmObj shared_object_load(ScmString* path);
-extern ScmObj pointer_null();
-extern ScmObj is_pointer_null();
-extern ScmObj pointer_allocate(int size);
-extern ScmObj pointer_address(ScmObj object);
+extern ScmObj shared_object_load(ScmString* path, ScmObj options);
+//extern ScmObj pointer_null();
+//extern ScmObj is_pointer_null();
+//extern ScmObj pointer_allocate(int size);
+//extern ScmObj pointer_address(ScmObj pointer);
 extern ScmObj is_pointer(ScmObj pointer);
-extern ScmObj pointer_free(ScmObj pointer);
+//extern ScmObj pointer_free(ScmObj pointer);
 
-extern ScmObj pointer_set_int8(ScmObj pointer, int offset, int8_t value);
+//extern ScmObj pointer_set_int8(ScmObj pointer, int offset, int8_t value);
 extern ScmObj pointer_set_uint8(ScmObj pointer, int offset, uint8_t value);
+/*
 extern ScmObj pointer_set_int16(ScmObj pointer, int offset, int16_t value);
 extern ScmObj pointer_set_uint16(ScmObj pointer, int offset, uint16_t value);
 extern ScmObj pointer_set_int32(ScmObj pointer, int offset, int32_t value);
@@ -52,10 +53,12 @@ extern ScmObj pointer_set_long(ScmObj pointer, int offset, long value);
 extern ScmObj pointer_set_unsigned_long(ScmObj pointer, int offset, unsigned long value);
 extern ScmObj pointer_set_float(ScmObj pointer, int offset, float value);
 extern ScmObj pointer_set_double(ScmObj pointer, int offset, double value);
+*/
 extern ScmObj pointer_set_pointer(ScmObj pointer, int offset, ScmObj value);
 
-extern ScmObj pointer_get_int8(ScmObj pointer, int offset);
+//extern ScmObj pointer_get_int8(ScmObj pointer, int offset);
 extern ScmObj pointer_get_uint8(ScmObj pointer, int offset);
+/*
 extern ScmObj pointer_get_int16(ScmObj pointer, int offset);
 extern ScmObj pointer_get_uint16(ScmObj pointer, int offset);
 extern ScmObj pointer_get_int32(ScmObj pointer, int offset);
@@ -72,13 +75,15 @@ extern ScmObj pointer_get_long(ScmObj pointer, int offset);
 extern ScmObj pointer_get_unsigned_long(ScmObj pointer, int offset);
 extern ScmObj pointer_get_float(ScmObj pointer, int offset);
 extern ScmObj pointer_get_double(ScmObj pointer, int offset);
+*/
 extern ScmObj pointer_get_pointer(ScmObj pointer, int offset);
 
-extern ScmObj string_to_pointer(ScmObj string);
-extern ScmObj pointer_to_string(ScmObj pointer);
-extern ScmObj pffi_dlerror();
-extern ScmObj pffi_dlsym(ScmObj shared_object, ScmObj c_name);
+//extern ScmObj string_to_pointer(ScmObj string);
+//extern ScmObj pointer_to_string(ScmObj pointer);
+extern ScmObj internal_dlerror();
+extern ScmObj internal_dlsym(ScmObj shared_object, ScmObj c_name);
 extern ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, ScmObj rvalue, ScmObj avalues);
+extern ScmObj scheme_procedure_to_pointer(ScmObj procedure);
 
 extern ScmObj get_ffi_type_int8();
 extern ScmObj get_ffi_type_uint8();

snow/foreign/c/primitives/kawa.scm

@@ -26,7 +26,7 @@
            (java.lang.Char value))
           (else value))))
 
-(define pffi-type->native-type
+(define type->native-type
   (lambda (type)
     (cond
       ((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
@@ -48,20 +48,19 @@
       ((equal? type 'float) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT) 'withByteAlignment 4))
       ((equal? type 'double) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE) 'withByteAlignment 8))
       ((equal? type 'pointer) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
-      ((equal? type 'string) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
       ((equal? type 'void) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1))
       ((equal? type 'callback) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
       ((equal? type 'struct) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
       (else #f))))
 
-(define pffi-pointer?
+(define c-bytevector?
   (lambda (object)
     (string=? (invoke (invoke object 'getClass) 'getName)
               "jdk.internal.foreign.NativeMemorySegmentImpl")))
 
-(define-syntax pffi-define
+(define-syntax define-c-procedure
   (syntax-rules ()
-    ((pffi-define scheme-name shared-object c-name return-type argument-types)
+    ((_ scheme-name shared-object c-name return-type argument-types)
      (define scheme-name
        (lambda vals
          (invoke (invoke (cdr (assoc 'linker shared-object))
@@ -72,10 +71,10 @@
                                  'orElseThrow)
                          (if (equal? return-type 'void)
                            (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)
-                                  (map pffi-type->native-type argument-types))
+                                  (map type->native-type argument-types))
                            (apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
-                                  (pffi-type->native-type return-type)
-                                  (map pffi-type->native-type argument-types))))
+                                  (type->native-type return-type)
+                                  (map type->native-type argument-types))))
                  'invokeWithArguments
                  (map value->object vals argument-types)))))))
 
@@ -89,7 +88,7 @@
              (looper (+ count 1) (append result (list count)))))))
       (looper from (list)))))
 
-(define-syntax pffi-define-callback
+(define-syntax define-c-callback
   (syntax-rules ()
     ((_ scheme-name return-type argument-types procedure)
      (define scheme-name
@@ -104,10 +103,10 @@
                 (let ((function-descriptor
                         (if (equal? return-type 'void)
                           (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)
-                                 (map pffi-type->native-type argument-types))
+                                 (map type->native-type argument-types))
                           (apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
-                                 (pffi-type->native-type return-type)
-                                 (map pffi-type->native-type argument-types)))))
+                                 (type->native-type return-type)
+                                 (map type->native-type argument-types)))))
                   (write function-descriptor)
                   (newline)
                   (write (invoke function-descriptor 'getClass))
@@ -126,34 +125,16 @@
 
 (define size-of-type
   (lambda (type)
-    (let ((native-type (pffi-type->native-type type)))
+    (let ((native-type (type->native-type type)))
       (if native-type
         (invoke native-type 'byteAlignment)
         #f))))
 
-#;(define pffi-pointer-allocate
-  (lambda (size)
-    (invoke (invoke arena 'allocate size 1) 'reinterpret size)))
-
-(define pffi-pointer-address
-  (lambda (pointer)
-    (invoke pointer 'address)))
-
-(define pffi-pointer-null
+(define make-c-null
   (lambda ()
     (static-field java.lang.foreign.MemorySegment 'NULL)))
 
-#;(define pffi-string->pointer
-  (lambda (string-content)
-    (let ((size (+ (invoke string-content 'length) 1)))
-      (invoke (invoke arena 'allocateFrom (invoke string-content 'toString))
-              'reinterpret size))))
-
-#;(define pffi-pointer->string
-  (lambda (pointer)
-    (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getString 0)))
-
-(define pffi-shared-object-load
+(define shared-object-load
   (lambda (path options)
     (let* ((library-file (make java.io.File path))
            (file-name (invoke library-file 'getName))
@@ -169,40 +150,47 @@
       (list (cons 'linker linker)
             (cons 'lookup lookup)))))
 
-#;(define pffi-pointer-free
+(define null-pointer (make-c-null))
+(define c-null?
   (lambda (pointer)
-    #t))
+    (invoke pointer 'equals null-pointer)))
 
-(define pffi-pointer-null?
-  (lambda (pointer)
-    (invoke pointer 'equals (pffi-pointer-null))))
-
-(define pffi-pointer-set!
-  (lambda (pointer type offset value)
-    (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
+(define u8-value-layout (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
+(define c-bytevector-u8-set!
+  (lambda (c-bytevector k byte)
+    (invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
             'set
-            (pffi-type->native-type type)
-            offset
-            (if (equal? type 'char)
-              (char->integer value)
-              value))))
-
-(define pffi-pointer-get
-  (lambda (pointer type offset)
-    (let ((r (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
+            u8-value-layout
+            k
+            byte)))
+(define c-bytevector-u8-ref
+  (lambda (c-bytevector k)
+    (invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
             'get
-                     (pffi-type->native-type type)
-                     offset)))
-      (if (equal? type 'char)
-        (integer->char r)
-        r))))
+            u8-value-layout
+            k)))
 
-#;(define pffi-struct-dereference
-  (lambda (struct)
-    ;; WIP
-    (pffi-struct-pointer struct)
-    #;(invoke (pffi-struct-pointer struct) 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
-    #;(invoke (pffi-struct-pointer struct)
+(define pointer-value-layout (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
+(define c-bytevector-pointer-set!
+  (lambda (c-bytevector k pointer)
+    (invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
+            'set
+            pointer-value-layout
+            k
+            pointer)))
+
+(define c-bytevector-pointer-ref
+  (lambda (c-bytevector k)
+    (invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
             'get
-            (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1)
-            0)))
+            pointer-value-layout
+            k)))
+
+#;(define-syntax call-with-address-of-c-bytevector
+          (syntax-rules ()
+            ((_ input-pointer thunk)
+             (let ((address-pointer (make-c-bytevector (c-type-size 'pointer))))
+               (pointer-set! address-pointer 'pointer 0 input-pointer)
+               (apply thunk (list address-pointer))
+               (set! input-pointer (pointer-get address-pointer 'pointer 0))
+               (c-free address-pointer)))))

snow/foreign/c/primitives/larceny.scm

@@ -0,0 +1,76 @@
+(require 'std-ffi)
+(require 'ffi-load)
+(require 'foreign-ctools)
+(require 'foreign-cenums)
+(require 'foreign-stdlib)
+(require 'foreign-sugar)
+(require 'system-interface)
+
+;; FIXME
+(define size-of-type
+  (lambda (type)
+    (cond ((eq? type 'int8) 1)
+          ((eq? type 'uint8) 1)
+          ((eq? type 'int16) 2)
+          ((eq? type 'uint16) 2)
+          ((eq? type 'int32) 4)
+          ((eq? type 'uint32) 4)
+          ((eq? type 'int64) 8)
+          ((eq? type 'uint64) 8)
+          ((eq? type 'char) 1)
+          ((eq? type 'unsigned-char) 1)
+          ((eq? type 'short) 2)
+          ((eq? type 'unsigned-short) 2)
+          ((eq? type 'int) 4)
+          ((eq? type 'unsigned-int) 4)
+          ((eq? type 'long) 4)
+          ((eq? type 'unsigned-long) 4)
+          ((eq? type 'float) 4)
+          ((eq? type 'double) 8)
+          ((eq? type 'pointer) sizeof:pointer)
+          ((eq? type 'void) 0)
+          ((eq? type 'callback) sizeof:pointer)
+          (else (error "Can not get size of unknown type" type)))))
+
+(define c-bytevector?
+  (lambda (object)
+    ;(void*? object)
+    (number? object)))
+
+(define shared-object-load
+  (lambda (headers path . options)
+    (foreign-file path)))
+
+(define c-bytevector-u8-set!
+  (lambda (c-bytevector k byte)
+    (syscall syscall:poke-bytes c-bytevector k (c-type-size 'uint8) byte)))
+
+(define c-bytevector-u8-ref
+  (lambda (c-bytevector k)
+    (syscall syscall:peek-bytes c-bytevector k (c-type-size 'uint8))))
+
+(define c-bytevector-pointer-set!
+  (lambda (c-bytevector k pointer)
+    (syscall syscall:poke-bytes c-bytevector k (c-type-size 'pointer) pointer)))
+
+(define c-bytevector-pointer-ref
+  (lambda (c-bytevector k)
+    (syscall syscall:peek-bytes c-bytevector k (c-type-size 'pointer))))
+
+(define-syntax define-c-procedure
+  (syntax-rules ()
+    ((_ scheme-name shared-object c-name return-type argument-types)
+     (define scheme-name
+       0
+
+       #;(make-c-function shared-object
+                        (symbol->string c-name)
+                        return-type
+                        argument-types)))))
+
+(define-syntax define-c-callback
+  (syntax-rules ()
+    ((_ scheme-name return-type argument-types procedure)
+     (define scheme-name
+       0
+       #;(make-c-callback return-type argument-types procedure)))))

snow/foreign/c/primitives/mosh.scm

@@ -19,40 +19,24 @@
           ((eq? type 'float) size-of-float)
           ((eq? type 'double) size-of-double)
           ((eq? type 'pointer) size-of-pointer)
-          ((eq? type 'string) size-of-pointer)
           ((eq? type 'callback) size-of-pointer)
           ((eq? type 'void) 0)
           (else #f))))
 
-(define pffi-shared-object-load
-  (lambda (path . options)
+(define shared-object-load
+  (lambda (path options)
     (open-shared-library path)))
 
-(define pffi-pointer-null
-  (lambda ()
-    pointer-null))
-
-(define pffi-pointer-null?
-  (lambda (pointer)
-    (pointer-null? pointer)))
-
-#;(define pffi-pointer-allocate
-  (lambda (size)
-    (malloc size)))
-
-(define pffi-pointer-address
-  (lambda (pointer)
-    (pointer->integer pointer)))
-
-(define pffi-pointer?
+(define c-bytevector?
   (lambda (object)
     (pointer? object)))
 
-#;(define pffi-pointer-free
-  (lambda (pointer)
-    (free pointer)))
+(define c-bytevector-u8-set! pointer-set-c-uint8!)
+(define c-bytevector-u8-ref pointer-ref-c-uint8)
+(define c-bytevector-pointer-set! pointer-set-c-pointer!)
+(define c-bytevector-pointer-ref pointer-ref-c-pointer)
 
-(define pffi-pointer-set!
+#;(define pointer-set!
   (lambda (pointer type offset value)
     (cond ((equal? type 'int8) (pointer-set-c-int8! pointer offset value))
           ((equal? type 'uint8) (pointer-set-c-uint8! pointer offset value))
@@ -74,7 +58,7 @@
           ((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
           ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
 
-(define pffi-pointer-get
+#;(define pointer-get
   (lambda (pointer type offset)
     (cond ((equal? type 'int8) (pointer-ref-c-int8 pointer offset))
           ((equal? type 'uint8) (pointer-ref-c-uint8 pointer offset))
@@ -96,23 +80,7 @@
           ((equal? type 'void) (pointer-ref-c-pointer pointer offset))
           ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
 
-#;(define pffi-string->pointer
-  (lambda (string-content)
-    (let ((pointer (pffi-pointer-allocate (+ (string-length string-content) 1)))
-          (index 0))
-      (string-for-each
-        (lambda (c)
-          (pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) c)
-          (set! index (+ index 1)))
-        string-content)
-      (pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) #\null)
-      pointer)))
-
-#;(define pffi-pointer->string
-  (lambda (pointer)
-    (pointer->string pointer)))
-
-(define pffi-type->native-type
+(define type->native-type
   (lambda (type)
     (cond ((equal? type 'int8) 'int8_t)
           ((equal? type 'uint8) 'uint8_t)
@@ -133,29 +101,23 @@
           ((equal? type 'float) 'float)
           ((equal? type 'double) 'double)
           ((equal? type 'pointer) 'void*)
-          ((equal? type 'string) 'char*)
           ((equal? type 'void) 'void)
           ((equal? type 'callback) 'void*)
-          ((equal? type 'struct) 'void*)
-          (else (error "pffi-type->native-type -- No such pffi type" type)))))
+          (else (error "type->native-type -- No such type" type)))))
 
-(define-syntax pffi-define
+(define-syntax define-c-procedure
   (syntax-rules ()
-    ((pffi-define scheme-name shared-object c-name return-type argument-types)
+    ((_ scheme-name shared-object c-name return-type argument-types)
      (define scheme-name
        (make-c-function shared-object
-                        (pffi-type->native-type return-type)
+                        (type->native-type return-type)
                         c-name
-                        (map pffi-type->native-type argument-types))))))
+                        (map type->native-type argument-types))))))
 
-(define-syntax pffi-define-callback
+(define-syntax define-c-callback
   (syntax-rules ()
     ((_ scheme-name return-type argument-types procedure)
      (define scheme-name
-       (make-c-callback (pffi-type->native-type return-type)
-                        (map pffi-type->native-type argument-types)
+       (make-c-callback (type->native-type return-type)
+                        (map type->native-type argument-types)
                         procedure)))))
-
-#;(define pffi-struct-dereference
-  (lambda (struct)
-    (pffi-struct-pointer struct)))

snow/foreign/c/primitives/racket.scm

@@ -0,0 +1,83 @@
+(define type->native-type
+  (lambda (type)
+    (cond ((equal? type 'int8) _int8)
+          ((equal? type 'uint8) _uint8)
+          ((equal? type 'int16) _int16)
+          ((equal? type 'uint16) _uint16)
+          ((equal? type 'int32) _int32)
+          ((equal? type 'uint32) _uint32)
+          ((equal? type 'int64) _int64)
+          ((equal? type 'uint64) _uint64)
+          ((equal? type 'char) _int8)
+          ((equal? type 'unsigned-char) _uint8)
+          ((equal? type 'short) _short)
+          ((equal? type 'unsigned-short) _ushort)
+          ((equal? type 'int) _int)
+          ((equal? type 'unsigned-int) _uint)
+          ((equal? type 'long) _long)
+          ((equal? type 'unsigned-long) _ulong)
+          ((equal? type 'float) _float)
+          ((equal? type 'double) _double)
+          ((equal? type 'pointer) _pointer)
+          ((equal? type 'void) _void)
+          ((equal? type 'callback) _pointer)
+          (else #f))))
+
+(define c-bytevector?
+  (lambda (object)
+    (cpointer? object)))
+
+(define-syntax define-c-procedure
+  (syntax-rules ()
+    ((_ scheme-name shared-object c-name return-type argument-types)
+     (define scheme-name
+       (get-ffi-obj c-name
+                    shared-object
+                    (_cprocedure (mlist->list (map type->native-type argument-types))
+                                 (type->native-type return-type)))))))
+
+(define-syntax define-c-callback
+  (syntax-rules ()
+    ((_ scheme-name return-type argument-types procedure)
+     (define scheme-name (function-ptr procedure
+                                       (_cprocedure
+                                         (mlist->list (map type->native-type argument-types))
+                                         (type->native-type return-type)))))))
+
+(define size-of-type
+  (lambda (type)
+    (ctype-sizeof (type->native-type type))))
+
+(define shared-object-load
+  (lambda (path options)
+    (if (and (not (null? options))
+             (assoc 'additional-versions options))
+      (ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions
+                                                      options))
+                                         (list #f))))
+      (ffi-lib path))))
+
+(define c-bytevector-u8-set!
+  (lambda (c-bytevector k byte)
+    (ptr-set! c-bytevector _uint8 'abs k byte)))
+
+(define c-bytevector-u8-ref
+  (lambda (c-bytevector k)
+    (ptr-ref c-bytevector _uint8 'abs k)))
+
+(define c-bytevector-pointer-set!
+  (lambda (c-bytevector k pointer)
+    (ptr-set! c-bytevector _pointer 'abs k pointer)))
+
+(define c-bytevector-pointer-ref
+  (lambda (c-bytevector k)
+    (ptr-ref c-bytevector _pointer 'abs k)))
+
+#;(define-syntax call-with-address-of-c-bytevector
+  (syntax-rules ()
+    ((_ input-pointer thunk)
+     (let ((address-pointer (make-c-bytevector (c-type-size 'pointer))))
+       (c-bytevector-pointer-set! address-pointer 0 input-pointer)
+       (apply thunk (list address-pointer))
+       (set! input-pointer (c-bytevector-pointer-ref address-pointer 0))
+       (c-free address-pointer)))))

snow/foreign/c/primitives/sagittarius.scm

@@ -1,52 +1,3 @@
-(define pffi-type->native-type
-  (lambda (type)
-    (cond ((equal? type 'int8) 'int8_t)
-          ((equal? type 'uint8) 'uint8_t)
-          ((equal? type 'int16) 'int16_t)
-          ((equal? type 'uint16) 'uint16_t)
-          ((equal? type 'int32) 'int32_t)
-          ((equal? type 'uint32) 'uint32_t)
-          ((equal? type 'int64) 'int64_t)
-          ((equal? type 'uint64) 'uint64_t)
-          ((equal? type 'char) 'char)
-          ((equal? type 'unsigned-char) 'char)
-          ((equal? type 'short) 'short)
-          ((equal? type 'unsigned-short) 'unsigned-short)
-          ((equal? type 'int) 'int)
-          ((equal? type 'unsigned-int) 'unsigned-int)
-          ((equal? type 'long) 'long)
-          ((equal? type 'unsigned-long) 'unsigned-long)
-          ((equal? type 'float) 'float)
-          ((equal? type 'double) 'double)
-          ((equal? type 'pointer) 'void*)
-          ((equal? type 'string) 'void*)
-          ((equal? type 'void) 'void)
-          ((equal? type 'callback) 'callback)
-          ((and (pair? type) (equal? 'struct (car type))) 'void*)
-          (else #f))))
-
-(define pffi-pointer?
-  (lambda (object)
-    (or (pointer? object)
-        (string? object))))
-
-(define-syntax pffi-define
-  (syntax-rules ()
-    ((_ scheme-name shared-object c-name return-type argument-types)
-     (define scheme-name
-       (make-c-function shared-object
-                        (pffi-type->native-type return-type)
-                        c-name
-                        (map pffi-type->native-type argument-types))))))
-
-(define-syntax pffi-define-callback
-  (syntax-rules ()
-    ((_ scheme-name return-type argument-types procedure)
-     (define scheme-name
-       (make-c-callback (pffi-type->native-type return-type)
-                        (map pffi-type->native-type argument-types)
-                        procedure)))))
-
 (define size-of-type
   (lambda (type)
     (cond ((eq? type 'int8) size-of-int8_t)
@@ -69,52 +20,65 @@
           ((eq? type 'double) size-of-double)
           ((eq? type 'pointer) size-of-void*)
           ((eq? type 'void) 0)
-          ((eq? type 'string) size-of-void*)
           ((eq? type 'callback) size-of-void*)
           (else #f))))
 
-#;(define pffi-pointer-allocate
-  (lambda (size)
-    (c-malloc size)))
-
-(define pffi-pointer-address
-  (lambda (pointer)
-    (address pointer 0)))
-
-(define pffi-pointer-null
-  (lambda ()
-    (empty-pointer)))
-
-#;(define (string->c-string s)
-  (let* ((bv (string->utf8 s))
-         (p  (allocate-pointer (+ (bytevector-length bv) 1))))
-    (do ((i 0 (+ i 1)))
-      ((= i (bytevector-length bv)) p)
-      (pointer-set-c-uint8! p i (bytevector-u8-ref bv i)))
-    p))
-
-#;(define pffi-string->pointer
-  (lambda (string-content)
-    (string->c-string string-content)))
-
-#;(define pffi-pointer->string
-  (lambda (pointer)
-    (pointer->string pointer)))
-
-(define pffi-shared-object-load
+(define shared-object-load
   (lambda (path options)
     (open-shared-library path)))
 
-#;(define pffi-pointer-free
-  (lambda (pointer)
-    (when (pointer? pointer)
-      (c-free pointer))))
+(define type->native-type
+  (lambda (type)
+    (cond ((equal? type 'int8) 'int8_t)
+          ((equal? type 'uint8) 'uint8_t)
+          ((equal? type 'int16) 'int16_t)
+          ((equal? type 'uint16) 'uint16_t)
+          ((equal? type 'int32) 'int32_t)
+          ((equal? type 'uint32) 'uint32_t)
+          ((equal? type 'int64) 'int64_t)
+          ((equal? type 'uint64) 'uint64_t)
+          ((equal? type 'char) 'char)
+          ((equal? type 'unsigned-char) 'char)
+          ((equal? type 'short) 'short)
+          ((equal? type 'unsigned-short) 'unsigned-short)
+          ((equal? type 'int) 'int)
+          ((equal? type 'unsigned-int) 'unsigned-int)
+          ((equal? type 'long) 'long)
+          ((equal? type 'unsigned-long) 'unsigned-long)
+          ((equal? type 'float) 'float)
+          ((equal? type 'double) 'double)
+          ((equal? type 'pointer) 'void*)
+          ((equal? type 'void) 'void)
+          ((equal? type 'callback) 'callback)
+          (else #f))))
 
-(define pffi-pointer-null?
-  (lambda (pointer)
-    (null-pointer? pointer)))
+(define-syntax define-c-procedure
+  (syntax-rules ()
+    ((_ scheme-name shared-object c-name return-type argument-types)
+     (define scheme-name
+       (make-c-function shared-object
+                        (type->native-type return-type)
+                        c-name
+                        (map type->native-type argument-types))))))
 
-(define pffi-pointer-set!
+(define-syntax define-c-callback
+  (syntax-rules ()
+    ((_ scheme-name return-type argument-types procedure)
+     (define scheme-name
+       (make-c-callback (type->native-type return-type)
+                        (map type->native-type argument-types)
+                        procedure)))))
+
+(define c-bytevector?
+  (lambda (object)
+    (pointer? object)))
+
+(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
+(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
+(define c-bytevector-pointer-set! pointer-set-c-pointer!)
+(define c-bytevector-pointer-ref pointer-ref-c-pointer)
+
+#;(define pointer-set!
   (lambda (pointer type offset value)
     (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
           ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
@@ -136,7 +100,7 @@
           ((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
           ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
 
-(define pffi-pointer-get
+#;(define pointer-get
   (lambda (pointer type offset)
     (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
           ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
@@ -157,3 +121,4 @@
           ((equal? type 'double) (pointer-ref-c-double pointer offset))
           ((equal? type 'void) (pointer-ref-c-pointer pointer offset))
           ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
+

snow/foreign/c/primitives/stklos.scm

@@ -0,0 +1,110 @@
+(define type->native-type
+  (lambda (type)
+    (cond ((equal? type 'int8) :char)
+          ((equal? type 'uint8) :char)
+          ((equal? type 'int16) :short)
+          ((equal? type 'uint16) :ushort)
+          ((equal? type 'int32) :int)
+          ((equal? type 'uint32) :uint)
+          ((equal? type 'int64) :long)
+          ((equal? type 'uint64) :ulong)
+          ((equal? type 'char) :char)
+          ((equal? type 'unsigned-char) :uchar)
+          ((equal? type 'short) :short)
+          ((equal? type 'unsigned-short) :ushort)
+          ((equal? type 'int) :int)
+          ((equal? type 'unsigned-int) :uint)
+          ((equal? type 'long) :long)
+          ((equal? type 'unsigned-long) :ulong)
+          ((equal? type 'float) :float)
+          ((equal? type 'double) :double)
+          ((equal? type 'pointer) :pointer)
+          ((equal? type 'void) :void)
+          ((equal? type 'callback) :pointer)
+          (else (error "type->native-type -- No such pffi type" type)))))
+
+(define c-bytevector?
+  (lambda (object)
+    (cpointer? object)))
+
+(define-syntax define-c-procedure
+  (syntax-rules ()
+    ((_ scheme-name shared-object c-name return-type argument-types)
+     (begin
+       (define type->native-type
+         (lambda (type)
+           (cond ((equal? type 'int8) :char)
+                 ((equal? type 'uint8) :char)
+                 ((equal? type 'int16) :short)
+                 ((equal? type 'uint16) :ushort)
+                 ((equal? type 'int32) :int)
+                 ((equal? type 'uint32) :uint)
+                 ((equal? type 'int64) :long)
+                 ((equal? type 'uint64) :ulong)
+                 ((equal? type 'char) :char)
+                 ((equal? type 'unsigned-char) :char)
+                 ((equal? type 'short) :short)
+                 ((equal? type 'unsigned-short) :ushort)
+                 ((equal? type 'int) :int)
+                 ((equal? type 'unsigned-int) :uint)
+                 ((equal? type 'long) :long)
+                 ((equal? type 'unsigned-long) :ulong)
+                 ((equal? type 'float) :float)
+                 ((equal? type 'double) :double)
+                 ((equal? type 'pointer) :pointer)
+                 ((equal? type 'void) :void)
+                 ((equal? type 'callback) :pointer)
+                 (else (error "type->native-type -- No such pffi type" type)))))
+       (define scheme-name
+         (make-external-function
+           (symbol->string c-name)
+           (map type->native-type argument-types)
+           (type->native-type return-type)
+           shared-object))))))
+
+(define-syntax define-c-callback
+  (syntax-rules ()
+    ((_ scheme-name return-type argument-types procedure)
+     (define scheme-name
+       (%make-callback procedure
+                       (map type->native-type argument-types)
+                       (type->native-type return-type))))))
+
+; FIXME
+(define size-of-type
+  (lambda (type)
+    (cond ((equal? type 'int8) 1)
+          ((equal? type 'uint8) 1)
+          ((equal? type 'int16) 2)
+          ((equal? type 'uint16) 2)
+          ((equal? type 'int32) 4)
+          ((equal? type 'uint32) 4)
+          ((equal? type 'int64) 8)
+          ((equal? type 'uint64) 8)
+          ((equal? type 'char) 1)
+          ((equal? type 'unsigned-char) 1)
+          ((equal? type 'short) 2)
+          ((equal? type 'unsigned-short) 2)
+          ((equal? type 'int) 4)
+          ((equal? type 'unsigned-int) 4)
+          ((equal? type 'long) 8)
+          ((equal? type 'unsigned-long) 8)
+          ((equal? type 'float) 4)
+          ((equal? type 'double) 8)
+          ((equal? type 'pointer) 8))))
+
+(define c-bytevector-u8-set!
+  (lambda (pointer offset value)
+  (cpointer-set! pointer :uint8 value offset)))
+
+(define c-bytevector-u8-ref
+  (lambda (pointer offset)
+    (cpointer-ref pointer :uint8 offset)))
+
+(define c-bytevector-pointer-set!
+  (lambda (pointer offset value)
+    (cpointer-set! pointer :pointer value offset)))
+
+(define c-bytevector-pointer-ref
+  (lambda (pointer offset)
+    (cpointer-ref pointer :pointer offset)))

snow/foreign/c/primitives/ypsilon.scm

@@ -0,0 +1,188 @@
+(define size-of-type
+  (lambda (type)
+    (cond ((eq? type 'int8) (c-sizeof int8_t))
+          ((eq? type 'uint8) (c-sizeof uint8_t))
+          ((eq? type 'int16) (c-sizeof int16_t))
+          ((eq? type 'uint16) (c-sizeof uint16_t))
+          ((eq? type 'int32) (c-sizeof int32_t))
+          ((eq? type 'uint32) (c-sizeof uint32_t))
+          ((eq? type 'int64) (c-sizeof int64_t))
+          ((eq? type 'uint64) (c-sizeof uint64_t))
+          ((eq? type 'char) (c-sizeof char))
+          ((eq? type 'unsigned-char) (c-sizeof char))
+          ((eq? type 'short) (c-sizeof short))
+          ((eq? type 'unsigned-short) (c-sizeof unsigned-short))
+          ((eq? type 'int) (c-sizeof int))
+          ((eq? type 'unsigned-int) (c-sizeof unsigned-int))
+          ((eq? type 'long) (c-sizeof long))
+          ((eq? type 'unsigned-long) (c-sizeof unsigned-long))
+          ((eq? type 'float) (c-sizeof float))
+          ((eq? type 'double) (c-sizeof double))
+          ((eq? type 'pointer) (c-sizeof void*))
+          ((eq? type 'struct) (c-sizeof void*))
+          ((eq? type 'callback) (c-sizeof void*))
+          ((eq? type 'void) 0)
+          (else #f))))
+
+(define c-bytevector?
+  (lambda (object)
+    (number? object)))
+
+(define c-bytevector-u8-set!
+  (lambda (c-bytevector k byte)
+    (bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k)
+                                                     (c-type-size 'uint8))
+                            0
+                            byte)))
+
+(define c-bytevector-u8-ref
+  (lambda (c-bytevector k)
+      (bytevector-c-int8-ref (make-bytevector-mapping (+ c-bytevector k)
+                                                      (c-type-size 'uint8))
+                             0)))
+(define c-bytevector-pointer-set!
+  (lambda (c-bytevector k pointer)
+    (let ((bv (make-bytevector-mapping (+ c-bytevector k) (c-type-size 'pointer))))
+      (bytevector-c-void*-set! bv 0 pointer))))
+(define c-bytevector-pointer-ref
+  (lambda (c-bytevector k)
+    (let ((bv (make-bytevector-mapping (+ c-bytevector k) (c-type-size 'pointer))))
+      (bytevector-c-void*-ref bv 0))))
+
+#;(define pointer-set!
+  (lambda (pointer type offset value)
+    (let ((bv (make-bytevector-mapping (+ pointer offset) (c-type-size type))))
+      (cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value))
+            ((equal? type 'uint8) (bytevector-c-int8-set! bv 0 value))
+            ((equal? type 'int16) (bytevector-c-int16-set! bv 0 value))
+            ((equal? type 'uint16) (bytevector-c-int16-set! bv 0 value))
+            ((equal? type 'int32) (bytevector-c-int32-set! bv 0 value))
+            ((equal? type 'uint32) (bytevector-c-int32-set! bv 0 value))
+            ((equal? type 'int64) (bytevector-c-int64-set! bv 0 value))
+            ((equal? type 'uint64) (bytevector-c-int64-set! bv 0 value))
+            ((equal? type 'char) (bytevector-c-int8-set! bv 0 (char->integer value)))
+            ((equal? type 'short) (bytevector-c-short-set! bv 0 value))
+            ((equal? type 'unsigned-short) (bytevector-c-short-set! bv 0 value))
+            ((equal? type 'int) (bytevector-c-int-set! bv 0 value))
+            ((equal? type 'unsigned-int) (bytevector-c-int-set! bv 0 value))
+            ((equal? type 'long) (bytevector-c-long-set! bv 0 value))
+            ((equal? type 'unsigned-long) (bytevector-c-long-set! bv 0 value))
+            ((equal? type 'float) (bytevector-c-float-set! bv 0 value))
+            ((equal? type 'double) (bytevector-c-double-set! bv 0 value))
+            ((equal? type 'void) (bytevector-c-void*-set! bv 0 value))
+            ((equal? type 'pointer) (bytevector-c-void*-set! bv 0 value))))))
+
+#;(define pointer-get
+  (lambda (pointer type offset)
+    (let ((bv (make-bytevector-mapping (+ pointer offset) (c-type-size type))))
+      (cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0))
+            ((equal? type 'uint8) (bytevector-c-uint8-ref bv 0))
+            ((equal? type 'int16) (bytevector-c-int16-ref bv 0))
+            ((equal? type 'uint16) (bytevector-c-uint16-ref bv 0))
+            ((equal? type 'int32) (bytevector-c-int32-ref bv 0))
+            ((equal? type 'uint32) (bytevector-c-uint32-ref bv 0))
+            ((equal? type 'int64) (bytevector-c-int64-ref bv 0))
+            ((equal? type 'uint64) (bytevector-c-uint64-ref bv 0))
+            ((equal? type 'char) (integer->char (bytevector-c-uint8-ref bv 0)))
+            ((equal? type 'short) (bytevector-c-short-ref bv 0))
+            ((equal? type 'unsigned-short) (bytevector-c-unsigned-short-ref bv 0))
+            ((equal? type 'int) (bytevector-c-int-ref bv 0))
+            ((equal? type 'unsigned-int) (bytevector-c-unsigned-int-ref bv 0))
+            ((equal? type 'long) (bytevector-c-long-ref bv 0))
+            ((equal? type 'unsigned-long) (bytevector-c-unsigned-long-ref bv 0))
+            ((equal? type 'float) (bytevector-c-float-ref bv 0))
+            ((equal? type 'double) (bytevector-c-double-ref bv 0))
+            ((equal? type 'void) (bytevector-c-void*-ref bv 0))
+            ((equal? type 'pointer) (bytevector-c-void*-ref bv 0))))))
+
+(define shared-object-load
+  (lambda (path options)
+    (load-shared-object path)))
+
+#;(define-macro
+  (type->native-type type)
+  `(cond ((equal? ,type 'int8) 'int8_t)
+         ((equal? ,type 'uint8) 'uint8_t)
+         ;((equal? ,type 'int16) 'int16_t)
+         ;((equal? ,type 'uint16) 'uint16_t)
+         ;((equal? ,type 'int32) 'int32_t)
+         ;((equal? ,type 'uint32) 'uint32_t)
+         ;((equal? ,type 'int64) 'int64_t)
+         ;((equal? ,type 'uint64) 'uint64_t)
+         ;((equal? ,type 'char) 'char)
+         ;((equal? ,type 'unsigned-char) 'char)
+         ;((equal? ,type 'short) 'short)
+         ;((equal? ,type 'unsigned-short) 'unsigned-short)
+         ((equal? ,type 'int) 'int)
+         ;((equal? ,type 'unsigned-int) 'unsigned-int)
+         ;((equal? ,type 'long) 'long)
+         ;((equal? ,type 'unsigned-long) 'unsigned-long)
+         ;((equal? ,type 'float) 'float)
+         ;((equal? ,type 'double) 'double)
+         ((equal? ,type 'pointer) 'void*)
+         ((equal? ,type 'void) 'void)
+         ;((equal? ,type 'callback) 'void*)
+         (else (error "type->native-type -- No such type" ,type))))
+
+(define-macro
+  (define-c-procedure scheme-name shared-object c-name return-type argument-types)
+  (begin
+    (let ((type->native-type
+            (lambda (type)
+              (cond ((equal? type 'int8) 'int8_t)
+                    ((equal? type 'uint8) 'uint8_t)
+                    ((equal? type 'int16) 'int16_t)
+                    ((equal? type 'uint16) 'uint16_t)
+                    ((equal? type 'int32) 'int32_t)
+                    ((equal? type 'uint32) 'uint32_t)
+                    ((equal? type 'int64) 'int64_t)
+                    ((equal? type 'uint64) 'uint64_t)
+                    ((equal? type 'char) 'char)
+                    ((equal? type 'unsigned-char) 'char)
+                    ((equal? type 'short) 'short)
+                    ((equal? type 'unsigned-short) 'unsigned-short)
+                    ((equal? type 'int) 'int)
+                    ((equal? type 'unsigned-int) 'unsigned-int)
+                    ((equal? type 'long) 'long)
+                    ((equal? type 'unsigned-long) 'unsigned-long)
+                    ((equal? type 'float) 'float)
+                    ((equal? type 'double) 'double)
+                    ((equal? type 'pointer) 'void*)
+                    ((equal? type 'void) 'void)
+                    ((equal? type 'callback) 'void*)
+                    (else (error "type->native-type -- No such type" type))))))
+      `(define ,scheme-name
+         (c-function ,(type->native-type (cadr return-type))
+                     ,(cadr c-name)
+                     ,(map type->native-type (cadr argument-types)))))))
+
+(define-macro
+  (define-c-callback scheme-name return-type argument-types procedure)
+  (let* ((type->native-type
+           (lambda (type)
+             (cond ((equal? type 'int8) 'int8_t)
+                   ((equal? type 'uint8) 'uint8_t)
+                   ((equal? type 'int16) 'int16_t)
+                   ((equal? type 'uint16) 'uint16_t)
+                   ((equal? type 'int32) 'int32_t)
+                   ((equal? type 'uint32) 'uint32_t)
+                   ((equal? type 'int64) 'int64_t)
+                   ((equal? type 'uint64) 'uint64_t)
+                   ((equal? type 'char) 'char)
+                   ((equal? type 'unsigned-char) 'char)
+                   ((equal? type 'short) 'short)
+                   ((equal? type 'unsigned-short) 'unsigned-short)
+                   ((equal? type 'int) 'int)
+                   ((equal? type 'unsigned-int) 'unsigned-int)
+                   ((equal? type 'long) 'long)
+                   ((equal? type 'unsigned-long) 'unsigned-long)
+                   ((equal? type 'float) 'float)
+                   ((equal? type 'double) 'double)
+                   ((equal? type 'pointer) 'void*)
+                   ((equal? type 'void) 'void)
+                   ((equal? type 'callback) 'void*)
+                   (else (error "type->native-type -- No such type" type)))))
+         (native-return-type (type->native-type (cadr return-type)))
+         (native-argument-types (map type->native-type (cadr argument-types))))
+    `(define ,scheme-name
+       (c-callback ,native-return-type ,native-argument-types ,procedure))))

snow/foreign/c/struct.scm

@@ -15,33 +15,13 @@
                 (size (cdr (assoc 'size size-and-offsets)))
                 (offsets (cdr (assoc 'offsets size-and-offsets)))
                 (pointer (if (and (not (null? arguments))
-                                  (pffi-pointer? (car arguments)))
+                                  (c-bytevector? (car arguments)))
                            (car arguments)
-                           (pffi-pointer-allocate size)))
+                           (make-c-bytevector size)))
                 (c-type-string (if (string? c-type) c-type (symbol->string c-type))))
            (struct-make c-type-string size pointer offsets)))))))
 
-(define pffi-struct-dereference
-  (lambda (struct)
-    (let ((pointer (pffi-pointer-allocate (pffi-struct-size struct)))
-          (offset 0))
-      (for-each
-        (lambda (struct-member)
-          (let* ((member-type (cadr struct-member))
-                 (member-name (car struct-member))
-                 (member-size (pffi-size-of member-type)))
-            (pffi-pointer-set! pointer
-                               member-type
-                               offset
-                               (pffi-struct-get struct member-name))
-            (set! offset (+ offset member-size))))
-        (pffi-struct-members struct))
-    ;(pffi-pointer-get (pffi-struct-pointer struct) 'pointer 0)
-    ;(pffi-pointer-get pointer 'pointer 0)
-    pointer
-    )))
-
-(define pffi-align-of
+(define c-align-of
   (lambda (type)
     (cond-expand
       ;(guile (alignof (pffi-type->native-type type)))
@@ -60,7 +40,7 @@
            (offsets (map (lambda (member)
                            (let* ((name (cdr member))
                                   (type (car member))
-                                  (type-alignment (pffi-align-of type)))
+                                  (type-alignment (c-align-of type)))
                              (when (> (size-of-type type) largest-member-size)
                                (set! largest-member-size (size-of-type type)))
                              (if (or (= size 0)
@@ -97,7 +77,7 @@
   (let* ((size-and-offsets (calculate-struct-size-and-offsets members))
          (size (cdr (assoc 'size size-and-offsets)))
          (offsets (cdr (assoc 'offsets size-and-offsets)))
-         (pointer (if (null? pointer) (pffi-pointer-allocate size) (car pointer)))
+         (pointer (if (null? pointer) (make-c-bytevector size) (car pointer)))
          (c-type (if (string? c-type) c-type (symbol->string c-type))))
     (struct-make c-type size pointer offsets))))
 

snow/retropikzel/pffi.sld

@@ -1,195 +0,0 @@
-(define-library
-  (retropikzel pffi)
-  (cond-expand
-    (chibi
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (chibi ast)
-              (chibi))
-      (include-shared "pffi/chibi-pffi"))
-    (chicken
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (chicken base)
-              (chicken foreign)
-              (chicken locative)
-              (chicken syntax)
-              (chicken memory)
-              (chicken random)))
-    (cyclone
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (cyclone foreign)
-              (scheme cyclone primitives)))
-    (gambit
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (only (gambit) c-declare c-lambda c-define define-macro)))
-    (gauche
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (gauche base)
-              (retropikzel pffi gauche)))
-    (gerbil
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)))
-    (guile
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (rnrs bytevectors)
-              (system foreign)
-              (system foreign-library)
-              (only (guile) include-from-path)))
-    (kawa
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)))
-    (larceny
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (rename (primitives r5rs:require) (r5rs:require require))
-              (primitives std-ffi)
-              (primitives foreign-procedure)
-              (primitives foreign-file)
-              (primitives foreign-stdlib)))
-    (mosh
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (mosh ffi)))
-    (racket
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (only (racket base) system-type)
-              (ffi winapi)
-              (compatibility mlist)
-              (ffi unsafe)
-              (ffi vector)))
-    (sagittarius
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (sagittarius ffi)
-              (sagittarius)))
-    (skint
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)))
-    (stklos
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (stklos))
-      (export make-external-function
-              calculate-struct-size-and-offsets
-              struct-make))
-    (tr7
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)))
-    (ypsilon
-      (import (scheme base)
-              (scheme write)
-              (scheme char)
-              (scheme file)
-              (scheme process-context)
-              (ypsilon c-ffi)
-              (ypsilon c-types)
-              (only (core) define-macro syntax-case))))
-  (export pffi-init
-          pffi-size-of
-          pffi-type?
-          pffi-align-of
-          pffi-define-library
-          pffi-pointer-null
-          pffi-pointer-null?
-          pffi-pointer-allocate
-          pffi-pointer-address
-          pffi-pointer?
-          pffi-pointer-free
-          pffi-pointer-set!
-          pffi-pointer-get
-          pffi-string->pointer
-          pffi-pointer->string
-          pffi-define-struct
-          pffi-struct-pointer
-          pffi-struct-offset-get
-          pffi-struct-get
-          pffi-struct-set!
-          pffi-struct-dereference
-          pffi-array-allocate
-          pffi-array?
-          pffi-pointer->array
-          pffi-array-get
-          pffi-array-set!
-          pffi-list->array
-          pffi-array->list
-          pffi-define
-          pffi-define-callback)
-  (cond-expand
-    (chibi (include "pffi/chibi.scm"))
-    (chicken-5 (include "pffi/chicken.scm"))
-    (chicken-6 (include-relative "pffi/chicken.scm"))
-    (cyclone (include "pffi/cyclone.scm"))
-    (gambit (include "pffi/gambit.scm"))
-    (gauche (include "pffi/gauche.scm"))
-    (gerbil (include "pffi/gerbil.scm"))
-    (guile (include "pffi/guile.scm"))
-    (kawa (include "pffi/kawa.scm"))
-    (larceny (include "pffi/larceny.scm"))
-    (mosh (include "pffi/mosh.scm"))
-    (racket (include "pffi/racket.scm"))
-    (sagittarius (include "pffi/sagittarius.scm"))
-    (skint (include "pffi/skint.scm"))
-    (stklos (include "pffi/stklos.scm"))
-    (tr7 (include "pffi/tr7.scm"))
-    (ypsilon (include "pffi/ypsilon.scm")))
-  ;(include "pffi/shared/union.scm")
-  (cond-expand
-    (chicken-6 (include-relative "pffi/shared/main.scm")
-             (include-relative "pffi/shared/pointer.scm")
-             (include-relative "pffi/shared/array.scm")
-             (include-relative "pffi/shared/struct.scm"))
-    (else (include "pffi/shared/main.scm")
-          (include "pffi/shared/pointer.scm")
-          (include "pffi/shared/array.scm")
-          (include "pffi/shared/struct.scm"))))

snow/retropikzel/pffi/chibi-src/pffi.stub

@@ -1,281 +0,0 @@
-; vim: ft=scheme
-
-(c-system-include "stdint.h")
-(c-system-include "dlfcn.h")
-(c-system-include "ffi.h")
-
-;; pffi-size-of
-(c-declare "
-    int size_of_int8_t() { return sizeof(int8_t); }
-    int size_of_uint8_t() { return sizeof(uint8_t); }
-    int size_of_int16_t() { return sizeof(int16_t); }
-    int size_of_uint16_t() { return sizeof(uint16_t); }
-    int size_of_int32_t() { return sizeof(int32_t); }
-    int size_of_uint32_t() { return sizeof(uint32_t); }
-    int size_of_int64_t() { return sizeof(int64_t); }
-    int size_of_uint64_t() { return sizeof(uint64_t); }
-    int size_of_char() { return sizeof(char); }
-    int size_of_unsigned_char() { return sizeof(unsigned char); }
-    int size_of_short() { return sizeof(short); }
-    int size_of_unsigned_short() { return sizeof(unsigned short); }
-    int size_of_int() { return sizeof(int); }
-    int size_of_unsigned_int() { return sizeof(unsigned int); }
-    int size_of_long() { return sizeof(long); }
-    int size_of_unsigned_long() { return sizeof(unsigned long); }
-    int size_of_float() { return sizeof(float); }
-    int size_of_double() { return sizeof(double); }
-    int size_of_pointer() { return sizeof(void*); }
-")
-
-(define-c int (size-of-int8_t size_of_int8_t) ())
-(define-c int (size-of-uint8_t size_of_uint8_t) ())
-(define-c int (size-of-int16_t size_of_int16_t) ())
-(define-c int (size-of-uint16_t size_of_uint16_t) ())
-(define-c int (size-of-int32_t size_of_int32_t) ())
-(define-c int (size-of-uint32_t size_of_uint32_t) ())
-(define-c int (size-of-int64_t size_of_int64_t) ())
-(define-c int (size-of-uint64_t size_of_uint64_t) ())
-(define-c int (size-of-char size_of_char) ())
-(define-c int (size-of-unsigned-char size_of_unsigned_char) ())
-(define-c int (size-of-short size_of_short) ())
-(define-c int (size-of-unsigned-short size_of_unsigned_short) ())
-(define-c int (size-of-int size_of_int) ())
-(define-c int (size-of-unsigned-int size_of_unsigned_int) ())
-(define-c int (size-of-long size_of_long) ())
-(define-c int (size-of-unsigned-long size_of_unsigned_long) ())
-(define-c int (size-of-float size_of_float) ())
-(define-c int (size-of-double size_of_double) ())
-(define-c int (size-of-pointer size_of_pointer) ())
-
-;; pffi-shape-object-load
-(define-c-const int (RTLD-NOW "RTLD_NOW"))
-(define-c (maybe-null pointer void*) dlopen (string int))
-(define-c (maybe-null pointer void*) dlerror ())
-
-(c-declare "void* pointer_null() { return NULL; }")
-(define-c (pointer void*) (pointer-null pointer_null) ())
-
-(c-declare "int is_pointer_null(void* pointer) { if(pointer == NULL) { return 1; } else { return 0; }; }")
-(define-c bool (is-pointer-null is_pointer_null) ((maybe-null pointer void*)))
-
-(c-declare "void* pointer_allocate(int size) { return malloc(size); }")
-(define-c (maybe-null pointer void*) (pointer-allocate pointer_allocate) (int))
-
-(c-declare "sexp is_pointer(struct sexp_struct* object) {
-           if(sexp_cpointerp(object)) {
-              return SEXP_TRUE;
-           } else {
-              return SEXP_FALSE;
-           }
-           }")
-(define-c sexp (pointer? is_pointer) (sexp))
-
-(c-declare "intptr_t pointer_address(struct sexp_struct* pointer) {
-            return (intptr_t)&sexp_cpointer_value(pointer);
-           }")
-(define-c uint32_t (pointer-address pointer_address) (sexp))
-
-(c-declare "void pointer_free(void* pointer) { free(pointer); }")
-(define-c void (pointer-free pointer_free) ((maybe-null pointer void*)))
-
-;; pffi-pointer-set!
-(c-declare "void pointer_set_c_int8_t(void* pointer, int offset, int8_t value) { *(int8_t*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-int8_t! pointer_set_c_int8_t) ((pointer void*) int int8_t))
-(c-declare "void pointer_set_c_uint8_t(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-uint8_t! pointer_set_c_uint8_t) ((pointer void*) int uint8_t))
-
-(c-declare "void pointer_set_c_int16_t(void* pointer, int offset, int16_t value) { *(int16_t*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-int16_t! pointer_set_c_int16_t) ((pointer void*) int int16_t))
-(c-declare "void pointer_set_c_uint16_t(void* pointer, int offset, uint16_t value) { *(uint16_t*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-uint16_t! pointer_set_c_uint16_t) ((pointer void*) int uint16_t))
-
-(c-declare "void pointer_set_c_int32_t(void* pointer, int offset, int32_t value) { *(int32_t*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-int32_t! pointer_set_c_int32_t) ((pointer void*) int int32_t))
-(c-declare "void pointer_set_c_uint32_t(void* pointer, int offset, uint32_t value) { *(uint32_t*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-uint32_t! pointer_set_c_uint32_t) ((pointer void*) int uint32_t))
-
-(c-declare "void pointer_set_c_int64_t(void* pointer, int offset, int64_t value) { *(int64_t*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-int64_t! pointer_set_c_int64_t) ((pointer void*) int int64_t))
-(c-declare "void pointer_set_c_uint64_t(void* pointer, int offset, uint64_t value) { *(uint64_t*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-uint64_t! pointer_set_c_uint64_t) ((pointer void*) int uint64_t))
-
-(c-declare "void pointer_set_c_char(void* pointer, int offset, char value) { *((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int char))
-(c-declare "void pointer_set_c_unsigned_char(void* pointer, int offset, unsigned char value) { *(unsigned char*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-unsigned-char! pointer_set_c_unsigned_char) ((pointer void*) int unsigned-char))
-
-(c-declare "void pointer_set_c_short(void* pointer, int offset, short value) { *(short*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-short! pointer_set_c_short) ((pointer void*) int short))
-(c-declare "void pointer_set_c_unsigned_short(void* pointer, int offset, unsigned short value) { *(unsigned short*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-unsigned-short! pointer_set_c_unsigned_short) ((pointer void*) int unsigned-short))
-
-(c-declare "void pointer_set_c_int(void* pointer, int offset, int value) { *(int*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-int! pointer_set_c_int) ((pointer void*) int int))
-(c-declare "void pointer_set_c_unsigned_int(void* pointer, int offset, unsigned int value) { *(unsigned int*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-unsigned-int! pointer_set_c_unsigned_int) ((pointer void*) int unsigned-int))
-
-(c-declare "void pointer_set_c_long(void* pointer, int offset, long value) { *(long*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-long! pointer_set_c_long) ((pointer void*) int long))
-(c-declare "void pointer_set_c_unsigned_long(void* pointer, int offset, unsigned long value) { *(unsigned long*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-unsigned-long! pointer_set_c_unsigned_long) ((pointer void*) int unsigned-long))
-
-(c-declare "void pointer_set_c_float(void* pointer, int offset, float value) { *(float*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-float! pointer_set_c_float) ((pointer void*) int float))
-
-(c-declare "void pointer_set_c_double(void* pointer, int offset, double value) { *(double*)((char*)pointer + offset) = value; }")
-(define-c void (pointer-set-c-double! pointer_set_c_double) ((pointer void*) int double))
-
-(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }")
-(define-c void (pointer-set-c-pointer! pointer_set_c_pointer) ((pointer void*) int (maybe-null pointer void*)))
-
-;; pffi-pointer-get
-(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }")
-(define-c int8_t (pointer-ref-c-int8_t pointer_ref_c_int8_t) ((pointer void*) int))
-(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { return *(uint8_t*)((char*)pointer + offset); }")
-(define-c uint8_t (pointer-ref-c-uint8_t pointer_ref_c_uint8_t) ((pointer void*) int))
-
-(c-declare "int16_t pointer_ref_c_int16_t(void* pointer, int offset) { return *(int16_t*)((char*)pointer + offset); }")
-(define-c int16_t (pointer-ref-c-int16_t pointer_ref_c_int16_t) ((pointer void*) int))
-(c-declare "uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { return *(uint16_t*)((char*)pointer + offset); }")
-(define-c uint16_t (pointer-ref-c-uint16_t pointer_ref_c_uint16_t) ((pointer void*) int))
-
-(c-declare "int32_t pointer_ref_c_int32_t(void* pointer, int offset) { return *(int32_t*)((char*)pointer + offset); }")
-(define-c int32_t (pointer-ref-c-int32_t pointer_ref_c_int32_t) ((pointer void*) int))
-(c-declare "uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { return *(uint32_t*)((char*)pointer + offset); }")
-(define-c uint32_t (pointer-ref-c-uint32_t pointer_ref_c_uint32_t) ((pointer void*) int))
-
-(c-declare "int64_t pointer_ref_c_int64_t(void* pointer, int offset) { return *(int64_t*)((char*)pointer + offset); }")
-(define-c int64_t (pointer-ref-c-int64_t pointer_ref_c_int64_t) ((pointer void*) int))
-(c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { return *(uint64_t*)((char*)pointer + offset); }")
-(define-c uint64_t (pointer-ref-c-uint64_t pointer_ref_c_uint64_t) ((pointer void*) int))
-
-(c-declare "char pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); }")
-(define-c char (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int))
-(c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { return *(unsigned char*)((char*)pointer + offset); }")
-(define-c unsigned-char (pointer-ref-c-unsigned-char pointer_ref_c_unsigned_char) ((pointer void*) int))
-
-(c-declare "short pointer_ref_c_short(void* pointer, int offset) { return *(short*)((char*)pointer + offset); }")
-(define-c short (pointer-ref-c-short pointer_ref_c_short) ((pointer void*) int))
-(c-declare "unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { return *(unsigned short*)((char*)pointer + offset); }")
-(define-c unsigned-short (pointer-ref-c-unsigned-short pointer_ref_c_unsigned_short) ((pointer void*) int))
-
-(c-declare "int pointer_ref_c_int(void* pointer, int offset) { return *(int*)((char*)pointer + offset); }")
-(define-c int (pointer-ref-c-int pointer_ref_c_int) ((pointer void*) int))
-(c-declare "unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { return *(unsigned int*)((char*)pointer + offset); }")
-(define-c unsigned-int (pointer-ref-c-unsigned-int pointer_ref_c_unsigned_int) ((pointer void*) int))
-
-(c-declare "long pointer_ref_c_long(void* pointer, int offset) { return *(long*)((char*)pointer + offset); }")
-(define-c long (pointer-ref-c-long pointer_ref_c_long) ((pointer void*) long))
-(c-declare "unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { return *(unsigned long*)((char*)pointer + offset); }")
-(define-c unsigned-long (pointer-ref-c-unsigned-long pointer_ref_c_unsigned_long) ((pointer void*) int))
-
-(c-declare "float pointer_ref_c_float(void* pointer, int offset) { return *(float*)((char*)pointer + offset); }")
-(define-c float (pointer-ref-c-float pointer_ref_c_float) ((pointer void*) int))
-
-(c-declare "double pointer_ref_c_double(void* pointer, int offset) { return *(double*)((char*)pointer + offset); }")
-(define-c double (pointer-ref-c-double pointer_ref_c_double) ((pointer void*) int))
-
-(c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }")
-(define-c (maybe-null pointer void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int))
-
-;; pffi-string->pointer
-;(c-declare "void* string_to_pointer(char* string) { return (void*)string; }")
-;(define-c (maybe-null pointer void*) (string-to-pointer string_to_pointer) (string))
-
-;; pffi-pointer->string
-;(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }")
-;(define-c string (pointer-to-string pointer_to_string) ((maybe-null pointer void*)))
-
-;; pffi-define
-
-(c-declare "ffi_cif cif;")
-(define-c (pointer void*) dlsym ((maybe-null pointer void*) string))
-
-(c-declare "void* get_ffi_type_int8() { return &ffi_type_sint8; }")
-(define-c (pointer void*) (get-ffi-type-int8 get_ffi_type_int8) ())
-(c-declare "void* get_ffi_type_uint8() { return &ffi_type_uint8; }")
-(define-c (pointer void*) (get-ffi-type-uint8 get_ffi_type_uint8) ())
-
-(c-declare "void* get_ffi_type_int16() { return &ffi_type_sint16; }")
-(define-c (pointer void*) (get-ffi-type-int16 get_ffi_type_int16) ())
-(c-declare "void* get_ffi_type_uint16() { return &ffi_type_uint16; }")
-(define-c (pointer void*) (get-ffi-type-uint16 get_ffi_type_uint16) ())
-
-(c-declare "void* get_ffi_type_int32() { return &ffi_type_sint32; }")
-(define-c (pointer void*) (get-ffi-type-int32 get_ffi_type_int32) ())
-(c-declare "void* get_ffi_type_uint32() { return &ffi_type_uint32; }")
-(define-c (pointer void*) (get-ffi-type-uint32 get_ffi_type_uint32) ())
-
-(c-declare "void* get_ffi_type_int64() { return &ffi_type_sint64; }")
-(define-c (pointer void*) (get-ffi-type-int64 get_ffi_type_int64) ())
-(c-declare "void* get_ffi_type_uint64() { return &ffi_type_uint64; }")
-(define-c (pointer void*) (get-ffi-type-uint64 get_ffi_type_uint64) ())
-
-(c-declare "void* get_ffi_type_char() { return &ffi_type_schar; }")
-(define-c (pointer void*) (get-ffi-type-char get_ffi_type_char) ())
-(c-declare "void* get_ffi_type_uchar() { return &ffi_type_uchar; }")
-(define-c (pointer void*) (get-ffi-type-uchar get_ffi_type_uchar) ())
-
-(c-declare "void* get_ffi_type_short() { return &ffi_type_sshort; }")
-(define-c (pointer void*) (get-ffi-type-short get_ffi_type_short) ())
-(c-declare "void* get_ffi_type_ushort() { return &ffi_type_ushort; }")
-(define-c (pointer void*) (get-ffi-type-ushort get_ffi_type_ushort) ())
-
-(c-declare "void* get_ffi_type_int() { return &ffi_type_sint; }")
-(define-c (pointer void*) (get-ffi-type-int get_ffi_type_int) ())
-(c-declare "void* get_ffi_type_uint() { return &ffi_type_uint; }")
-(define-c (pointer void*) (get-ffi-type-uint get_ffi_type_uint) ())
-
-(c-declare "void* get_ffi_type_long() { return &ffi_type_slong; }")
-(define-c (pointer void*) (get-ffi-type-long get_ffi_type_long) ())
-
-(c-declare "void* get_ffi_type_ulong() { return &ffi_type_ulong; }")
-(define-c (pointer void*) (get-ffi-type-ulong get_ffi_type_ulong) ())
-
-(c-declare "void* get_ffi_type_float() { return &ffi_type_float; }")
-(define-c (pointer void*) (get-ffi-type-float get_ffi_type_float) ())
-
-(c-declare "void* get_ffi_type_double() { return &ffi_type_double; }")
-(define-c (pointer void*) (get-ffi-type-double get_ffi_type_double) ())
-
-(c-declare "void* get_ffi_type_void() { return &ffi_type_void; }")
-(define-c (pointer void*) (get-ffi-type-void get_ffi_type_void) ())
-
-(c-declare "void* get_ffi_type_pointer() { return &ffi_type_pointer; }")
-(define-c (pointer void*) (get-ffi-type-pointer get_ffi_type_pointer) ())
-
-(define-c-const int (FFI-OK "FFI_OK"))
-(c-declare
-  "int internal_ffi_prep_cif(unsigned int nargs, void* rtype, void* atypes[]) {
-    printf(\"A1: %u, A2: %u, nargs: %u\\n\", &ffi_type_pointer, atypes[0], nargs);
-    return ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
-  }")
-(define-c int (internal-ffi-prep-cif internal_ffi_prep_cif) (unsigned-int (pointer void*) (array void*)))
-(c-declare
-  "void internal_ffi_call(unsigned int nargs, void* rtype, void** atypes, void* fn, void* rvalue, struct sexp_struct* avalues[]) {
-    ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
-    void* c_avalues[nargs];
-    for(int i = 0; i < nargs; i++) {
-      c_avalues[i] = sexp_cpointer_value(avalues[i]);
-    }
-    ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues);
-  }")
-(define-c void
-          (internal-ffi-call internal_ffi_call)
-          (unsigned-int
-            (pointer void*)
-            (array void*)
-            (pointer void*)
-            (pointer void*)
-            (array sexp)))
-
-(c-declare
-  "void* scheme_procedure_to_pointer(sexp proc) {
-    if(sexp_procedurep(proc) == 1) {
-      return 0;  //&sexp_unbox_fixnum(proc);
-    } else {
-      printf(\"NOT A FUNCTION\\n\");
-    }
-    return (void*)proc;
-  }")
-(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp))

snow/retropikzel/pffi/gauche-src/gauchelib.scm

@@ -1,102 +0,0 @@
-(in-module retropikzel.pffi.gauche)
-
-(inline-stub
- (.include "gauche-pffi.h")
- (define-cproc size-of-int8 () size_of_int8)
- (define-cproc size-of-uint8 () size_of_uint8)
- (define-cproc size-of-int16 () size_of_int16)
- (define-cproc size-of-uint16 () size_of_int16)
- (define-cproc size-of-int32 () size_of_int32)
- (define-cproc size-of-uint32 () size_of_int32)
- (define-cproc size-of-int64 () size_of_int64)
- (define-cproc size-of-uint64 () size_of_int64)
- (define-cproc size-of-char () size_of_char)
- (define-cproc size-of-unsigned-char () size_of_unsigned_char)
- (define-cproc size-of-short () size_of_short)
- (define-cproc size-of-unsigned-short () size_of_unsigned_short)
- (define-cproc size-of-int () size_of_int)
- (define-cproc size-of-unsigned-int () size_of_unsigned_int)
- (define-cproc size-of-long () size_of_long)
- (define-cproc size-of-unsigned-long () size_of_unsigned_long)
- (define-cproc size-of-float () size_of_float)
- (define-cproc size-of-double () size_of_double)
- (define-cproc size-of-string () size_of_string)
- (define-cproc size-of-pointer () size_of_pointer)
- (define-cproc size-of-void () size_of_void)
- (define-cproc shared-object-load (path::<string>) shared_object_load)
- (define-cproc pointer-null () pointer_null)
- (define-cproc pointer-null? (pointer) is_pointer_null)
- (define-cproc pointer-allocate (size::<int>) pointer_allocate)
- (define-cproc pointer-address (object) pointer_address)
- (define-cproc pointer? (pointer) is_pointer)
- (define-cproc pointer-free (pointer) pointer_free)
-
- (define-cproc pointer-set-int8! (pointer offset::<int> value::<int8>) pointer_set_int8)
- (define-cproc pointer-set-uint8! (pointer offset::<int> value::<int8>) pointer_set_uint8)
- (define-cproc pointer-set-int16! (pointer offset::<int> value::<int16>) pointer_set_int16)
- (define-cproc pointer-set-uint16! (pointer offset::<int> value::<int16>) pointer_set_uint16)
- (define-cproc pointer-set-int32! (pointer offset::<int> value::<int32>) pointer_set_int32)
- (define-cproc pointer-set-uint32! (pointer offset::<int> value::<int32>) pointer_set_uint32)
- (define-cproc pointer-set-int64! (pointer offset::<int> value::<int64>) pointer_set_int64)
- (define-cproc pointer-set-uint64! (pointer offset::<int> value::<int64>) pointer_set_uint64)
- (define-cproc pointer-set-char! (pointer offset::<int> value::<char>) pointer_set_char)
- (define-cproc pointer-set-unsigned-char! (pointer offset::<int> value::<char>) pointer_set_unsigned_char)
- (define-cproc pointer-set-short! (pointer offset::<int> value::<short>) pointer_set_short)
- (define-cproc pointer-set-unsigned-short! (pointer offset::<int> value::<short>) pointer_set_unsigned_short)
- (define-cproc pointer-set-int! (pointer offset::<int> value::<int>) pointer_set_int)
- (define-cproc pointer-set-unsigned-int! (pointer offset::<int> value::<int>) pointer_set_unsigned_int)
- (define-cproc pointer-set-long! (pointer offset::<int> value::<long>) pointer_set_long)
- (define-cproc pointer-set-unsigned-long! (pointer offset::<int> value::<long>) pointer_set_unsigned_long)
- (define-cproc pointer-set-float! (pointer offset::<int> value::<float>) pointer_set_float)
- (define-cproc pointer-set-double! (pointer offset::<int> value::<double>) pointer_set_double)
- (define-cproc pointer-set-pointer! (pointer offset::<int> value) pointer_set_pointer)
-
- (define-cproc pointer-get-int8 (pointer offset::<int>) pointer_get_int8)
- (define-cproc pointer-get-uint8 (pointer offset::<int>) pointer_get_uint8)
- (define-cproc pointer-get-int16 (pointer offset::<int>) pointer_get_int16)
- (define-cproc pointer-get-uint16 (pointer offset::<int>) pointer_get_uint16)
- (define-cproc pointer-get-int32 (pointer offset::<int>) pointer_get_int32)
- (define-cproc pointer-get-uint32 (pointer offset::<int>) pointer_get_uint32)
- (define-cproc pointer-get-int64 (pointer offset::<int>) pointer_get_int64)
- (define-cproc pointer-get-uint64 (pointer offset::<int>) pointer_get_uint64)
- (define-cproc pointer-get-char (pointer offset::<int>) pointer_get_char)
- (define-cproc pointer-get-unsigned-char (pointer offset::<int>) pointer_get_unsigned_char)
- (define-cproc pointer-get-short (pointer offset::<int>) pointer_get_short)
- (define-cproc pointer-get-unsigned-short (pointer offset::<int>) pointer_get_unsigned_short)
- (define-cproc pointer-get-int (pointer offset::<int>) pointer_get_int)
- (define-cproc pointer-get-unsigned-int (pointer offset::<int>) pointer_get_unsigned_int)
- (define-cproc pointer-get-long (pointer offset::<int>) pointer_get_long)
- (define-cproc pointer-get-unsigned-long (pointer offset::<int>) pointer_get_unsigned_long)
- (define-cproc pointer-get-float (pointer offset::<int>) pointer_get_float)
- (define-cproc pointer-get-double (pointer offset::<int>) pointer_get_double)
- (define-cproc pointer-get-pointer (pointer offset::<int>) pointer_get_pointer)
-
- (define-cproc string->pointer (string-content) string_to_pointer)
- (define-cproc pointer->string (pointer) pointer_to_string)
- (define-cproc dlerror () pffi_dlerror)
- (define-cproc dlsym (shared-object c-name) pffi_dlsym)
- (define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call)
-
- (define-cproc get-ffi-type-int8 () get_ffi_type_int8)
- (define-cproc get-ffi-type-uint8 () get_ffi_type_uint8)
- (define-cproc get-ffi-type-int16 () get_ffi_type_int16)
- (define-cproc get-ffi-type-uint16 () get_ffi_type_uint16)
- (define-cproc get-ffi-type-int32 () get_ffi_type_int32)
- (define-cproc get-ffi-type-uint32 () get_ffi_type_uint32)
- (define-cproc get-ffi-type-int64 () get_ffi_type_int64)
- (define-cproc get-ffi-type-uint64 () get_ffi_type_uint64)
- (define-cproc get-ffi-type-char () get_ffi_type_char)
- (define-cproc get-ffi-type-unsigned-char () get_ffi_type_unsigned_char)
- (define-cproc get-ffi-type-short () get_ffi_type_short)
- (define-cproc get-ffi-type-unsigned-short () get_ffi_type_unsigned_short)
- (define-cproc get-ffi-type-int () get_ffi_type_int)
- (define-cproc get-ffi-type-unsigned-int () get_ffi_type_unsigned_int)
- (define-cproc get-ffi-type-long () get_ffi_type_long)
- (define-cproc get-ffi-type-unsigned-long () get_ffi_type_unsigned_long)
- (define-cproc get-ffi-type-float () get_ffi_type_float)
- (define-cproc get-ffi-type-double () get_ffi_type_double)
- (define-cproc get-ffi-type-void() get_ffi_type_void)
- (define-cproc get-ffi-type-pointer () get_ffi_type_pointer)
-
- ;(define-cproc procedure-to-pointer (procedure) procedure_to_pointer)
- )

snow/retropikzel/pffi/gerbil.scm

@@ -1,57 +0,0 @@
-(define pffi-type->native-type
-  (lambda (type)
-    (error "Not defined")))
-
-(define pffi-pointer?
-  (lambda (object)
-    (error "Not defined")))
-
-(define-syntax pffi-define
-  (syntax-rules ()
-    ((pffi-define scheme-name shared-object c-name return-type argument-types)
-     (error "Not defined"))))
-
-(define size-of-type
-  (lambda (type)
-    (error "Not defined")))
-
-(define pffi-pointer-allocate
-  (lambda (size)
-    (error "Not defined")))
-
-(define pffi-pointer-null
-  (lambda ()
-    (error "Not defined")))
-
-#;(define pffi-string->pointer
-  (lambda (string-content)
-    (error "Not defined")))
-
-#;(define pffi-pointer->string
-  (lambda (pointer)
-    pointer))
-
-(define pffi-shared-object-load
-  (lambda (header path)
-    (error "Not defined")))
-
-(define pffi-pointer-free
-  (lambda (pointer)
-    (error "Not defined")))
-
-(define pffi-pointer-null?
-  (lambda (pointer)
-    (error "Not defined")))
-
-(define pffi-pointer-set!
-  (lambda (pointer type offset value)
-    (let ((p pointer))
-      (error "Not defined"))))
-
-(define pffi-pointer-get
-  (lambda (pointer type offset)
-    (error "Not defined")))
-
-(define pffi-pointer-deref
-  (lambda (pointer)
-    (error "Not defined")))

snow/retropikzel/pffi/guile.scm

@@ -1,137 +0,0 @@
-(define pffi-type->native-type
-  (lambda (type)
-    (cond ((equal? type 'int8) int8)
-          ((equal? type 'uint8) uint8)
-          ((equal? type 'int16) int16)
-          ((equal? type 'uint16) uint16)
-          ((equal? type 'int32) int32)
-          ((equal? type 'uint32) uint32)
-          ((equal? type 'int64) int64)
-          ((equal? type 'uint64) uint64)
-          ((equal? type 'char) int8)
-          ((equal? type 'unsigned-char) uint8)
-          ((equal? type 'short) short)
-          ((equal? type 'unsigned-short) unsigned-short)
-          ((equal? type 'int) int)
-          ((equal? type 'unsigned-int) unsigned-int)
-          ((equal? type 'long) long)
-          ((equal? type 'unsigned-long) unsigned-long)
-          ((equal? type 'float) float)
-          ((equal? type 'double) double)
-          ((equal? type 'pointer) '*)
-          ((equal? type 'void) void)
-          ((equal? type 'string) '*)
-          ((equal? type 'callback) '*)
-          ((equal? type 'struct) '*)
-          (else #f))))
-
-(define pffi-pointer?
-  (lambda (object)
-    (pointer? object)))
-
-(define-syntax pffi-define
-  (syntax-rules ()
-    ((pffi-define scheme-name shared-object c-name return-type argument-types)
-     (define scheme-name
-       (foreign-library-function shared-object
-                                 (symbol->string c-name)
-                                 #:return-type (pffi-type->native-type return-type)
-                                 #:arg-types (map pffi-type->native-type argument-types))))))
-
-(define-syntax pffi-define-callback
-  (syntax-rules ()
-    ((pffi-define-callback scheme-name return-type argument-types procedure)
-     (define scheme-name
-       (procedure->pointer (pffi-type->native-type return-type)
-                           procedure
-                           (map pffi-type->native-type argument-types))))))
-
-(define size-of-type
-  (lambda (type)
-    (let ((native-type (pffi-type->native-type type)))
-      (cond ((equal? native-type void) 0)
-            (native-type (sizeof native-type))
-            (else #f)))))
-
-#;(define pffi-pointer-allocate
-  (lambda (size)
-    (bytevector->pointer (make-bytevector size 0))))
-
-(define pffi-pointer-address
-  (lambda (pointer)
-    (pointer-address pointer)))
-
-(define pffi-pointer-null
-  (lambda ()
-    (make-pointer 0)))
-
-#;(define pffi-string->pointer
-  (lambda (string-content)
-    (string->pointer string-content)))
-
-#;(define pffi-pointer->string
-  (lambda (pointer)
-    (pointer->string pointer)))
-
-(define pffi-shared-object-load
-  (lambda (path options)
-    (load-foreign-library path)))
-
-#;(define pffi-pointer-free
-  (lambda (pointer)
-    #t))
-
-(define pffi-pointer-null?
-  (lambda (pointer)
-    (and (pffi-pointer? pointer)
-         (null-pointer? pointer))))
-
-(define pffi-pointer-set!
-  (lambda (pointer type offset value)
-    (let ((p (pointer->bytevector pointer (+ offset 100))))
-      (cond ((equal? type 'int8) (bytevector-s8-set! p offset value))
-            ((equal? type 'uint8) (bytevector-u8-set! p offset value))
-            ((equal? type 'int16) (bytevector-s16-set! p offset value (native-endianness)))
-            ((equal? type 'uint16) (bytevector-u16-set! p offset value (native-endianness)))
-            ((equal? type 'int32) (bytevector-s32-set! p offset value (native-endianness)))
-            ((equal? type 'uint32) (bytevector-u32-set! p offset value (native-endianness)))
-            ((equal? type 'int64) (bytevector-s64-set! p offset value (native-endianness)))
-            ((equal? type 'uint64) (bytevector-u64-set! p offset value (native-endianness)))
-            ((equal? type 'char) (bytevector-s8-set! p offset (char->integer value)))
-            ((equal? type 'short) (bytevector-s8-set! p offset value))
-            ((equal? type 'unsigned-short) (bytevector-u8-set! p offset value))
-            ((equal? type 'int) (bytevector-sint-set! p offset value (native-endianness) (size-of-type type)))
-            ((equal? type 'unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (size-of-type type)))
-            ((equal? type 'long) (bytevector-s64-set! p offset value (native-endianness)))
-            ((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
-            ((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness)))
-            ((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness)))
-            ((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))
-            ((equal? type 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer value)) (native-endianness) (size-of-type type)))))))
-
-(define pffi-pointer-get
-  (lambda (pointer type offset)
-    (let ((p (pointer->bytevector pointer (+ offset 100))))
-      (cond ((equal? type 'int8) (bytevector-s8-ref p offset))
-            ((equal? type 'uint8) (bytevector-u8-ref p offset))
-            ((equal? type 'int16) (bytevector-s16-ref p offset (native-endianness)))
-            ((equal? type 'uint16) (bytevector-u16-ref p offset (native-endianness)))
-            ((equal? type 'int32) (bytevector-s32-ref p offset (native-endianness)))
-            ((equal? type 'uint32) (bytevector-u32-ref p offset (native-endianness)))
-            ((equal? type 'int64) (bytevector-s64-ref p offset (native-endianness)))
-            ((equal? type 'uint64) (bytevector-u64-ref p offset (native-endianness)))
-            ((equal? type 'char) (integer->char (bytevector-s8-ref p offset)))
-            ((equal? type 'short) (bytevector-s8-ref p offset))
-            ((equal? type 'unsigned-short) (bytevector-u8-ref p offset))
-            ((equal? type 'int) (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))
-            ((equal? type 'unsigned-int) (bytevector-uint-ref p offset (native-endianness) (size-of-type type)))
-            ((equal? type 'long) (bytevector-s64-ref p offset (native-endianness)))
-            ((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
-            ((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness)))
-            ((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness)))
-            ((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))
-            ((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))))))))
-
-#;(define pffi-struct-dereference
-  (lambda (struct)
-    (dereference-pointer (pffi-struct-pointer struct))))

snow/retropikzel/pffi/larceny.scm

@@ -1,141 +0,0 @@
-(require 'std-ffi)
-;(require "Standard/foreign-stdlib")
-;(require "Lib/Common/system-interface")
-
-;; FIXME
-(define size-of-type
-  (lambda (type)
-    (cond ((eq? type 'int8) 1)
-          ((eq? type 'uint8) 1)
-          ((eq? type 'int16) 2)
-          ((eq? type 'uint16) 2)
-          ((eq? type 'int32) 4)
-          ((eq? type 'uint32) 4)
-          ((eq? type 'int64) 8)
-          ((eq? type 'uint64) 8)
-          ((eq? type 'char) 1)
-          ((eq? type 'unsigned-char) 1)
-          ((eq? type 'short) 2)
-          ((eq? type 'unsigned-short) 2)
-          ((eq? type 'int) 4)
-          ((eq? type 'unsigned-int) 4)
-          ((eq? type 'long) 4)
-          ((eq? type 'unsigned-long) 4)
-          ((eq? type 'float) 4)
-          ((eq? type 'double) 8)
-          ((eq? type 'pointer) 4)
-          ((eq? type 'void) 0)
-          ((eq? type 'callback) 4)
-          (else (error "Can not get size of unknown type" type)))))
-
-(define c-malloc (foreign-procedure "malloc" '(int) 'void*))
-;(define c-malloc (stdlib/malloc rtd-void*))
-#;(define pffi-pointer-allocate
-  (lambda (size)
-    (c-malloc size)))
-
-#;(define c-free (foreign-procedure "free" '(void*) 'int))
-;(define c-malloc (stdlib/malloc rtd-void*))
-#;(define pffi-pointer-free
-  (lambda (pointer)
-    (c-free pointer)))
-
-(define pffi-pointer-null (lambda () 0))
-
-(define pffi-pointer-null?
-  (lambda (object)
-    (and (number? object)
-         (= object 0))))
-
-(define pffi-pointer?
-  (lambda (object)
-    ;(void*? object)
-    (number? object)
-    ))
-
-(define pffi-pointer-address
-  (lambda (pointer)
-    ;(void*->address pointer)
-    pointer
-    ))
-
-(define pffi-pointer->string
-  (lambda (pointer)
-    ;(char*->string pointer)
-    pointer
-    ))
-
-(define pffi-string->pointer
-  (lambda (string-content)
-    ;(string->char* string-content)
-    string-content
-    ))
-
-(define pffi-shared-object-load
-  (lambda (headers path . options)
-    (foreign-file path)))
-
-
-(define pffi-pointer-set!
-  (lambda (pointer type offset value)
-    0
-    #;(cond ((equal? type 'int8) (%poke8 (+ pointer offset) value))
-          ((equal? type 'uint8) (%poke8u (+ pointer offset) value))
-          ((equal? type 'int16) (%poke16 (+ pointer offset) value))
-          ((equal? type 'uint16) (%poke16u (+ pointer offset) value))
-          ((equal? type 'int32) (%poke32 (+ pointer offset) value))
-          ((equal? type 'uint32) (%poke32u (+ pointer offset) value))
-          ;((equal? type 'int64) (%poke64 (+ pointer offset) value))
-          ;((equal? type 'uint64) (%poke64u (+ pointer offset) value))
-          ((equal? type 'char) (%poke8 (+ pointer offset) value))
-          ((equal? type 'short) (%poke-short (+ pointer offset) value))
-          ((equal? type 'unsigned-short) (%poke-ushort (+ pointer offset) value))
-          ((equal? type 'int) (%poke-int (+ pointer offset) value))
-          ((equal? type 'unsigned-int) (%poke-uint (+ pointer offset) value))
-          ((equal? type 'long) (%poke-long (+ pointer offset) value))
-          ((equal? type 'unsigned-long) (%poke-ulong (+ pointer offset) value))
-          ;((equal? type 'float) (%poke-ulong (+ pointer offset) value))
-          ;((equal? type 'double) (pointer-set-c-double! pointer offset value))
-          ((equal? type 'void) (%poke-pointer (+ pointer offset) value))
-          ((equal? type 'pointer) (%poke-pointer (+ pointer offset) value)))))
-
-(define pffi-pointer-get
-  (lambda (pointer type offset)
-    0
-    #;(cond ((equal? type 'int8) (%peek8 (+ pointer offset)))
-          ((equal? type 'uint8) (%peek8u (+ pointer offset)))
-          ((equal? type 'int16) (%peek16 (+ pointer offset)))
-          ((equal? type 'uint16) (%peek16u (+ pointer offset)))
-          ((equal? type 'int32) (%peek32 (+ pointer offset)))
-          ((equal? type 'uint32) (%peek32u (+ pointer offset)))
-          ;((equal? type 'int64) (%peek64 (+ pointer offset)))
-          ;((equal? type 'uint64) (%peek64u (+ pointer offset)))
-          ((equal? type 'char) (%peek8 (+ pointer offset)))
-          ((equal? type 'short) (%peek-short (+ pointer offset)))
-          ((equal? type 'unsigned-short) (%peek-ushort (+ pointer offset)))
-          ((equal? type 'int) (%peek-int (+ pointer offset)))
-          ((equal? type 'unsigned-int) (%peek-uint (+ pointer offset)))
-          ((equal? type 'long) (%peek-long (+ pointer offset)))
-          ((equal? type 'unsigned-long) (%peek-ulong (+ pointer offset)))
-          ;((equal? type 'float) (%peek-ulong (+ pointer offset)))
-          ;((equal? type 'double) (pointer-set-c-double! pointer offset))
-          ((equal? type 'void) (%peek-pointer (+ pointer offset)))
-          ((equal? type 'pointer) (%peek-pointer (+ pointer offset))))))
-
-(define-syntax pffi-define
-  (syntax-rules ()
-    ((pffi-define scheme-name shared-object c-name return-type argument-types)
-     (define scheme-name
-       0
-
-       #;(make-c-function shared-object
-                        (symbol->string c-name)
-                        return-type
-                        argument-types)))))
-
-(define-syntax pffi-define-callback
-  (syntax-rules ()
-    ((pffi-define scheme-name return-type argument-types procedure)
-     (define scheme-name
-       0
-       #;(make-c-callback return-type argument-types procedure)))))

snow/retropikzel/pffi/racket.scm

@@ -1,120 +0,0 @@
-(define pffi-type->native-type
-  (lambda (type)
-    (cond ((equal? type 'int8) _int8)
-          ((equal? type 'uint8) _uint8)
-          ((equal? type 'int16) _int16)
-          ((equal? type 'uint16) _uint16)
-          ((equal? type 'int32) _int32)
-          ((equal? type 'uint32) _uint32)
-          ((equal? type 'int64) _int64)
-          ((equal? type 'uint64) _uint64)
-          ((equal? type 'char) _int8)
-          ((equal? type 'unsigned-char) _uint8)
-          ((equal? type 'short) _short)
-          ((equal? type 'unsigned-short) _ushort)
-          ((equal? type 'int) _int)
-          ((equal? type 'unsigned-int) _uint)
-          ((equal? type 'long) _long)
-          ((equal? type 'unsigned-long) _ulong)
-          ((equal? type 'float) _float)
-          ((equal? type 'double) _double)
-          ((equal? type 'pointer) _pointer)
-          ((equal? type 'void) _void)
-          ((equal? type 'callback) _pointer)
-          ((equal? type 'string) _pointer)
-          ((equal? type 'struct) _pointer)
-          (else #f))))
-
-(define pffi-pointer?
-  (lambda (object)
-    (cpointer? object)))
-
-(define-syntax pffi-define
-  (syntax-rules ()
-    ((pffi-define scheme-name shared-object c-name return-type argument-types)
-     (define scheme-name
-       (get-ffi-obj c-name
-                    shared-object
-                    (_cprocedure (mlist->list (map pffi-type->native-type argument-types))
-                                 (pffi-type->native-type return-type)))))))
-
-(define-syntax pffi-define-callback
-  (syntax-rules ()
-    ((pffi-define-callback scheme-name return-type argument-types procedure)
-     (define scheme-name (function-ptr procedure
-                                       (_cprocedure
-                                         (mlist->list (map pffi-type->native-type argument-types))
-                                         (pffi-type->native-type return-type)))))))
-
-(define size-of-type
-  (lambda (type)
-    (let ((native-type (pffi-type->native-type type)))
-      (if native-type
-        (ctype-sizeof native-type)
-        #f))))
-
-#;(define pffi-pointer-allocate
-  (lambda (size)
-    (malloc 'raw size)))
-
-(define pffi-pointer-address
-  (lambda (pointer)
-    pointer))
-
-(define pffi-pointer-null
-  (lambda ()
-    #f )) ; #f is the null pointer on racket
-
-#;(define pffi-string->pointer
-  (lambda (string-content)
-    (let* ((size (string-length string-content))
-           (pointer (pffi-pointer-allocate (+ size 1))))
-      (memmove pointer (cast (string-append string-content "") _string _pointer) (+ size 1))
-      pointer)))
-
-#;(define pffi-pointer->string
-  (lambda (pointer)
-    (when (pffi-pointer-null? pointer)
-      (error "Can not make string from null pointer" pointer))
-    (string-copy (cast pointer _pointer _string))))
-
-(define pffi-shared-object-load
-  (lambda (path options)
-    (if (and (not (null? options))
-             (assoc 'additional-versions options))
-      (ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions
-                                                      options))
-                                         (list #f))))
-      (ffi-lib path))))
-
-#;(define pffi-pointer-free
-  (lambda (pointer)
-    (free pointer)))
-
-(define pffi-pointer-null?
-  (lambda (pointer)
-    (not pointer))) ; #f is the null pointer on racket
-
-(define pffi-pointer-set!
-  (lambda (pointer type offset value)
-    (ptr-set! pointer
-              (pffi-type->native-type type)
-              'abs
-              offset
-              (if (equal? type 'char)
-                (char->integer value)
-                value))))
-
-(define pffi-pointer-get
-  (lambda (pointer type offset)
-    (let ((r (ptr-ref pointer
-                      (pffi-type->native-type type)
-                      'abs
-                      offset)))
-      (if (equal? type 'char)
-        (integer->char r)
-        r))))
-
-#;(define pffi-struct-dereference
-  (lambda (struct)
-    (pffi-struct-pointer struct)))

snow/retropikzel/pffi/shared/pointer.scm

@@ -1,20 +0,0 @@
-(cond-expand
-  (windows (pffi-define-library pffi-libc-stdlib
-                                '("stdlib.h")
-                                "ucrtbase"
-                                '((additional-versions ("0" "6")))))
-  (else (pffi-define-library pffi-libc-stdlib
-                             '("stdlib.h")
-                             "c"
-                             '((additional-versions ("0" "6"))))))
-
-(cond-expand
-  (chibi #t) ; FIXME
-  (else (pffi-define pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int))))
-
-;(pffi-define pffi-pointer-allocate-aligned pffi-libc-stdlib 'aligned_alloc 'pointer '(int int))
-(pffi-define pffi-pointer-allocate-calloc pffi-libc-stdlib 'calloc 'pointer '(int int))
-
-(cond-expand
-  (chibi #t) ; FIXME
-  (else (pffi-define pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer))))

snow/retropikzel/pffi/shared/union.scm

@@ -1,8 +0,0 @@
-
-(define-record-type <pffi-union>
-  (union-make c-type size pointer members)
-  pffi-union?
-  (c-type pffi-union-c-type)
-  (size pffi-union-size)
-  (pointer pffi-union-pointer)
-  (members pffi-union-members))

snow/retropikzel/pffi/stklos.scm

@@ -1,169 +0,0 @@
-(define pffi-type->native-type
-  (lambda (type)
-    (cond ((equal? type 'int8) :int)
-          ((equal? type 'uint8) :uint)
-          ((equal? type 'int16) :int)
-          ((equal? type 'uint16) :uint)
-          ((equal? type 'int32) :int)
-          ((equal? type 'uint32) :uint)
-          ((equal? type 'int64) :int)
-          ((equal? type 'uint64) :uint)
-          ((equal? type 'char) :char)
-          ((equal? type 'unsigned-char) :uchar)
-          ((equal? type 'short) :short)
-          ((equal? type 'unsigned-short) :ushort)
-          ((equal? type 'int) :int)
-          ((equal? type 'unsigned-int) :uint)
-          ((equal? type 'long) :long)
-          ((equal? type 'unsigned-long) :ulong)
-          ((equal? type 'float) :float)
-          ((equal? type 'double) :double)
-          ((equal? type 'pointer) :pointer)
-          ((equal? type 'string) :string)
-          ((equal? type 'void) :void)
-          ((equal? type 'struct) :void)
-          (else (error "pffi-type->native-type -- No such pffi type" type)))))
-
-(define pffi-pointer?
-  (lambda (object)
-    (display "HERE: ")
-    (write object)
-    (newline)
-    (write (cpointer? object))
-    (newline)
-    (cpointer? object)))
-
-(define-syntax pffi-define
-  (syntax-rules ()
-    ((pffi-define scheme-name shared-object c-name return-type argument-types)
-     (begin
-       (define pffi-type->native-type
-  (lambda (type)
-    (cond ((equal? type 'int8) :int)
-          ((equal? type 'uint8) :uint)
-          ((equal? type 'int16) :int)
-          ((equal? type 'uint16) :uint)
-          ((equal? type 'int32) :int)
-          ((equal? type 'uint32) :uint)
-          ((equal? type 'int64) :int)
-          ((equal? type 'uint64) :uint)
-          ((equal? type 'char) :char)
-          ((equal? type 'unsigned-char) :uchar)
-          ((equal? type 'short) :short)
-          ((equal? type 'unsigned-short) :ushort)
-          ((equal? type 'int) :int)
-          ((equal? type 'unsigned-int) :uint)
-          ((equal? type 'long) :long)
-          ((equal? type 'unsigned-long) :ulong)
-          ((equal? type 'float) :float)
-          ((equal? type 'double) :double)
-          ((equal? type 'pointer) :pointer)
-          ((equal? type 'string) :string)
-          ((equal? type 'void) :void)
-          ((equal? type 'struct) :void)
-          (else (error "pffi-type->native-type -- No such pffi type" type)))))
-     (define scheme-name
-       (make-external-function
-         (symbol->string c-name)
-         (map pffi-type->native-type argument-types)
-         (pffi-type->native-type return-type)
-         shared-object))))))
-
-(define pffi-define-callback
-  (lambda ()
-    (error "Not implemented")))
-
-; FIXME
-(define size-of-type
-  (lambda (type)
-    (cond
-      ((equal? type 'int8) 1)
-      ((equal? type 'uint8) 1)
-      ((equal? type 'int16) 2)
-      ((equal? type 'uint16) 2)
-      ((equal? type 'int32) 4)
-      ((equal? type 'uint32) 4)
-      ((equal? type 'int64) 8)
-      ((equal? type 'uint64) 8)
-      ((equal? type 'char) 1)
-      ((equal? type 'unsigned-char) 1)
-      ((equal? type 'short) 2)
-      ((equal? type 'unsigned-short) 2)
-      ((equal? type 'int) 4)
-      ((equal? type 'unsigned-int) 4)
-      ((equal? type 'long) 8)
-      ((equal? type 'unsigned-long) 8)
-      ((equal? type 'float) 4)
-      ((equal? type 'double) 8)
-      ((equal? type 'pointer) 8)
-
-      )))
-
-#;(define pffi-pointer-allocate
-  (lambda (size)
-    (allocate-bytes size)))
-
-;; FIXME
-(define pffi-pointer-address
-  (lambda (pointer)
-    0))
-
-;; FIXME
-(define pffi-pointer-null
-  (lambda ()
-    (let ((p (allocate-bytes 0)))
-      (free-bytes p)
-      p)))
-
-#;(define pffi-pointer-free
-  (lambda (pointer)
-    (free-bytes pointer)))
-
-(define pffi-pointer-null?
-  (lambda (pointer)
-    (and (cpointer? pointer)
-         (cpointer-null? pointer))))
-
-(define pffi-pointer-set!
-  (lambda (pointer type offset value)
-    (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
-          ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
-          ((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
-          ((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
-          ((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
-          ((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
-          ((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
-          ((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
-          ((equal? type 'char) (pointer-set-c-char! pointer offset value))
-          ((equal? type 'short) (pointer-set-c-short! pointer offset value))
-          ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
-          ((equal? type 'int) (pointer-set-c-int! pointer offset value))
-          ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
-          ((equal? type 'long) (pointer-set-c-long! pointer offset value))
-          ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
-          ((equal? type 'float) (pointer-set-c-float! pointer offset value))
-          ((equal? type 'double) (pointer-set-c-double! pointer offset value))
-          ((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
-          ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
-
-(define pffi-pointer-get
-  (lambda (pointer type offset)
-    (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
-          ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
-          ((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
-          ((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
-          ((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
-          ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
-          ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
-          ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
-          ((equal? type 'char) (pointer-ref-c-char pointer offset))
-          ((equal? type 'short) (pointer-ref-c-short pointer offset))
-          ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
-          ((equal? type 'int) (pointer-ref-c-int pointer offset))
-          ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
-          ((equal? type 'long) (pointer-ref-c-long pointer offset))
-          ((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
-          ((equal? type 'float) (pointer-ref-c-float pointer offset))
-          ((equal? type 'double) (pointer-ref-c-double pointer offset))
-          ((equal? type 'void) (pointer-ref-c-pointer pointer offset))
-          ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))

snow/retropikzel/pffi/ypsilon.scm

@@ -1,158 +0,0 @@
-(define size-of-type
-  (lambda (type)
-    (cond ((eq? type 'int8) (c-sizeof int8_t))
-          ((eq? type 'uint8) (c-sizeof uint8_t))
-          ((eq? type 'int16) (c-sizeof int16_t))
-          ((eq? type 'uint16) (c-sizeof uint16_t))
-          ((eq? type 'int32) (c-sizeof int32_t))
-          ((eq? type 'uint32) (c-sizeof uint32_t))
-          ((eq? type 'int64) (c-sizeof int64_t))
-          ((eq? type 'uint64) (c-sizeof uint64_t))
-          ((eq? type 'char) (c-sizeof char))
-          ((eq? type 'unsigned-char) (c-sizeof char))
-          ((eq? type 'short) (c-sizeof short))
-          ((eq? type 'unsigned-short) (c-sizeof unsigned-short))
-          ((eq? type 'int) (c-sizeof int))
-          ((eq? type 'unsigned-int) (c-sizeof unsigned-int))
-          ((eq? type 'long) (c-sizeof long))
-          ((eq? type 'unsigned-long) (c-sizeof unsigned-long))
-          ((eq? type 'float) (c-sizeof float))
-          ((eq? type 'double) (c-sizeof double))
-          ((eq? type 'pointer) (c-sizeof void*))
-          ((eq? type 'string) (c-sizeof void*))
-          ((eq? type 'struct) (c-sizeof void*))
-          ((eq? type 'callback) (c-sizeof void*))
-          ((eq? type 'void) 0)
-          (else #f))))
-
-;(define c-malloc (c-function void* malloc (size_t)))
-;(define c-free (c-function int free (void*)))
-
-#;(define pffi-pointer-allocate
-  (lambda (size)
-    (c-malloc size)))
-
-(define pffi-pointer-address
-  (lambda (pointer)
-    pointer))
-
-(define pffi-pointer?
-  (lambda (object)
-    (number? object)))
-
-#;(define pffi-pointer-free
-  (lambda (pointer)
-    (c-free pointer)))
-
-(define pffi-pointer-null
-  (lambda ()
-    0))
-
-(define pffi-pointer-null?
-  (lambda (pointer)
-    (and (pffi-pointer? pointer)
-         (= (pffi-pointer-address pointer) 0))))
-
-#;(define pffi-pointer->string
-  (lambda (pointer)
-    (c-string-ref pointer)))
-
-;(define c-memset(c-function int memset (void* int int)))
-;(define c-snprintf (c-function int snprintf (void* size_t void*) (long double)))
-#;(define pffi-string->pointer
-  (lambda (string-content)
-    (let* ((c-string (make-c-string string-content))
-          (c-string-length (bytevector-length c-string))
-          (pointer (c-malloc c-string-length)))
-      (c-memset pointer 0 c-string-length)
-      (c-snprintf pointer c-string-length (make-c-string "%s") c-string)
-      pointer)))
-
-(define pffi-pointer-set!
-  (lambda (pointer type offset value)
-    (let ((bv (make-bytevector-mapping (+ pointer offset) (pffi-size-of type))))
-      (cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value))
-            ((equal? type 'uint8) (bytevector-c-int8-set! bv 0 value))
-            ((equal? type 'int16) (bytevector-c-int16-set! bv 0 value))
-            ((equal? type 'uint16) (bytevector-c-int16-set! bv 0 value))
-            ((equal? type 'int32) (bytevector-c-int32-set! bv 0 value))
-            ((equal? type 'uint32) (bytevector-c-int32-set! bv 0 value))
-            ((equal? type 'int64) (bytevector-c-int64-set! bv 0 value))
-            ((equal? type 'uint64) (bytevector-c-int64-set! bv 0 value))
-            ((equal? type 'char) (bytevector-c-int8-set! bv 0 (char->integer value)))
-            ((equal? type 'short) (bytevector-c-short-set! bv 0 value))
-            ((equal? type 'unsigned-short) (bytevector-c-short-set! bv 0 value))
-            ((equal? type 'int) (bytevector-c-int-set! bv 0 value))
-            ((equal? type 'unsigned-int) (bytevector-c-int-set! bv 0 value))
-            ((equal? type 'long) (bytevector-c-long-set! bv 0 value))
-            ((equal? type 'unsigned-long) (bytevector-c-long-set! bv 0 value))
-            ((equal? type 'float) (bytevector-c-float-set! bv 0 value))
-            ((equal? type 'double) (bytevector-c-double-set! bv 0 value))
-            ((equal? type 'void) (bytevector-c-void*-set! bv 0 value))
-            ((equal? type 'pointer) (bytevector-c-void*-set! bv 0 value))))))
-
-(define pffi-pointer-get
-  (lambda (pointer type offset)
-    (let ((bv (make-bytevector-mapping (+ pointer offset) (pffi-size-of type))))
-      (cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0))
-            ((equal? type 'uint8) (bytevector-c-uint8-ref bv 0))
-            ((equal? type 'int16) (bytevector-c-int16-ref bv 0))
-            ((equal? type 'uint16) (bytevector-c-uint16-ref bv 0))
-            ((equal? type 'int32) (bytevector-c-int32-ref bv 0))
-            ((equal? type 'uint32) (bytevector-c-uint32-ref bv 0))
-            ((equal? type 'int64) (bytevector-c-int64-ref bv 0))
-            ((equal? type 'uint64) (bytevector-c-uint64-ref bv 0))
-            ((equal? type 'char) (integer->char (bytevector-c-uint8-ref bv 0)))
-            ((equal? type 'short) (bytevector-c-short-ref bv 0))
-            ((equal? type 'unsigned-short) (bytevector-c-unsigned-short-ref bv 0))
-            ((equal? type 'int) (bytevector-c-int-ref bv 0))
-            ((equal? type 'unsigned-int) (bytevector-c-unsigned-int-ref bv 0))
-            ((equal? type 'long) (bytevector-c-long-ref bv 0))
-            ((equal? type 'unsigned-long) (bytevector-c-unsigned-long-ref bv 0))
-            ((equal? type 'float) (bytevector-c-float-ref bv 0))
-            ((equal? type 'double) (bytevector-c-double-ref bv 0))
-            ((equal? type 'void) (bytevector-c-void*-ref bv 0))
-            ((equal? type 'pointer) (bytevector-c-void*-ref bv 0))))))
-
-(define pffi-shared-object-load
-  (lambda (headers path options)
-    (load-shared-object path)))
-
-(define-macro (pffi-type->native-type type)
-    `(cond ((equal? ,type int8) int8_t)
-          ((equal? ,type uint8) uint8_t)
-          ((equal? ,type int16) int16_t)
-          ((equal? ,type uint16) uint16_t)
-          ((equal? ,type int32) int32_t)
-          ((equal? ,type uint32) uint32_t)
-          ((equal? ,type int64) int64_t)
-          ((equal? ,type uint64) uint64_t)
-          ((equal? ,type char) char)
-          ((equal? ,type unsigned-char) char)
-          ((equal? ,type short) short)
-          ((equal? ,type unsigned-short) unsigned-short)
-          ((equal? ,type int) int)
-          ((equal? ,type unsigned-int) unsigned-int)
-          ((equal? ,type long) long)
-          ((equal? ,type unsigned-long) unsigned-long)
-          ((equal? ,type float) float)
-          ((equal? ,type double) double)
-          ((equal? ,type pointer) void*)
-          ((equal? ,type string) void*)
-          ((equal? ,type void) void)
-          ((equal? ,type callback) void*)
-          (else (error "pffi-type->native-type -- No such pffi type" ,type))))
-
-(define-macro
-  (pffi-define scheme-name shared-object c-name return-type argument-types)
-    `(define ,scheme-name
-       (c-function ,(pffi-type->native-type return-type)
-                   ,(cadr c-name)
-                   ,(map pffi-type->native-type (cdr argument-types)))))
-
-(define-macro
-  (pffi-define-callback scheme-name return-type argument-types procedure)
-    `(define ,scheme-name
-       (c-callback ,(pffi-type->native-type return-type)
-                   ,(map pffi-type->native-type (cdr argument-types))
-                   ,procedure)))

snow/srfi/170.scm

@@ -1,112 +1,25 @@
-(pffi-init)
-
-(cond-expand
-  (chicken (import (chicken foreign)))
-  (else #t))
-
 (define slash (cond-expand (windows "\\") (else "/")))
 
 (cond-expand
   (windows
-    (pffi-define-library libc '("stdio.h") "ucrtbase" '()))
+    (define-c-library libc
+                         '("stdlib.h" "stdio.h" "error.h")
+                         "ucrtbase"
+                         '()))
   (else
-    (pffi-define-library libc
-                         '("stdio.h" "error.h")
+    (define-c-library libc
+                         '("stdlib.h" "stdio.h" "dirent.h" "error.h")
                          "c"
                          '((additional-versions ("6"))))))
 
-(pffi-define-library libuv
-                     '("uv.h")
-                     "uv"
-                     '((additional-versions ("1" "1.0.0"))))
-
-(cond-expand
-  (windows (pffi-define-library libkernel '("windows.h") "kernel32" '()))
-  (else #f))
-
-;(pffi-define c-puts libc 'puts 'int '(string))
-(pffi-define uv-default-loop libuv 'uv_default_loop 'pointer '())
-(pffi-define uv-translate-sys-error libuv 'uv_translate_sys_error 'int '(int))
-(pffi-define uv-strerror libuv 'uv_strerror 'pointer '(int))
-(pffi-define uv-fs-stat libuv 'uv_fs_stat 'int '(pointer pointer pointer pointer))
-(pffi-define uv-fs-mkdir libuv 'uv_fs_mkdir 'int '(pointer pointer pointer int pointer))
-(pffi-define uv-fs-rmdir libuv 'uv_fs_rmdir 'int '(pointer pointer pointer pointer))
-(pffi-define uv-fs-opendir libuv 'uv_fs_opendir 'int '(pointer pointer pointer pointer))
-(pffi-define uv-fs-closedir libuv 'uv_fs_closedir 'int '(pointer pointer pointer pointer))
-(pffi-define uv-fs-scandir libuv 'uv_fs_scandir 'int '(pointer pointer pointer int pointer))
-(pffi-define uv-fs-scandir-next libuv 'uv_fs_scandir_next 'int '(pointer pointer))
-(pffi-define uv-fs-get-ptr libuv 'uv_fs_get_ptr 'pointer '(pointer))
-(pffi-define uv-fs-realpath libuv 'uv_fs_realpath 'int '(pointer pointer pointer pointer))
-(pffi-define uv-fs-cleanup libuv 'uv_fs_req_cleanup 'void '(pointer))
-;(pffi-define uv-fs-scandir libuv 'uv_fs_scandir 'int '(pointer pointer pointer int pointer))
-;(pffi-define c-printf libc 'printf 'int '(string))
-;(pffi-define c-cos libc 'cos 'double '(double))
-
-(define UV-FS 6)
-(pffi-define-struct uv-fs-t-make
-                    'uv_fs_t
-                    '((pointer . data)
-                      (int . type)
-                      (pointer . reserved1)
-                      (pointer . reserved2)
-                      (pointer . reserved3)
-                      (pointer . reserved4)
-                      (pointer . reserved5)
-                      (pointer . reserved6)
-                      (pointer . fs_type)
-                      (pointer . loop)
-                      (pointer . cb)
-                      (int . result)
-                      (pointer . ptr)
-                      (pointer . path)
-                      (int . statbuf)
-                      (pointer . new_path)
-                      (int . file)
-                      (int . flags)
-                      (int . mode)
-                      (pointer . bufs)
-                      (int . off)
-                      (int . uid)
-                      (int . gid)
-                      (double . atime)
-                      (double . mtime)
-                      (pointer . work_req)
-                      (pointer . bufsml1)
-                      (pointer . bufsml2)
-                      (pointer . bufsml3)
-                      (pointer . bufsml4)))
-
-(define req-type (uv-fs-t-make))
-
-;(pffi-struct-set! struct 'fs_type UV-FS)
-#;(define uv-fs-t-make
-  (lambda ()
-    (let ((struct (uv-fs-t)))
-      (pffi-struct-set! struct 'fs_type UV-FS)
-      struct
-    #;(let ((p (pffi-pointer-allocate (+ (pffi-size-of 'pointer)     ; .loop
-                                       (pffi-size-of 'int)         ; .uv_fs_type
-                                       (pffi-size-of 'pointer)     ; .path
-                                       (pffi-size-of 'int)         ; .result
-                                       (pffi-size-of 'pointer)     ; .statbuf
-                                       (pffi-size-of 'pointer)     ; .ptr
-                                       512 ; Temporary fix
-                                       ))))
-      (pffi-pointer-set! p 'int (pffi-size-of 'pointer) UV-FS)
-      p))))
-
-(pffi-define-struct uv-dirent-make
-                    'uv_dirent_t
-                    '((pointer . name) (int . uv_dirent_type)))
-
-(define handle-errors
-  (lambda (return-code . irritants)
-    (when (< return-code 0)
-      (if (null? irritants)
-        (raise-continuable (pffi-pointer->string (uv-strerror (uv-translate-sys-error return-code))))
-        (raise-continuable (pffi-pointer->string (uv-strerror (uv-translate-sys-error return-code))))))
-    return-code))
-
+(define-c-procedure c-perror libc 'perror 'void '(pointer))
+(define-c-procedure c-mkdir libc 'mkdir 'int '(pointer int))
+(define-c-procedure c-rmdir libc 'rmdir 'int '(pointer))
+(define-c-procedure c-stat libc 'stat 'int '(pointer pointer))
+(define-c-procedure c-opendir libc 'opendir 'pointer '(pointer))
+(define-c-procedure c-readdir libc 'readdir 'pointer '(pointer))
+(define-c-procedure c-closedir libc 'closedir 'int '(pointer))
+(define-c-procedure c-realpath libc 'realpath 'pointer '(pointer pointer))
 
 (define-record-type file-info-record
   (file-info-record-make device inode mode nlinks uid gid rdev size blksize blocks atime mtime ctime fname/port follow?)
@@ -130,105 +43,113 @@
 ; FIX make the "follow?" argument work
 (define file-info
   (lambda (fname/port follow?)
-    (handle-errors (uv-fs-stat (uv-default-loop)
-                               (pffi-struct-pointer req-type)
-                               (pffi-string->pointer fname/port)
-                               (pffi-pointer-null)))
-    (let* ((stat-pointer (uv-fs-get-ptr (pffi-struct-pointer req-type)))
-           (result (file-info-record-make (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 0))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 1))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 2))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 3))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 4))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 5))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 6))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 7))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 8))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 9))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 10))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 11))
-                                          (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 12))
+    (when (port? fname/port)
+      (error "file-info implementation does not support ports as arguments"))
+    (let* ((fname-pointer (string->c-utf8 fname/port))
+           (stat-pointer (make-c-bytevector 256))
+           (result (c-stat fname-pointer stat-pointer))
+           (error-message "file-info error")
+           (error-pointer (string->c-utf8 error-message)))
+      (when (< result 0)
+        (c-perror error-pointer)
+        (c-free fname-pointer)
+        (c-free stat-pointer)
+        (c-free error-pointer)
+        (error error-message fname/port))
+      (file-info-record-make (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 0) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 1) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 2) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 3) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 4) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 5) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 6) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 7) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 8) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 9) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 10) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 11) (native-endianness))
+                             (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 12) (native-endianness))
                              fname/port
-                                          follow?)))
-      (uv-fs-cleanup (pffi-struct-pointer req-type))
-      result)))
-
-(define file-info-directory?
-  (lambda (file-info)
-    ; Try to open the file-info path as directory, if it fails say it's not a directory
-    (let* ((file-path (file-info:fname/port file-info))
-           (uv-result (uv-fs-opendir (uv-default-loop)
-                                     (pffi-struct-pointer req-type)
-                                     (pffi-string->pointer file-path)
-                                     (pffi-pointer-null))))
-      (cond ((not (file-exists? file-path))
-             (uv-fs-cleanup (pffi-struct-pointer req-type))
-             #f)
-            ((not (= uv-result -20))
-             (uv-fs-cleanup (pffi-struct-pointer req-type))
-             #t)
-            ; If it is a dir then it's open and needs to be closed
-            (else (uv-fs-closedir (uv-default-loop)
-                                  (pffi-struct-pointer req-type)
-                                  (uv-fs-get-ptr (pffi-struct-pointer req-type))
-                                  (pffi-pointer-null))
-                  (uv-fs-cleanup (pffi-struct-pointer req-type))
-                  #f)))))
+                             follow?))))
 
 (define create-directory
   (lambda (fname . permission-bits)
-    (let ((mode (if (null? permission-bits) #o775 (car permission-bits))))
-      (handle-errors (uv-fs-mkdir (uv-default-loop)
-                                  (pffi-struct-pointer req-type)
-                                  (pffi-string->pointer fname)
-                                  mode
-                                  (pffi-pointer-null))
-                     (uv-fs-cleanup (pffi-struct-pointer req-type))
-                     fname))))
+    (let* ((fname-pointer (string->c-utf8 fname))
+           (mode (if (null? permission-bits)
+                   #o775
+                   (string->number (string-append "#o"
+                                                  (number->string (car permission-bits))))))
+           (result (c-mkdir fname-pointer mode))
+           (error-message "create-directory error")
+           (error-pointer (string->c-utf8 error-message)))
+      (c-free fname-pointer)
+      (when (< result 0)
+        (c-perror error-pointer)
+        (c-free error-pointer)
+        (error error-message)))))
 
 (define delete-directory
   (lambda (fname)
-    (handle-errors
-      (uv-fs-rmdir (uv-default-loop)
-                   (pffi-struct-pointer req-type)
-                   (pffi-string->pointer fname)
-                   (pffi-pointer-null))
-      (uv-fs-cleanup (pffi-struct-pointer req-type))
-      fname)))
+    (let* ((fname-pointer (string->c-utf8 fname))
+           (result (c-rmdir fname-pointer))
+           (error-message "delete-directory error")
+           (error-pointer (string->c-utf8 error-message)))
+      (c-free fname-pointer)
+      (when (< result 0)
+        (c-perror error-pointer)
+        (c-free error-pointer)
+        (error error-message)))))
+
+(define pointer-string-read
+  (lambda (pointer offset)
+    (letrec* ((looper (lambda (c index result)
+                        (if (char=? c #\null)
+                          (list->string (reverse result))
+                          (looper (c-bytevector-char-ref pointer
+                                                         (+ offset index))
+                                  (+ index 1)
+                                  (cons c result))))))
+      (looper (c-bytevector-char-ref pointer offset) 1 (list)))))
 
 (define directory-files
-  (lambda (dir . args)
-    (letrec* ((dotfiles? (if (null? args) #f (car args)))
-              (result (handle-errors (uv-fs-scandir (uv-default-loop)
-                                                    (pffi-struct-pointer req-type)
-                                                    (pffi-string->pointer dir)
-                                                    0
-                                                    (pffi-pointer-null))
-                                     dir))
-              (uv-dirent-t (uv-dirent-make))
-              (files (list))
-              (looper
-                (lambda ()
-                  (let ((next-file (uv-fs-scandir-next (pffi-struct-pointer req-type)
-                                                       (pffi-struct-pointer uv-dirent-t))))
-                    (when (= next-file 0) ; End of file
-                      (let ((file-name (pffi-pointer->string (pffi-struct-get uv-dirent-t 'name))))
-                        (if (and (> (string-length file-name) 0)
-                                 (char=? (string-ref file-name 0) #\.))
-                          (if dotfiles? (set! files (append files (list file-name))))
-                          (set! files (append files (list file-name))))
-                        (looper)))))))
-      (looper)
-      (uv-fs-cleanup (pffi-struct-pointer req-type))
-      files)))
+  (lambda (dir . dotfiles?)
+    (letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?)))
+              (path-pointer (string->c-utf8 dir))
+              (directory-pointer (c-opendir path-pointer))
+              (error-message "directory-files error")
+              (error-pointer (string->c-utf8 error-message))
+              (name-offset 19) ; struct dirent d_name offset on linux
+              (looper (lambda (directory-entity files)
+                        (if (c-null? directory-entity)
+                          files
+                          (let ((name (pointer-string-read directory-entity
+                                                           name-offset)))
+                            (looper (c-readdir directory-pointer)
+                                    (if (or (string=? name ".")
+                                            (string=? name ".."))
+                                      (if include-dotfiles?
+                                        (cons name files)
+                                        files)
+                                      (cons name files))))))))
+      (when (c-null? directory-pointer)
+        (c-perror error-pointer)
+        ;(c-free error-pointer)
+        ;(c-free directory)
+        ;(c-free path-pointer)
+        (error error-message))
+      (let ((files (looper (c-readdir directory-pointer) (list))))
+        ;(c-free error-pointer)
+        ;(c-free directory-pointer)
+        ;(c-free path-pointer)
+        (c-closedir directory-pointer)
+        files))))
 
 (define real-path
   (lambda (path)
-    (let* ((result (uv-fs-realpath (uv-default-loop)
-                                   (pffi-struct-pointer req-type)
-                                   (pffi-string->pointer path)
-                                   (pffi-pointer-null)))
-           (realpath (pffi-pointer->string (uv-fs-get-ptr (pffi-struct-pointer req-type)))))
-      (uv-fs-cleanup (pffi-struct-pointer req-type))
-      realpath)))
+    (let* ((path-pointer (string->c-utf8 path))
+           (real-path-pointer (c-realpath path-pointer (make-c-null)))
+           (real-path (c-utf8->string real-path-pointer)))
+      (c-free path-pointer)
+      (c-free real-path-pointer)
+      real-path)))
 

snow/srfi/170.sld

@@ -3,9 +3,8 @@
   (import (scheme base)
           (scheme write)
           (scheme file)
-          (retropikzel pffi)
-          (scheme process-context)
-          )
+          (foreign c)
+          (scheme process-context))
   (export ;posix-error?
           ;posix-error-name
           ;posix-error-message
@@ -36,7 +35,7 @@
           file-info:atime
           file-info:mtime
           file-info:ctime
-          file-info-directory?
+          ;file-info-directory?
           ;file-info-fifo?
           ;file-info-symlink?
           ;file-info-regular?