Cleaning up the repository structure. Improving the Gauche implementation
This commit is contained in:
parent
842178129d
commit
a6e63db252
15
Makefile
15
Makefile
|
|
@ -3,19 +3,20 @@ CC=gcc
|
||||||
DOCKER=docker run -it -v ${PWD}:/workdir
|
DOCKER=docker run -it -v ${PWD}:/workdir
|
||||||
DOCKER_INIT=cd /workdir && make clean &&
|
DOCKER_INIT=cd /workdir && make clean &&
|
||||||
|
|
||||||
all: chibi
|
all: chibi gauche libtest.so libtest.o libtest.a
|
||||||
|
|
||||||
chibi:
|
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 \
|
-fPIC \
|
||||||
-lffi \
|
-lffi \
|
||||||
-shared
|
-shared
|
||||||
|
|
||||||
gauche:
|
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:
|
jenkinsfile:
|
||||||
gosh -r7 -I ./snow build.scm
|
gosh -r7 -I ./snow build.scm
|
||||||
|
|
@ -58,7 +59,7 @@ clean:
|
||||||
@rm -rf test/pffi-define
|
@rm -rf test/pffi-define
|
||||||
@rm -rf test/*gambit*
|
@rm -rf test/*gambit*
|
||||||
find . -name "*.link" -delete
|
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" -delete
|
||||||
find . -name "*.o[1-9]" -delete
|
find . -name "*.o[1-9]" -delete
|
||||||
find . -name "*.so" -delete
|
find . -name "*.so" -delete
|
||||||
|
|
|
||||||
|
|
@ -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);
|
|
||||||
|
|
@ -33,9 +33,8 @@
|
||||||
pffi-define
|
pffi-define
|
||||||
pffi-define-callback
|
pffi-define-callback
|
||||||
scheme-procedure-to-pointer
|
scheme-procedure-to-pointer
|
||||||
|
|
||||||
)
|
)
|
||||||
(include-shared "pffi/pffi-chibi"))
|
(include-shared "pffi/chibi-pffi"))
|
||||||
(chicken-5
|
(chicken-5
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
|
|
@ -183,16 +182,16 @@
|
||||||
pffi-pointer-allocate
|
pffi-pointer-allocate
|
||||||
pffi-pointer?
|
pffi-pointer?
|
||||||
pffi-pointer-free
|
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-make
|
||||||
pffi-struct-pointer
|
pffi-struct-pointer
|
||||||
pffi-struct-offset-get
|
pffi-struct-offset-get
|
||||||
pffi-struct-get
|
pffi-struct-get
|
||||||
pffi-struct-set!
|
pffi-struct-set!
|
||||||
;pffi-define
|
pffi-define
|
||||||
;pffi-define-callback
|
;pffi-define-callback
|
||||||
))
|
))
|
||||||
(gerbil
|
(gerbil
|
||||||
|
|
|
||||||
|
|
@ -176,9 +176,9 @@
|
||||||
pointer)))))
|
pointer)))))
|
||||||
|
|
||||||
(define make-c-function
|
(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
|
(dlerror) ;; Clean all previous errors
|
||||||
(let ((func (dlsym shared-object c-name))
|
(let ((c-function (dlsym shared-object c-name))
|
||||||
(maybe-dlerror (dlerror))
|
(maybe-dlerror (dlerror))
|
||||||
(return-value (pffi-pointer-allocate
|
(return-value (pffi-pointer-allocate
|
||||||
(if (equal? return-type 'void)
|
(if (equal? return-type 'void)
|
||||||
|
|
@ -188,13 +188,13 @@
|
||||||
(error (pffi-pointer->string maybe-dlerror)))
|
(error (pffi-pointer->string maybe-dlerror)))
|
||||||
(lambda arguments
|
(lambda arguments
|
||||||
(internal-ffi-call (length argument-types)
|
(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))
|
(cond ((not (equal? return-type 'void))
|
||||||
(pffi-pointer-get return-value return-type 0)))))))
|
(pffi-pointer-get return-value return-type 0)))))))
|
||||||
|
|
||||||
|
|
@ -203,8 +203,8 @@
|
||||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||||
(define scheme-name
|
(define scheme-name
|
||||||
(make-c-function shared-object
|
(make-c-function shared-object
|
||||||
return-type
|
|
||||||
(symbol->string c-name)
|
(symbol->string c-name)
|
||||||
|
return-type
|
||||||
argument-types)))))
|
argument-types)))))
|
||||||
|
|
||||||
(define make-c-callback
|
(define make-c-callback
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,10 @@
|
||||||
pffi-pointer-allocate
|
pffi-pointer-allocate
|
||||||
pffi-pointer?
|
pffi-pointer?
|
||||||
pffi-pointer-free
|
pffi-pointer-free
|
||||||
spigot-calculate-e))
|
pffi-pointer-set!
|
||||||
|
pffi-pointer-get
|
||||||
|
pffi-string->pointer
|
||||||
|
pffi-pointer->string))
|
||||||
(select-module retropikzel.pffi.gauche)
|
(select-module retropikzel.pffi.gauche)
|
||||||
(dynamic-load "retropikzel-pffi-gauche")
|
(dynamic-load "retropikzel-pffi-gauche")
|
||||||
|
|
||||||
|
|
@ -59,3 +62,83 @@
|
||||||
(lambda (pointer)
|
(lambda (pointer)
|
||||||
(pointer-free 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)))))
|
||||||
|
|
|
||||||
|
|
@ -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)))))))))
|
|
||||||
|
|
@ -7,18 +7,20 @@
|
||||||
(chicken memory))
|
(chicken memory))
|
||||||
#t))))
|
#t))))
|
||||||
(else
|
(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
|
(define pffi-types
|
||||||
'(int8
|
'(int8
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
|
)
|
||||||
|
|
@ -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.
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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();
|
|
||||||
}
|
|
||||||
Loading…
Reference in New Issue