Cleaning up the repository structure. Improving the Gauche implementation

Makefile

@@ -3,19 +3,20 @@ CC=gcc
 DOCKER=docker run -it -v ${PWD}:/workdir
 DOCKER_INIT=cd /workdir && make clean &&
 
-all: chibi
+all: chibi gauche libtest.so libtest.o libtest.a
 
 chibi:
-	chibi-ffi src/pffi-chibi.stub
+	chibi-ffi src/chibi/pffi.stub
-	${CC} -Werror -g3 -o retropikzel/pffi/pffi-chibi.so \
+	${CC} -g3 -o retropikzel/pffi/chibi-pffi.so \
-		src/pffi-chibi.c \
+		src/chibi/pffi.c \
 		-fPIC \
 		-lffi \
 		-shared
 
 gauche:
-	CFLAGS="-I./include" gauche-package compile \
+	CFLAGS="-I. -Werror -Wall -g3 -lffi" \
-		--verbose --srcdir=src retropikzel-pffi-gauche pffi-gauche.c gauchelib.scm
+		gauche-package compile \
+		--verbose --srcdir=src/gauche retropikzel-pffi-gauche pffi.c gauchelib.scm
 
 jenkinsfile:
 	gosh -r7 -I ./snow build.scm
@@ -58,7 +59,7 @@ clean:
 	@rm -rf test/pffi-define
 	@rm -rf test/*gambit*
 	find . -name "*.link" -delete
-	#find . -name "*.c" -not -name "libtest.c" -and -not -name "pffi-gauche.c" -delete
+	#find . -name "*.c" -not -name "libtest.c" -and -not -name "pffi.c" -delete
 	find . -name "*.o" -delete
 	find . -name "*.o[1-9]" -delete
 	find . -name "*.so" -delete

include/pffi-gauche.h

@@ -1,36 +0,0 @@
-/*
- * spigot.h - calculate pi and e by spigot algorithm
- *
- *  Written by Shiro Kawai (shiro@acm.org)
- *  I put this program in public domain.  Use it as you like.
- */
-
-extern ScmObj size_of_int8();
-extern ScmObj size_of_uint8();
-extern ScmObj size_of_int16();
-extern ScmObj size_of_uint16();
-extern ScmObj size_of_int32();
-extern ScmObj size_of_uint32();
-extern ScmObj size_of_int64();
-extern ScmObj size_of_uint64();
-extern ScmObj size_of_char();
-extern ScmObj size_of_unsigned_char();
-extern ScmObj size_of_short();
-extern ScmObj size_of_unsigned_short();
-extern ScmObj size_of_int();
-extern ScmObj size_of_unsigned_int();
-extern ScmObj size_of_long();
-extern ScmObj size_of_unsigned_long();
-extern ScmObj size_of_float();
-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 is_pointer(ScmObj pointer);
-extern ScmObj pointer_free(ScmObj pointer);
-extern ScmObj Spigot_calculate_e(int digits);
-extern void Scm_Init_gauchelib(void);

retropikzel/pffi.sld

@@ -33,9 +33,8 @@
               pffi-define
               pffi-define-callback
               scheme-procedure-to-pointer
-
               )
