From a6e63db25279daed2b593d395fcc55991627917b Mon Sep 17 00:00:00 2001 From: retropikzel Date: Tue, 4 Mar 2025 18:35:19 +0200 Subject: [PATCH] Cleaning up the repository structure. Improving the Gauche implementation --- Makefile | 15 +- include/pffi-gauche.h | 36 ---- retropikzel/pffi.sld | 13 +- retropikzel/pffi/chibi.scm | 20 +-- retropikzel/pffi/gauche.scm | 85 ++++++++- retropikzel/pffi/main.scm | 206 --------------------- retropikzel/pffi/shared/main.scm | 22 +-- src/{chibi.stub => chibi/pffi.stub} | 0 src/gauche/gauchelib.scm | 79 +++++++++ src/gauchelib.scm | 45 ----- src/pffi-chibi.stub | 265 ---------------------------- src/pffi-gauche.c | 142 --------------- 12 files changed, 199 insertions(+), 729 deletions(-) delete mode 100644 include/pffi-gauche.h delete mode 100644 retropikzel/pffi/main.scm rename src/{chibi.stub => chibi/pffi.stub} (100%) create mode 100644 src/gauche/gauchelib.scm delete mode 100644 src/gauchelib.scm delete mode 100644 src/pffi-chibi.stub delete mode 100644 src/pffi-gauche.c diff --git a/Makefile b/Makefile index 3fa633f..3d52d27 100644 --- a/Makefile +++ b/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 - ${CC} -Werror -g3 -o retropikzel/pffi/pffi-chibi.so \ - src/pffi-chibi.c \ + chibi-ffi src/chibi/pffi.stub + ${CC} -g3 -o retropikzel/pffi/chibi-pffi.so \ + src/chibi/pffi.c \ -fPIC \ -lffi \ -shared gauche: - CFLAGS="-I./include" gauche-package compile \ - --verbose --srcdir=src retropikzel-pffi-gauche pffi-gauche.c gauchelib.scm + CFLAGS="-I. -Werror -Wall -g3 -lffi" \ + 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 diff --git a/include/pffi-gauche.h b/include/pffi-gauche.h deleted file mode 100644 index e3f9d4a..0000000 --- a/include/pffi-gauche.h +++ /dev/null @@ -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); diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index dc28711..232629f 100644 --- a/retropikzel/pffi.sld +++ b/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-get - ;pffi-string->pointer - ;pffi-pointer->string + pffi-pointer-set! + pffi-pointer-get + pffi-string->pointer + 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 diff --git a/retropikzel/pffi/chibi.scm b/retropikzel/pffi/chibi.scm index d88959c..0d0cbea 100644 --- a/retropikzel/pffi/chibi.scm +++ b/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) - (map pffi-type->libffi-type argument-types) - func - return-value - (map argument->pointer - arguments - 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))))))) @@ -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 diff --git a/retropikzel/pffi/gauche.scm b/retropikzel/pffi/gauche.scm index a7cc91e..53b76bc 100644 --- a/retropikzel/pffi/gauche.scm +++ b/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))))) diff --git a/retropikzel/pffi/main.scm b/retropikzel/pffi/main.scm deleted file mode 100644 index dd7cffd..0000000 --- a/retropikzel/pffi/main.scm +++ /dev/null @@ -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))))))))) diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index dd7cffd..3f9263f 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/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) - (if (equal? (size-of-type object) #f) - #f - #t)) +(define pffi-type? + (lambda (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-size-of + (lambda (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 diff --git a/src/chibi.stub b/src/chibi/pffi.stub similarity index 100% rename from src/chibi.stub rename to src/chibi/pffi.stub diff --git a/src/gauche/gauchelib.scm b/src/gauche/gauchelib.scm new file mode 100644 index 0000000..5dbcf68 --- /dev/null +++ b/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::) shared_object_load) + (define-cproc pointer-null () pointer_null) + (define-cproc pointer-null? (pointer) is_pointer_null) + (define-cproc pointer-allocate (size::) pointer_allocate) + (define-cproc pointer? (pointer) is_pointer) + (define-cproc pointer-free (pointer) pointer_free) + + (define-cproc pointer-set-int8! (pointer offset:: value::) pointer_set_int8) + (define-cproc pointer-set-uint8! (pointer offset:: value::) pointer_set_uint8) + (define-cproc pointer-set-int16! (pointer offset:: value::) pointer_set_int16) + (define-cproc pointer-set-uint16! (pointer offset:: value::) pointer_set_uint16) + (define-cproc pointer-set-int32! (pointer offset:: value::) pointer_set_int32) + (define-cproc pointer-set-uint32! (pointer offset:: value::) pointer_set_uint32) + (define-cproc pointer-set-int64! (pointer offset:: value::) pointer_set_int64) + (define-cproc pointer-set-uint64! (pointer offset:: value::) pointer_set_uint64) + (define-cproc pointer-set-char! (pointer offset:: value::) pointer_set_char) + (define-cproc pointer-set-unsigned-char! (pointer offset:: value::) pointer_set_unsigned_char) + (define-cproc pointer-set-short! (pointer offset:: value::) pointer_set_short) + (define-cproc pointer-set-unsigned-short! (pointer offset:: value::) pointer_set_unsigned_short) + (define-cproc pointer-set-int! (pointer offset:: value::) pointer_set_int) + (define-cproc pointer-set-unsigned-int! (pointer offset:: value::) pointer_set_unsigned_int) + (define-cproc pointer-set-long! (pointer offset:: value::) pointer_set_long) + (define-cproc pointer-set-unsigned-long! (pointer offset:: value::) pointer_set_unsigned_long) + (define-cproc pointer-set-float! (pointer offset:: value::) pointer_set_float) + (define-cproc pointer-set-double! (pointer offset:: value::) pointer_set_double) + (define-cproc pointer-set-pointer! (pointer offset:: value) pointer_set_pointer) + + (define-cproc pointer-get-int8 (pointer offset::) pointer_get_int8) + (define-cproc pointer-get-uint8 (pointer offset::) pointer_get_uint8) + (define-cproc pointer-get-int16 (pointer offset::) pointer_get_int16) + (define-cproc pointer-get-uint16 (pointer offset::) pointer_get_uint16) + (define-cproc pointer-get-int32 (pointer offset::) pointer_get_int32) + (define-cproc pointer-get-uint32 (pointer offset::) pointer_get_uint32) + (define-cproc pointer-get-int64 (pointer offset::) pointer_get_int64) + (define-cproc pointer-get-uint64 (pointer offset::) pointer_get_uint64) + (define-cproc pointer-get-char (pointer offset::) pointer_get_char) + (define-cproc pointer-get-unsigned-char (pointer offset::) pointer_get_unsigned_char) + (define-cproc pointer-get-short (pointer offset::) pointer_get_short) + (define-cproc pointer-get-unsigned-short (pointer offset::) pointer_get_unsigned_short) + (define-cproc pointer-get-int (pointer offset::) pointer_get_int) + (define-cproc pointer-get-unsigned-int (pointer offset::) pointer_get_unsigned_int) + (define-cproc pointer-get-long (pointer offset::) pointer_get_long) + (define-cproc pointer-get-unsigned-long (pointer offset::) pointer_get_unsigned_long) + (define-cproc pointer-get-float (pointer offset::) pointer_get_float) + (define-cproc pointer-get-double (pointer offset::) pointer_get_double) + (define-cproc pointer-get-pointer (pointer offset::) 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) + ) diff --git a/src/gauchelib.scm b/src/gauchelib.scm deleted file mode 100644 index e101b7d..0000000 --- a/src/gauchelib.scm +++ /dev/null @@ -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::) shared_object_load) - (define-cproc pointer-null () pointer_null) - (define-cproc pointer-null? (pointer) is_pointer_null) - (define-cproc pointer-allocate (size::) pointer_allocate) - (define-cproc pointer? (pointer) is_pointer) - (define-cproc pointer-free (pointer) pointer_free) - (define-cproc spigot-calculate-e (digits::) Spigot_calculate_e)) - -;; You can define Scheme functions here if you want. diff --git a/src/pffi-chibi.stub b/src/pffi-chibi.stub deleted file mode 100644 index e0b64f3..0000000 --- a/src/pffi-chibi.stub +++ /dev/null @@ -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)) diff --git a/src/pffi-gauche.c b/src/pffi-gauche.c deleted file mode 100644 index 7e6162f..0000000 --- a/src/pffi-gauche.c +++ /dev/null @@ -1,142 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -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("\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, "", 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("\n"); -} - -ScmObj pointer_null() { - ScmClass* class = Scm_MakeForeignPointerClass(module, "", 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, "", 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; i0; 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(); -}