-      (include-shared "pffi/pffi-chibi"))
+      (include-shared "pffi/chibi-pffi"))
     (chicken-5
       (import (scheme base)
               (scheme write)
@@ -183,16 +182,16 @@
               pffi-pointer-allocate
               pffi-pointer?
               pffi-pointer-free
-              ;pffi-pointer-set!
+              pffi-pointer-set!
-              ;pffi-pointer-get
+              pffi-pointer-get
-              ;pffi-string->pointer
+              pffi-string->pointer
-              ;pffi-pointer->string
+              pffi-pointer->string
               pffi-struct-make
               pffi-struct-pointer
               pffi-struct-offset-get
               pffi-struct-get
               pffi-struct-set!
-              ;pffi-define
+              pffi-define
               ;pffi-define-callback
               ))
     (gerbil

retropikzel/pffi/chibi.scm

@@ -176,9 +176,9 @@
                   pointer)))))
 
 (define make-c-function
-  (lambda (shared-object return-type c-name argument-types)
+  (lambda (shared-object c-name return-type argument-types)
     (dlerror) ;; Clean all previous errors
-    (let ((func (dlsym shared-object c-name))
+    (let ((c-function (dlsym shared-object c-name))
           (maybe-dlerror (dlerror))
           (return-value (pffi-pointer-allocate
                           (if (equal? return-type 'void)
@@ -188,13 +188,13 @@
         (error (pffi-pointer->string maybe-dlerror)))
       (lambda arguments
         (internal-ffi-call (length argument-types)
-                           (pffi-type->libffi-type return-type)
+                  (pffi-type->libffi-type return-type)
-                           (map pffi-type->libffi-type argument-types)
+                  (map pffi-type->libffi-type argument-types)
-                           func
+                  c-function
-                           return-value
+                  return-value
-                           (map argument->pointer
+                  (map argument->pointer
-                                arguments
+                       arguments
-                                argument-types))
+                       argument-types))
         (cond ((not (equal? return-type 'void))
                (pffi-pointer-get return-value return-type 0)))))))
 
@@ -203,8 +203,8 @@
     ((pffi-define scheme-name shared-object c-name return-type argument-types)
      (define scheme-name
        (make-c-function shared-object
-                        return-type
                         (symbol->string c-name)
+                        return-type
                         argument-types)))))
 
 (define make-c-callback

retropikzel/pffi/gauche.scm

@@ -6,7 +6,10 @@
                        pffi-pointer-allocate
                        pffi-pointer?
                        pffi-pointer-free
-                       spigot-calculate-e))
+                       pffi-pointer-set!
+                       pffi-pointer-get
+                       pffi-string->pointer
+                       pffi-pointer->string))
 (select-module retropikzel.pffi.gauche)
 (dynamic-load "retropikzel-pffi-gauche")
 
@@ -59,3 +62,83 @@
   (lambda (pointer)
     (pointer-free pointer)))
 
+(define pffi-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))
+          ((equal? type 'int16) (pointer-set-int16! pointer offset value))
+          ((equal? type 'uint16) (pointer-set-uint16! pointer offset value))
+          ((equal? type 'int32) (pointer-set-int32! pointer offset value))
+          ((equal? type 'uint32) (pointer-set-uint32! pointer offset value))
+          ((equal? type 'int64) (pointer-set-int64! pointer offset value))
+          ((equal? type 'uint64) (pointer-set-uint64! pointer offset value))
+          ((equal? type 'char) (pointer-set-char! pointer offset value))
+          ((equal? type 'short) (pointer-set-short! pointer offset value))
+          ((equal? type 'unsigned-short) (pointer-set-unsigned-short! pointer offset value))
+          ((equal? type 'int) (pointer-set-int! pointer offset value))
+          ((equal? type 'unsigned-int) (pointer-set-unsigned-int! pointer offset value))
+          ((equal? type 'long) (pointer-set-long! pointer offset value))
+          ((equal? type 'unsigned-long) (pointer-set-unsigned-long! pointer offset value))
+          ((equal? type 'float) (pointer-set-float! pointer offset value))
+          ((equal? type 'double) (pointer-set-double! pointer offset value))
+          ((equal? type 'void) (pointer-set-pointer! pointer offset value))
+          ((equal? type 'pointer) (pointer-set-pointer! pointer offset value)))))
+
+(define pffi-pointer-get
+  (lambda (pointer type offset)
+    (cond ((equal? type 'int8) (pointer-get-int8 pointer offset))
+          ((equal? type 'uint8) (pointer-get-uint8 pointer offset))
+          ((equal? type 'int16) (pointer-get-int16 pointer offset))
+          ((equal? type 'uint16) (pointer-get-uint16 pointer offset))
+          ((equal? type 'int32) (pointer-get-int32 pointer offset))
+          ((equal? type 'uint32) (pointer-get-uint32 pointer offset))
+          ((equal? type 'int64) (pointer-get-int64 pointer offset))
+          ((equal? type 'uint64) (pointer-get-uint64 pointer offset))
+          ((equal? type 'char) (integer->char (pointer-get-char pointer offset)))
+          ((equal? type 'short) (pointer-get-short pointer offset))
+          ((equal? type 'unsigned-short) (pointer-get-unsigned-short pointer offset))
+          ((equal? type 'int) (pointer-get-int pointer offset))
+          ((equal? type 'unsigned-int) (pointer-get-unsigned-int pointer offset))
+          ((equal? type 'long) (pointer-get-long pointer offset))
+          ((equal? type 'unsigned-long) (pointer-get-unsigned-long pointer offset))
+          ((equal? type 'float) (pointer-get-float pointer offset))
+          ((equal? type 'double) (pointer-get-double pointer offset))
+          ((equal? type 'void) (pointer-get-pointer pointer offset))
+          ((equal? type 'pointer) (pointer-get-pointer pointer offset)))))
+
+(define pffi-string->pointer
+  (lambda (string-content)
+    (string->pointer string-content)))
+
+(define pffi-pointer->string
+  (lambda (pointer)
+    (pointer->string 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))
+          (return-value (pffi-pointer-allocate
+                          (if (equal? return-type 'void)
+                            0
+                            (size-of-type return-type)))))
+      (when (not (pffi-pointer-null? maybe-dlerror))
+        (error (pffi-pointer->string maybe-dlerror)))
+      (lambda arguments
+        (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 c-name return-type argument-types)))))

retropikzel/pffi/main.scm

@@ -1,206 +0,0 @@
-(cond-expand
-  ((or chicken-5 chicken-6)
-   (define-syntax pffi-init
-     (er-macro-transformer
-       (lambda (expr rename compare)
-         '(import (chicken foreign)
-                  (chicken memory))
-         #t))))
-  (else
-    (define (pffi-init) #t)))
-
-(define (pffi-type? object)
-  (if (equal? (size-of-type object) #f)
-    #f
-    #t))
-
-(define (pffi-size-of object)
-  (cond ((pffi-struct? object) (pffi-struct-size object))
-        ((pffi-union? object) (pffi-union-size object))
-        ((pffi-type? object) (size-of-type object))
-        (else (error "Not pffi-struct, pffi-enum of pffi-type" object))))
-
-(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
-     string
-     pointer
-     void))
-
-(define string-split
-  (lambda (str mark)
-    (let* ((str-l (string->list str))
-           (res (list))
-           (last-index 0)
-           (index 0)
-           (splitter (lambda (c)
-                       (cond ((char=? c mark)
-                              (begin
-                                (set! res (append res (list (string-copy str last-index index))))
-                                (set! last-index (+ index 1))))
-                             ((equal? (length str-l) (+ index 1))
-                              (set! res (append res (list (string-copy str last-index (+ index 1)))))))
-                       (set! index (+ index 1)))))
-      (for-each splitter str-l)
-      res)))
-
-(cond-expand
-  (gambit
-    (define-macro
-      (pffi-shared-object-auto-load headers object-name options)
-      `(pffi-shared-object-load ,(car headers))))
-
-  ((or chicken cyclone)
-   (define-syntax pffi-shared-object-auto-load
-     (syntax-rules ()
-       ((_ headers object-name . options)
-        (pffi-shared-object-load headers)))))
-  (else
-    (define pffi-shared-object-auto-load
-      (lambda (headers object-name . options)
-        (let* ((additional-paths (if (assoc 'additional-paths options)
-                                   (cdr (assoc 'additional-paths options))
-                                   (list)))
-               (additional-versions (if (assoc 'additional-versions options)
-                                      (map (lambda (version)
-                                             (if (number? version)
-                                               (number->string version)
-                                               version))
-                                           (cdr (assoc 'additional-versions options)))
-                                      (list)))
-               (slash (cond-expand (windows (string #\\)) (else "/")))
-               (auto-load-paths
-                 (cond-expand
-                   (windows
-                     (append
-                       (if (get-environment-variable "SYSTEM")
-                         (list (get-environment-variable "SYSTEM"))
-                         (list))
-                       (if (get-environment-variable "WINDIR")
-                         (list (get-environment-variable "WINDIR"))
-                         (list))
-                       (if (get-environment-variable "WINEDLLDIR0")
-                         (list (get-environment-variable "WINEDLLDIR0"))
-                         (list))
-                       (if (get-environment-variable "SystemRoot")
-                         (list (string-append
-                                 (get-environment-variable "SystemRoot")
-                                 slash
-                                 "system32"))
-                         (list))
-                       (list ".")
-                       (if (get-environment-variable "PATH")
-                         (string-split (get-environment-variable "PATH") #\;)
-                         (list))
-                       (if (get-environment-variable "PWD")
-                         (list (get-environment-variable "PWD"))
-                         (list))))
-                   (else
-                     (append
-                       ; Guix
-                       (list (if (get-environment-variable "GUIX_ENVIRONMENT")
-                               (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
-                               "")
-                             "/run/current-system/profile/lib")
-                       ; Debian
-                       (if (get-environment-variable "LD_LIBRARY_PATH")
-                         (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
-                         (list))
-                       (list
-                         ;;; x86-64
-                         ; Debian
-                         "/lib/x86_64-linux-gnu"
-                         "/usr/lib/x86_64-linux-gnu"
-                         "/usr/local/lib"
-                         ; Fedora/Alpine
-                         "/usr/lib"
-                         "/usr/lib64"
-                         ;;; aarch64
-                         ; Debian
-                         "/lib/aarch64-linux-gnu"
-                         "/usr/lib/aarch64-linux-gnu"
-                         "/usr/local/lib"
-                         ; Fedora/Alpine
-                         "/usr/lib"
-                         "/usr/lib64"
-                         ; NetBSD
-                         "/usr/pkg/lib")))))
-               (auto-load-versions (list ""))
-               (paths (append auto-load-paths additional-paths))
-               (versions (append additional-versions auto-load-versions))
-               (platform-lib-prefix
-                 (cond-expand
-                   ;(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
-                   (windows "")
-                   (else "lib")))
-               (platform-file-extension
-                 (cond-expand
-                   ;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
-                   (windows ".dll")
-                   (else ".so")))
-               (shared-object #f)
-               (searched-paths (list)))
-          (for-each
-            (lambda (path)
-              (for-each
-                (lambda (version)
-                  (let ((library-path
-                          (string-append path
-                                         slash
-                                         platform-lib-prefix
-                                         object-name
-                                         (cond-expand
-                                           (windows "")
-                                           (else platform-file-extension))
-                                         (if (string=? version "")
-                                           ""
-                                           (string-append
-                                             (cond-expand (windows "-")
-                                                          (else "."))
-                                             version))
-                                         (cond-expand
-                                           (windows platform-file-extension)
-                                           (else ""))))
-                        (library-path-without-suffixes (string-append path
-                                                                      slash
-                                                                      platform-lib-prefix
-                                                                      object-name)))
-                    (set! searched-paths (append searched-paths (list library-path)))
-                    (when (and (not shared-object)
-                               (file-exists? library-path))
-                      (set! shared-object
-                        (cond-expand (racket library-path-without-suffixes)
-                                     (else library-path))))))
-                versions))
-            paths)
-          (if (not shared-object)
-            (begin
-              (display "Could not load shared object: ")
-              (write (list (cons 'object object-name)
-                           (cons 'paths paths)
-                           (cons 'platform-file-extension platform-file-extension)
-                           (cons 'versions versions)))
-              (newline)
-              (display "Searched paths: ")
-              (write searched-paths)
-              (newline)
-              (exit 1))
-            (pffi-shared-object-load headers
-                                     shared-object
-                                     `((additional-versions ,versions)))))))))

retropikzel/pffi/shared/main.scm

@@ -7,18 +7,20 @@
                   (chicken memory))
          #t))))
   (else
-    (define (pffi-init) #t)))
+    (define pffi-init(lambda () #t))))
 
-(define (pffi-type? object)
+(define pffi-type?
-  (if (equal? (size-of-type object) #f)
+  (lambda (object)
-    #f
+    (if (equal? (size-of-type object) #f)
-    #t))
+      #f
+      #t)))
 
-(define (pffi-size-of object)
+(define pffi-size-of
-  (cond ((pffi-struct? object) (pffi-struct-size object))
+  (lambda (object)
-        ((pffi-union? object) (pffi-union-size object))
+    (cond ((pffi-struct? object) (pffi-struct-size object))
-        ((pffi-type? object) (size-of-type object))
+          ((pffi-union? object) (pffi-union-size object))
-        (else (error "Not pffi-struct, pffi-enum of pffi-type" object))))
+          ((pffi-type? object) (size-of-type object))
+          (else (error "Not pffi-struct, pffi-enum of pffi-type" object)))))
 
 (define pffi-types
   '(int8

src/gauche/gauchelib.scm

@@ -0,0 +1,79 @@
+(in-module retropikzel.pffi.gauche)
+
+(inline-stub
+ (.include "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? (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 make-c-function (shared-object c-name return-type argument-types) make_c_function)
+ )

src/gauchelib.scm

@@ -1,45 +0,0 @@
-;;;
-;;; spigot - 'spigot' extension module example
-;;;
-;;;  Written by Shiro Kawai (shiro@acm.org)
-;;;  I put this program in public domain.  Use it as you like.
-;;;
-
-(in-module retropikzel.pffi.gauche)
-
-;;
-;; The 'define-cproc' forms exposes C functions to Scheme world.
-;;
-
-(inline-stub
- (.include "pffi-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>) 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? (pointer) is_pointer)
- (define-cproc pointer-free (pointer) pointer_free)
- (define-cproc spigot-calculate-e (digits::<int>) Spigot_calculate_e))
-
-;; You can define Scheme functions here if you want.

src/pffi-chibi.stub

@@ -1,265 +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 void*) dlopen (string int))
-(define-c (maybe-null void*) dlerror ())
-
-(c-declare "void* pointer_null() { return NULL; }")
-(define-c (maybe-null 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 void*)))
-
-(c-declare "void* pointer_allocate(int size) { return malloc(size); }")
-(define-c (maybe-null void*) (pointer-allocate pointer_allocate) (int))
-
-(c-declare "int pointer_address(void* pointer) { return (intptr_t)&pointer; }")
-(define-c int (pointer-address pointer_address) ((maybe-null void*)))
-
-(c-declare "void pointer_free(void* pointer) { free(pointer); }")
-(define-c void (pointer-free pointer_free) ((maybe-null 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 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 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 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 void*)))
-
-;; pffi-define
-
-(c-declare "ffi_cif cif;")
-(define-c (pointer void*) dlsym ((maybe-null 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, void* avalues) {
-    ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
-    ffi_call(&cif, FFI_FN(fn), rvalue, &avalues);
-  }")
-(define-c void
-          (internal-ffi-call internal_ffi_call)
-          (unsigned-int
-            (pointer void*)
-            (array void*)
-            (pointer void*)
-            (pointer void*)
-            (array void*)))
-
-(c-declare
-  "void* scheme_procedure_to_pointer(sexp proc) {
-    if(sexp_procedurep(proc) == 1) {
-      sexp debug1 = sexp_procedure_code(proc);
-      printf(\"HERE: %u\\n\", sexp_bytecode_length(debug1));
-    }
-    return (void*)proc;
-  }")
-(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp))

src/pffi-gauche.c

@@ -1,142 +0,0 @@
-#include <math.h>
-#include <stdint.h>
-#include <gauche.h>
-#include <gauche/extend.h>
-#include <gauche/module.h>
-#include <gauche/load.h>
-#include <pffi-gauche.h>
-#include <ffi.h>
-#include <dlfcn.h>
-
-ScmObj size_of_int8() { return Scm_MakeInteger(sizeof(int8_t)); }
-ScmObj size_of_uint8() { return Scm_MakeInteger(sizeof(uint8_t)); }
-ScmObj size_of_int16() { return Scm_MakeInteger(sizeof(int16_t)); }
-ScmObj size_of_uint16() { return Scm_MakeInteger(sizeof(uint16_t)); }
-ScmObj size_of_int32() { return Scm_MakeInteger(sizeof(int32_t)); }
-ScmObj size_of_uint32() { return Scm_MakeInteger(sizeof(uint32_t)); }
-ScmObj size_of_int64() { return Scm_MakeInteger(sizeof(int64_t)); }
-ScmObj size_of_uint64() { return Scm_MakeInteger(sizeof(uint64_t)); }
-ScmObj size_of_char() { return Scm_MakeInteger(sizeof(char)); }
-ScmObj size_of_unsigned_char() { return Scm_MakeInteger(sizeof(unsigned char)); }
-ScmObj size_of_short() { return Scm_MakeInteger(sizeof(short)); }
-ScmObj size_of_unsigned_short() { return Scm_MakeInteger(sizeof(unsigned short)); }
-ScmObj size_of_int() { return Scm_MakeInteger(sizeof(int)); }
-ScmObj size_of_unsigned_int() { return Scm_MakeInteger(sizeof(unsigned int)); }
-ScmObj size_of_long() { return Scm_MakeInteger(sizeof(long)); }
-ScmObj size_of_unsigned_long() { return Scm_MakeInteger(sizeof(unsigned long)); }
-ScmObj size_of_float() { return Scm_MakeInteger(sizeof(float)); }
-ScmObj size_of_double() { return Scm_MakeInteger(sizeof(double)); }
-ScmObj size_of_string() { return Scm_MakeInteger(sizeof(char*)); }
-ScmObj size_of_pointer() { return Scm_MakeInteger(sizeof(void*)); }
-ScmObj size_of_void() { return Scm_MakeInteger(sizeof(void)); }
-
-ScmModule* module = NULL;
-
-void print_shared_object(ScmObj obj, ScmPort* sink, ScmWriteContext* G1788 SCM_UNUSED) {
-    printf("<pffi-shared-object>\n");
-}
-
-ScmObj shared_object_load(ScmString* scm_path) {
-    const ScmStringBody* body = SCM_STRING_BODY(scm_path);
-    const char* path = SCM_STRING_BODY_START(body);
-    void* shared_object = dlopen(path, RTLD_NOW);
-    ScmClass* class = Scm_MakeForeignPointerClass(module, "<pffi-shared-object>", print_shared_object, NULL, 0);
-    ScmObj scm_shared_object = Scm_MakeForeignPointer(class, shared_object);
-    printf("Loading path: %s\n", path);
-    return scm_shared_object;
-}
-
-void print_pointer(ScmObj obj, ScmPort* sink, ScmWriteContext* G1788 SCM_UNUSED) {
-    printf("<pffi-pointer>\n");
-}
-
-ScmObj pointer_null() {
-    ScmClass* class = Scm_MakeForeignPointerClass(module, "<pffi-pointer>", print_pointer, NULL, 0);
-    ScmObj pointer = Scm_MakeForeignPointer(class, NULL);
-    return pointer;
-}
-
-ScmObj is_pointer_null(ScmObj pointer) {
-    if(!SCM_FOREIGN_POINTER_P(pointer)) {
-        return SCM_FALSE;
-    }
-    if(SCM_FOREIGN_POINTER_REF(void*, pointer) == NULL) {
-        return SCM_TRUE;
-    } else {
-        return SCM_FALSE;
-    }
-}
-
-ScmObj pointer_allocate(int size) {
-    ScmClass* class = Scm_MakeForeignPointerClass(module, "<pffi-pointer>", print_pointer, NULL, 0);
-    ScmObj pointer = Scm_MakeForeignPointer(class, malloc(size));
-    return pointer;
-}
-
-ScmObj is_pointer(ScmObj pointer) {
-    if(SCM_FOREIGN_POINTER_P(pointer)) {
-        return SCM_TRUE;
-    } else {
-        return SCM_FALSE;
-    }
-}
-
-ScmObj pointer_free(ScmObj pointer) {
-    if(SCM_FOREIGN_POINTER_P(pointer)) {
-        free(SCM_FOREIGN_POINTER_REF(void*, pointer));
-    }
-}
-
-ScmObj Spigot_calculate_e(int digits)
-{
-    int k, i, j, l, b, q, r, *array;
-    ScmObj rvec, *relts;
-
-    if (digits <= 0) Scm_Error("digits must be a positive integer");
-
-    /* Scheme vector to keep the result */
-    rvec = Scm_MakeVector(digits, SCM_MAKE_INT(0));
-    relts = SCM_VECTOR_ELEMENTS(rvec);
-
-    /* Prepare the array for variable base system */
-    k = (int)floor(digits * 3.3219280948873626);
-    array = SCM_NEW_ATOMIC2(int *, (k+1)*sizeof(int));
-    for (i=0; i<k; i++) array[i] = 1;
-    array[k] = 2;
-
-    for (i=0, b=1; i<digits; i++) {
-        q = 0;
-        for (j=k; j>0; j--) {
-            q += array[j] * 10;
-            array[j] = q % j;
-            q /= j;
-        }
-        r = b + q/10;
-        b = q % 10;
-        /* Here, we have the i-th digit in r.
-           In rare occasions, r becomes more than 10, and we need to back-up
-           to increment the previous digit(s).  (It's rarely the case that
-           this back-up cascades for more than one digit). */
-        if (r < 10) {
-            relts[i] = SCM_MAKE_INT(r);
-        } else {
-            relts[i] = SCM_MAKE_INT(r%10);
-            for (l=i-1, r/=10; r && l>=0; l--, r/=10) {
-                r += SCM_INT_VALUE(relts[l]);
-                relts[l] = SCM_MAKE_INT(r%10);
-            }
-        }
-    }
-    return rvec;
-}
-
-/*
- * Module initialization function.
- * This is called when math--spigot.so is dynamically loaded into gosh.
- */
-void Scm_Init_retropikzel_pffi_gauche(void)
-{
-    SCM_INIT_EXTENSION(retropikzel.pffi.gauche);
-    module = SCM_MODULE(SCM_FIND_MODULE("retropikzel.pffi.gauche", TRUE));
-    Scm_Init_gauchelib();
-}