Started moving towards distribution as C files
This commit is contained in:
parent
db4376635f
commit
6e0d9efdf1
25
Makefile
25
Makefile
|
|
@ -1,18 +1,39 @@
|
|||
.PHONY: test
|
||||
PREFIX=/usr/local
|
||||
CC=gcc
|
||||
CHICKEN_FLAGS=-optimize-level 3
|
||||
|
||||
build:
|
||||
${CC} -o compile-r7rs \
|
||||
-Os \
|
||||
-fomit-frame-pointer \
|
||||
-DHAVE_CHICKEN_CONFIG_H \
|
||||
src/compile-r7rs.c \
|
||||
src/*.c \
|
||||
chicken/src/*.c \
|
||||
-lm \
|
||||
-Ichicken/include
|
||||
|
||||
test-sagittarius:
|
||||
cd test && sash -r7 -L ${PWD}/snow ../compile-r7rs.scm
|
||||
|
||||
test-racket:
|
||||
cd test && racket -I r7rs -S ${PWD}/snow --script ../compile-r7rs.scm
|
||||
|
||||
build-snow:
|
||||
rm -rf snow
|
||||
mkdir -p snow
|
||||
cp -r ../r7rs-pffi/retropikzel snow/
|
||||
cp -r ../pffi-srfi-170/srfi snow/
|
||||
|
||||
c-files: src
|
||||
csc -t compile-r7rs.scm -optimize-level 3 -output-file src/compile-r7rs.c
|
||||
csc -t snow/retropikzel/pffi.sld -J ${CHICKEN_FLAGS} -output-file src/retropikzel.pffi.c
|
||||
csc -t snow/srfi/170.sld -J ${CHICKEN_FLAGS} -output-file src/srfi.170.c
|
||||
csc -t compile-r7rs.scm ${CHICKEN_FLAGS} -output-file src/compile-r7rs.c
|
||||
|
||||
test:
|
||||
cd test && ../compile-r7rs -I ./libs
|
||||
cd test && ../compile-r7rs -I ./libs foo.scm
|
||||
cd test && ./foo
|
||||
|
||||
src:
|
||||
mkdir -p src
|
||||
|
|
|
|||
|
|
@ -0,0 +1,3 @@
|
|||
#lang r7rs
|
||||
(import (scheme base))
|
||||
(include "compile-r7rs.scm")
|
||||
|
|
@ -1,18 +1,26 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme process-context))
|
||||
|
||||
(define scheme (get-environment-variable "SCHEME"))
|
||||
(when (not scheme)
|
||||
(error "Environment variable SCHEME not set."))
|
||||
(scheme process-context)
|
||||
(retropikzel pffi)
|
||||
(srfi 170))
|
||||
|
||||
(define interpreters '(chibi))
|
||||
(define compilers '(chicken))
|
||||
(define implementations (append interpreters compilers))
|
||||
|
||||
(define scheme (get-environment-variable "SCHEME"))
|
||||
(when (not scheme) (error "Environment variable SCHEME not set."))
|
||||
(define is-interpreter? (if (member (string->symbol scheme) interpreters) #t #f))
|
||||
(define is-compiler? (if (member (string->symbol scheme) compilers) #t #f))
|
||||
|
||||
|
||||
(when (not (member (string->symbol scheme) implementations))
|
||||
(error "Unsupported scheme implementation" scheme))
|
||||
|
||||
(define file-to-compile
|
||||
(if (> (length (command-line)) 1)
|
||||
(car (reverse (command-line)))
|
||||
#f))
|
||||
|
||||
(write file-to-compile)
|
||||
(newline)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,50 @@
|
|||
;;;; retropikzel.pffi.import.scm - GENERATED BY CHICKEN 6.0.0 -*- Scheme -*-
|
||||
|
||||
(##sys#with-environment
|
||||
(lambda ()
|
||||
(scheme#eval
|
||||
'(import-syntax
|
||||
(only scheme.base
|
||||
begin
|
||||
cond-expand
|
||||
export
|
||||
import
|
||||
import-for-syntax
|
||||
include
|
||||
include-ci
|
||||
syntax-rules)
|
||||
(only chicken.module export/rename)
|
||||
scheme.base
|
||||
scheme.write
|
||||
scheme.char
|
||||
scheme.file
|
||||
scheme.process-context
|
||||
chicken.base
|
||||
chicken.foreign
|
||||
chicken.locative
|
||||
chicken.syntax
|
||||
chicken.memory
|
||||
chicken.random))
|
||||
(import
|
||||
(only scheme.base
|
||||
begin
|
||||
cond-expand
|
||||
export
|
||||
import
|
||||
import-for-syntax
|
||||
include
|
||||
include-ci
|
||||
syntax-rules))
|
||||
(##sys#register-compiled-module
|
||||
'retropikzel.pffi
|
||||
'#f
|
||||
(scheme#list)
|
||||
'()
|
||||
(scheme#list
|
||||
(scheme#cons
|
||||
'|\x4;r7rsretropikzel.pffi|
|
||||
(##sys#er-transformer (##core#lambda (x r c) (##core#undefined)))))
|
||||
(scheme#list)
|
||||
(scheme#list))))
|
||||
|
||||
;; END OF FILE
|
||||
Binary file not shown.
|
|
@ -0,0 +1,3 @@
|
|||
#lang r7rs
|
||||
(import (scheme base))
|
||||
(include "pffi.sld")
|
||||
|
|
@ -0,0 +1,189 @@
|
|||
(define-library
|
||||
(retropikzel pffi)
|
||||
(cond-expand
|
||||
(chibi
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(chibi ast)
|
||||
(chibi))
|
||||
(include-shared "pffi/chibi-pffi"))
|
||||
(chicken
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(chicken base)
|
||||
(chicken foreign)
|
||||
(chicken locative)
|
||||
(chicken syntax)
|
||||
(chicken memory)
|
||||
(chicken random)))
|
||||
(cyclone
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(cyclone foreign)
|
||||
(scheme cyclone primitives)))
|
||||
(gambit
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(only (gambit) c-declare c-lambda c-define define-macro)))
|
||||
(gauche
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(gauche base)
|
||||
(retropikzel pffi gauche)))
|
||||
(gerbil
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)))
|
||||
(guile
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(rnrs bytevectors)
|
||||
(system foreign)
|
||||
(system foreign-library)))
|
||||
(kawa
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)))
|
||||
(larceny
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(rename (primitives r5rs:require) (r5rs:require require))
|
||||
(primitives std-ffi)
|
||||
(primitives foreign-procedure)
|
||||
(primitives foreign-file)
|
||||
(primitives foreign-stdlib)))
|
||||
(mosh
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(mosh ffi)))
|
||||
(racket
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(only (racket base) system-type)
|
||||
(ffi winapi)
|
||||
(compatibility mlist)
|
||||
(ffi unsafe)
|
||||
(ffi vector)))
|
||||
(sagittarius
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(sagittarius ffi)
|
||||
(sagittarius)))
|
||||
(skint
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)))
|
||||
(stklos
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(stklos))
|
||||
(export make-external-function
|
||||
calculate-struct-size-and-offsets
|
||||
struct-make))
|
||||
(tr7
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)))
|
||||
(ypsilon
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(ypsilon c-ffi)
|
||||
(ypsilon c-types)
|
||||
(only (core) define-macro syntax-case)))
|
||||
(else (error "Unsupported implementation")))
|
||||
(export pffi-init
|
||||
pffi-size-of
|
||||
pffi-type?
|
||||
pffi-align-of
|
||||
pffi-define-library
|
||||
pffi-pointer-null
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-address
|
||||
pffi-pointer?
|
||||
pffi-pointer-free
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-define-struct
|
||||
pffi-struct-pointer
|
||||
pffi-struct-offset-get
|
||||
pffi-struct-get
|
||||
pffi-struct-set!
|
||||
pffi-struct-dereference
|
||||
pffi-array-allocate
|
||||
pffi-array?
|
||||
pffi-pointer->array
|
||||
pffi-array-get
|
||||
pffi-array-set!
|
||||
pffi-list->array
|
||||
pffi-array->list
|
||||
pffi-define
|
||||
pffi-define-callback)
|
||||
(cond-expand
|
||||
(chibi (include "pffi/chibi.scm"))
|
||||
(chicken (include-relative "pffi/chicken.scm"))
|
||||
(cyclone (include "pffi/cyclone.scm"))
|
||||
(gambit (include "pffi/gambit.scm"))
|
||||
(gauche (include "pffi/gauche.scm"))
|
||||
(gerbil (include "pffi/gerbil.scm"))
|
||||
(guile (include "pffi/guile.scm"))
|
||||
(kawa (include "pffi/kawa.scm"))
|
||||
(larceny (include "pffi/larceny.scm"))
|
||||
(mosh (include "pffi/mosh.scm"))
|
||||
(racket (include "pffi/racket.scm"))
|
||||
(sagittarius (include "pffi/sagittarius.scm"))
|
||||
(skint (include "pffi/skint.scm"))
|
||||
(stklos (include "pffi/stklos.scm"))
|
||||
(tr7 (include "pffi/tr7.scm"))
|
||||
(ypsilon (include "pffi/ypsilon.scm")))
|
||||
;(include "pffi/shared/union.scm")
|
||||
(include "pffi/shared/main.scm")
|
||||
(include "pffi/shared/pointer.scm")
|
||||
(include "pffi/shared/array.scm")
|
||||
(include "pffi/shared/struct.scm"))
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
CC=gcc
|
||||
|
||||
chibi-pffi.so: chibi/pffi.stub
|
||||
chibi-ffi chibi/pffi.stub
|
||||
${CC} -g3 -o chibi-pffi.so chibi/pffi.c -fPIC -lffi -shared
|
||||
|
||||
gauche-pffi.so:
|
||||
gauche-package compile \
|
||||
--srcdir=gauche \
|
||||
--cc=${CC} \
|
||||
--cflags="-I./include" \
|
||||
--libs=-lffi \
|
||||
gauche-pffi gauche-pffi.c gauchelib.scm
|
||||
|
|
@ -0,0 +1,213 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) (size-of-int8_t))
|
||||
((eq? type 'uint8) (size-of-uint8_t))
|
||||
((eq? type 'int16) (size-of-int16_t))
|
||||
((eq? type 'uint16) (size-of-uint16_t))
|
||||
((eq? type 'int32) (size-of-int32_t))
|
||||
((eq? type 'uint32) (size-of-uint32_t))
|
||||
((eq? type 'int64) (size-of-int64_t))
|
||||
((eq? type 'uint64) (size-of-uint64_t))
|
||||
((eq? type 'char) (size-of-char))
|
||||
((eq? type 'unsigned-char) (size-of-char))
|
||||
((eq? type 'short) (size-of-short))
|
||||
((eq? type 'unsigned-short) (size-of-unsigned-short))
|
||||
((eq? type 'int) (size-of-int))
|
||||
((eq? type 'unsigned-int) (size-of-unsigned-int))
|
||||
((eq? type 'long) (size-of-long))
|
||||
((eq? type 'unsigned-long) (size-of-unsigned-long))
|
||||
((eq? type 'float) (size-of-float))
|
||||
((eq? type 'double) (size-of-double))
|
||||
((eq? type 'pointer) (size-of-pointer))
|
||||
((eq? type 'string) (size-of-pointer))
|
||||
((eq? type 'struct) (size-of-pointer))
|
||||
((eq? type 'callback) (size-of-pointer))
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (path options)
|
||||
(let ((shared-object (dlopen path RTLD-NOW))
|
||||
(maybe-error (dlerror)))
|
||||
(when (not (pffi-pointer-null? maybe-error))
|
||||
(error (pffi-pointer->string maybe-error)))
|
||||
shared-object)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(pointer-null)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(not pointer))) ; #f is null on Chibi
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(or (equal? object #f) ; False can be null pointer
|
||||
(pointer? object))))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(pointer-allocate size)))
|
||||
|
||||
(define pffi-pointer-address
|
||||
(lambda (pointer)
|
||||
(pointer-address pointer)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(pointer-free pointer)))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
|
||||
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
|
||||
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
|
||||
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
|
||||
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
|
||||
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
|
||||
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
|
||||
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
|
||||
((equal? type 'char) (pointer-set-c-char! pointer offset value))
|
||||
((equal? type 'short) (pointer-set-c-short! pointer offset value))
|
||||
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
|
||||
((equal? type 'int) (pointer-set-c-int! pointer offset value))
|
||||
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
|
||||
((equal? type 'long) (pointer-set-c-long! pointer offset value))
|
||||
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
|
||||
((equal? type 'float) (pointer-set-c-float! pointer offset value))
|
||||
((equal? type 'double) (pointer-set-c-double! pointer offset value))
|
||||
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
|
||||
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
|
||||
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
|
||||
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
|
||||
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
|
||||
((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
|
||||
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
|
||||
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
|
||||
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
|
||||
((equal? type 'char) (pointer-ref-c-char pointer offset))
|
||||
((equal? type 'short) (pointer-ref-c-short pointer offset))
|
||||
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
|
||||
((equal? type 'int) (pointer-ref-c-int pointer offset))
|
||||
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
|
||||
((equal? type 'long) (pointer-ref-c-long pointer offset))
|
||||
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
|
||||
((equal? type 'float) (pointer-ref-c-float pointer offset))
|
||||
((equal? type 'double) (pointer-ref-c-double pointer offset))
|
||||
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
|
||||
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
|
||||
|
||||
#;(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(string-to-pointer string-content)))
|
||||
|
||||
#;(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(pointer-to-string pointer)))
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) '(maybe-null void*))
|
||||
((equal? type 'string) 'string)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) '(maybe-null void*))
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
;; pffi-define
|
||||
|
||||
(define pffi-type->libffi-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) (get-ffi-type-int8))
|
||||
((equal? type 'uint8) (get-ffi-type-uint8))
|
||||
((equal? type 'int16) (get-ffi-type-int16))
|
||||
((equal? type 'uint16) (get-ffi-type-uint16))
|
||||
((equal? type 'int32) (get-ffi-type-int32))
|
||||
((equal? type 'uint32) (get-ffi-type-uint32))
|
||||
((equal? type 'int64) (get-ffi-type-int64))
|
||||
((equal? type 'uint64) (get-ffi-type-uint64))
|
||||
((equal? type 'char) (get-ffi-type-char))
|
||||
((equal? type 'unsigned-char) (get-ffi-type-uchar))
|
||||
((equal? type 'bool) (get-ffi-type-int8))
|
||||
((equal? type 'short) (get-ffi-type-short))
|
||||
((equal? type 'unsigned-short) (get-ffi-type-ushort))
|
||||
((equal? type 'int) (get-ffi-type-int))
|
||||
((equal? type 'unsigned-int) (get-ffi-type-uint))
|
||||
((equal? type 'long) (get-ffi-type-long))
|
||||
((equal? type 'unsigned-long) (get-ffi-type-ulong))
|
||||
((equal? type 'float) (get-ffi-type-float))
|
||||
((equal? type 'double) (get-ffi-type-double))
|
||||
((equal? type 'void) (get-ffi-type-void))
|
||||
((equal? type 'pointer) (get-ffi-type-pointer))
|
||||
((equal? type 'callback) (get-ffi-type-pointer)))))
|
||||
|
||||
(define argument->pointer
|
||||
(lambda (value type)
|
||||
(cond ((procedure? value) (scheme-procedure-to-pointer value))
|
||||
(else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
|
||||
(pffi-pointer-set! pointer type 0 value)
|
||||
pointer)))))
|
||||
|
||||
(define make-c-function
|
||||
(lambda (shared-object c-name return-type argument-types)
|
||||
(dlerror) ;; Clean all previous errors
|
||||
(let ((c-function (dlsym shared-object c-name))
|
||||
(maybe-dlerror (dlerror)))
|
||||
(when (not (pffi-pointer-null? maybe-dlerror))
|
||||
(error (pffi-pointer->string maybe-dlerror)))
|
||||
(lambda arguments
|
||||
(let ((return-value (pffi-pointer-allocate
|
||||
(if (equal? return-type 'void)
|
||||
0
|
||||
(size-of-type return-type)))))
|
||||
(internal-ffi-call (length argument-types)
|
||||
(pffi-type->libffi-type return-type)
|
||||
(map pffi-type->libffi-type argument-types)
|
||||
c-function
|
||||
return-value
|
||||
(map argument->pointer
|
||||
arguments
|
||||
argument-types))
|
||||
(cond ((not (equal? return-type 'void))
|
||||
(pffi-pointer-get return-value return-type 0))))))))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(symbol->string c-name)
|
||||
return-type
|
||||
argument-types)))))
|
||||
|
||||
(define make-c-callback
|
||||
(lambda (return-type argument-types procedure)
|
||||
(scheme-procedure-to-pointer procedure)))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback return-type 'argument-types procedure)))))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,281 @@
|
|||
; vim: ft=scheme
|
||||
|
||||
(c-system-include "stdint.h")
|
||||
(c-system-include "dlfcn.h")
|
||||
(c-system-include "ffi.h")
|
||||
|
||||
;; pffi-size-of
|
||||
(c-declare "
|
||||
int size_of_int8_t() { return sizeof(int8_t); }
|
||||
int size_of_uint8_t() { return sizeof(uint8_t); }
|
||||
int size_of_int16_t() { return sizeof(int16_t); }
|
||||
int size_of_uint16_t() { return sizeof(uint16_t); }
|
||||
int size_of_int32_t() { return sizeof(int32_t); }
|
||||
int size_of_uint32_t() { return sizeof(uint32_t); }
|
||||
int size_of_int64_t() { return sizeof(int64_t); }
|
||||
int size_of_uint64_t() { return sizeof(uint64_t); }
|
||||
int size_of_char() { return sizeof(char); }
|
||||
int size_of_unsigned_char() { return sizeof(unsigned char); }
|
||||
int size_of_short() { return sizeof(short); }
|
||||
int size_of_unsigned_short() { return sizeof(unsigned short); }
|
||||
int size_of_int() { return sizeof(int); }
|
||||
int size_of_unsigned_int() { return sizeof(unsigned int); }
|
||||
int size_of_long() { return sizeof(long); }
|
||||
int size_of_unsigned_long() { return sizeof(unsigned long); }
|
||||
int size_of_float() { return sizeof(float); }
|
||||
int size_of_double() { return sizeof(double); }
|
||||
int size_of_pointer() { return sizeof(void*); }
|
||||
")
|
||||
|
||||
(define-c int (size-of-int8_t size_of_int8_t) ())
|
||||
(define-c int (size-of-uint8_t size_of_uint8_t) ())
|
||||
(define-c int (size-of-int16_t size_of_int16_t) ())
|
||||
(define-c int (size-of-uint16_t size_of_uint16_t) ())
|
||||
(define-c int (size-of-int32_t size_of_int32_t) ())
|
||||
(define-c int (size-of-uint32_t size_of_uint32_t) ())
|
||||
(define-c int (size-of-int64_t size_of_int64_t) ())
|
||||
(define-c int (size-of-uint64_t size_of_uint64_t) ())
|
||||
(define-c int (size-of-char size_of_char) ())
|
||||
(define-c int (size-of-unsigned-char size_of_unsigned_char) ())
|
||||
(define-c int (size-of-short size_of_short) ())
|
||||
(define-c int (size-of-unsigned-short size_of_unsigned_short) ())
|
||||
(define-c int (size-of-int size_of_int) ())
|
||||
(define-c int (size-of-unsigned-int size_of_unsigned_int) ())
|
||||
(define-c int (size-of-long size_of_long) ())
|
||||
(define-c int (size-of-unsigned-long size_of_unsigned_long) ())
|
||||
(define-c int (size-of-float size_of_float) ())
|
||||
(define-c int (size-of-double size_of_double) ())
|
||||
(define-c int (size-of-pointer size_of_pointer) ())
|
||||
|
||||
;; pffi-shape-object-load
|
||||
(define-c-const int (RTLD-NOW "RTLD_NOW"))
|
||||
(define-c (maybe-null pointer void*) dlopen (string int))
|
||||
(define-c (maybe-null pointer void*) dlerror ())
|
||||
|
||||
(c-declare "void* pointer_null() { return NULL; }")
|
||||
(define-c (pointer void*) (pointer-null pointer_null) ())
|
||||
|
||||
(c-declare "int is_pointer_null(void* pointer) { if(pointer == NULL) { return 1; } else { return 0; }; }")
|
||||
(define-c bool (is-pointer-null is_pointer_null) ((maybe-null pointer void*)))
|
||||
|
||||
(c-declare "void* pointer_allocate(int size) { return malloc(size); }")
|
||||
(define-c (maybe-null pointer void*) (pointer-allocate pointer_allocate) (int))
|
||||
|
||||
(c-declare "sexp is_pointer(struct sexp_struct* object) {
|
||||
if(sexp_cpointerp(object)) {
|
||||
return SEXP_TRUE;
|
||||
} else {
|
||||
return SEXP_FALSE;
|
||||
}
|
||||
}")
|
||||
(define-c sexp (pointer? is_pointer) (sexp))
|
||||
|
||||
(c-declare "intptr_t pointer_address(struct sexp_struct* pointer) {
|
||||
return (intptr_t)&sexp_cpointer_value(pointer);
|
||||
}")
|
||||
(define-c uint32_t (pointer-address pointer_address) (sexp))
|
||||
|
||||
(c-declare "void pointer_free(void* pointer) { free(pointer); }")
|
||||
(define-c void (pointer-free pointer_free) ((maybe-null pointer void*)))
|
||||
|
||||
;; pffi-pointer-set!
|
||||
(c-declare "void pointer_set_c_int8_t(void* pointer, int offset, int8_t value) { *(int8_t*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-int8_t! pointer_set_c_int8_t) ((pointer void*) int int8_t))
|
||||
(c-declare "void pointer_set_c_uint8_t(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-uint8_t! pointer_set_c_uint8_t) ((pointer void*) int uint8_t))
|
||||
|
||||
(c-declare "void pointer_set_c_int16_t(void* pointer, int offset, int16_t value) { *(int16_t*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-int16_t! pointer_set_c_int16_t) ((pointer void*) int int16_t))
|
||||
(c-declare "void pointer_set_c_uint16_t(void* pointer, int offset, uint16_t value) { *(uint16_t*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-uint16_t! pointer_set_c_uint16_t) ((pointer void*) int uint16_t))
|
||||
|
||||
(c-declare "void pointer_set_c_int32_t(void* pointer, int offset, int32_t value) { *(int32_t*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-int32_t! pointer_set_c_int32_t) ((pointer void*) int int32_t))
|
||||
(c-declare "void pointer_set_c_uint32_t(void* pointer, int offset, uint32_t value) { *(uint32_t*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-uint32_t! pointer_set_c_uint32_t) ((pointer void*) int uint32_t))
|
||||
|
||||
(c-declare "void pointer_set_c_int64_t(void* pointer, int offset, int64_t value) { *(int64_t*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-int64_t! pointer_set_c_int64_t) ((pointer void*) int int64_t))
|
||||
(c-declare "void pointer_set_c_uint64_t(void* pointer, int offset, uint64_t value) { *(uint64_t*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-uint64_t! pointer_set_c_uint64_t) ((pointer void*) int uint64_t))
|
||||
|
||||
(c-declare "void pointer_set_c_char(void* pointer, int offset, char value) { *((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int char))
|
||||
(c-declare "void pointer_set_c_unsigned_char(void* pointer, int offset, unsigned char value) { *(unsigned char*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-unsigned-char! pointer_set_c_unsigned_char) ((pointer void*) int unsigned-char))
|
||||
|
||||
(c-declare "void pointer_set_c_short(void* pointer, int offset, short value) { *(short*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-short! pointer_set_c_short) ((pointer void*) int short))
|
||||
(c-declare "void pointer_set_c_unsigned_short(void* pointer, int offset, unsigned short value) { *(unsigned short*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-unsigned-short! pointer_set_c_unsigned_short) ((pointer void*) int unsigned-short))
|
||||
|
||||
(c-declare "void pointer_set_c_int(void* pointer, int offset, int value) { *(int*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-int! pointer_set_c_int) ((pointer void*) int int))
|
||||
(c-declare "void pointer_set_c_unsigned_int(void* pointer, int offset, unsigned int value) { *(unsigned int*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-unsigned-int! pointer_set_c_unsigned_int) ((pointer void*) int unsigned-int))
|
||||
|
||||
(c-declare "void pointer_set_c_long(void* pointer, int offset, long value) { *(long*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-long! pointer_set_c_long) ((pointer void*) int long))
|
||||
(c-declare "void pointer_set_c_unsigned_long(void* pointer, int offset, unsigned long value) { *(unsigned long*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-unsigned-long! pointer_set_c_unsigned_long) ((pointer void*) int unsigned-long))
|
||||
|
||||
(c-declare "void pointer_set_c_float(void* pointer, int offset, float value) { *(float*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-float! pointer_set_c_float) ((pointer void*) int float))
|
||||
|
||||
(c-declare "void pointer_set_c_double(void* pointer, int offset, double value) { *(double*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (pointer-set-c-double! pointer_set_c_double) ((pointer void*) int double))
|
||||
|
||||
(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }")
|
||||
(define-c void (pointer-set-c-pointer! pointer_set_c_pointer) ((pointer void*) int (maybe-null pointer void*)))
|
||||
|
||||
;; pffi-pointer-get
|
||||
(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }")
|
||||
(define-c int8_t (pointer-ref-c-int8_t pointer_ref_c_int8_t) ((pointer void*) int))
|
||||
(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { return *(uint8_t*)((char*)pointer + offset); }")
|
||||
(define-c uint8_t (pointer-ref-c-uint8_t pointer_ref_c_uint8_t) ((pointer void*) int))
|
||||
|
||||
(c-declare "int16_t pointer_ref_c_int16_t(void* pointer, int offset) { return *(int16_t*)((char*)pointer + offset); }")
|
||||
(define-c int16_t (pointer-ref-c-int16_t pointer_ref_c_int16_t) ((pointer void*) int))
|
||||
(c-declare "uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { return *(uint16_t*)((char*)pointer + offset); }")
|
||||
(define-c uint16_t (pointer-ref-c-uint16_t pointer_ref_c_uint16_t) ((pointer void*) int))
|
||||
|
||||
(c-declare "int32_t pointer_ref_c_int32_t(void* pointer, int offset) { return *(int32_t*)((char*)pointer + offset); }")
|
||||
(define-c int32_t (pointer-ref-c-int32_t pointer_ref_c_int32_t) ((pointer void*) int))
|
||||
(c-declare "uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { return *(uint32_t*)((char*)pointer + offset); }")
|
||||
(define-c uint32_t (pointer-ref-c-uint32_t pointer_ref_c_uint32_t) ((pointer void*) int))
|
||||
|
||||
(c-declare "int64_t pointer_ref_c_int64_t(void* pointer, int offset) { return *(int64_t*)((char*)pointer + offset); }")
|
||||
(define-c int64_t (pointer-ref-c-int64_t pointer_ref_c_int64_t) ((pointer void*) int))
|
||||
(c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { return *(uint64_t*)((char*)pointer + offset); }")
|
||||
(define-c uint64_t (pointer-ref-c-uint64_t pointer_ref_c_uint64_t) ((pointer void*) int))
|
||||
|
||||
(c-declare "char pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); }")
|
||||
(define-c char (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int))
|
||||
(c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { return *(unsigned char*)((char*)pointer + offset); }")
|
||||
(define-c unsigned-char (pointer-ref-c-unsigned-char pointer_ref_c_unsigned_char) ((pointer void*) int))
|
||||
|
||||
(c-declare "short pointer_ref_c_short(void* pointer, int offset) { return *(short*)((char*)pointer + offset); }")
|
||||
(define-c short (pointer-ref-c-short pointer_ref_c_short) ((pointer void*) int))
|
||||
(c-declare "unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { return *(unsigned short*)((char*)pointer + offset); }")
|
||||
(define-c unsigned-short (pointer-ref-c-unsigned-short pointer_ref_c_unsigned_short) ((pointer void*) int))
|
||||
|
||||
(c-declare "int pointer_ref_c_int(void* pointer, int offset) { return *(int*)((char*)pointer + offset); }")
|
||||
(define-c int (pointer-ref-c-int pointer_ref_c_int) ((pointer void*) int))
|
||||
(c-declare "unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { return *(unsigned int*)((char*)pointer + offset); }")
|
||||
(define-c unsigned-int (pointer-ref-c-unsigned-int pointer_ref_c_unsigned_int) ((pointer void*) int))
|
||||
|
||||
(c-declare "long pointer_ref_c_long(void* pointer, int offset) { return *(long*)((char*)pointer + offset); }")
|
||||
(define-c long (pointer-ref-c-long pointer_ref_c_long) ((pointer void*) long))
|
||||
(c-declare "unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { return *(unsigned long*)((char*)pointer + offset); }")
|
||||
(define-c unsigned-long (pointer-ref-c-unsigned-long pointer_ref_c_unsigned_long) ((pointer void*) int))
|
||||
|
||||
(c-declare "float pointer_ref_c_float(void* pointer, int offset) { return *(float*)((char*)pointer + offset); }")
|
||||
(define-c float (pointer-ref-c-float pointer_ref_c_float) ((pointer void*) int))
|
||||
|
||||
(c-declare "double pointer_ref_c_double(void* pointer, int offset) { return *(double*)((char*)pointer + offset); }")
|
||||
(define-c double (pointer-ref-c-double pointer_ref_c_double) ((pointer void*) int))
|
||||
|
||||
(c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }")
|
||||
(define-c (maybe-null pointer void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int))
|
||||
|
||||
;; pffi-string->pointer
|
||||
;(c-declare "void* string_to_pointer(char* string) { return (void*)string; }")
|
||||
;(define-c (maybe-null pointer void*) (string-to-pointer string_to_pointer) (string))
|
||||
|
||||
;; pffi-pointer->string
|
||||
;(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }")
|
||||
;(define-c string (pointer-to-string pointer_to_string) ((maybe-null pointer void*)))
|
||||
|
||||
;; pffi-define
|
||||
|
||||
(c-declare "ffi_cif cif;")
|
||||
(define-c (pointer void*) dlsym ((maybe-null pointer void*) string))
|
||||
|
||||
(c-declare "void* get_ffi_type_int8() { return &ffi_type_sint8; }")
|
||||
(define-c (pointer void*) (get-ffi-type-int8 get_ffi_type_int8) ())
|
||||
(c-declare "void* get_ffi_type_uint8() { return &ffi_type_uint8; }")
|
||||
(define-c (pointer void*) (get-ffi-type-uint8 get_ffi_type_uint8) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_int16() { return &ffi_type_sint16; }")
|
||||
(define-c (pointer void*) (get-ffi-type-int16 get_ffi_type_int16) ())
|
||||
(c-declare "void* get_ffi_type_uint16() { return &ffi_type_uint16; }")
|
||||
(define-c (pointer void*) (get-ffi-type-uint16 get_ffi_type_uint16) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_int32() { return &ffi_type_sint32; }")
|
||||
(define-c (pointer void*) (get-ffi-type-int32 get_ffi_type_int32) ())
|
||||
(c-declare "void* get_ffi_type_uint32() { return &ffi_type_uint32; }")
|
||||
(define-c (pointer void*) (get-ffi-type-uint32 get_ffi_type_uint32) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_int64() { return &ffi_type_sint64; }")
|
||||
(define-c (pointer void*) (get-ffi-type-int64 get_ffi_type_int64) ())
|
||||
(c-declare "void* get_ffi_type_uint64() { return &ffi_type_uint64; }")
|
||||
(define-c (pointer void*) (get-ffi-type-uint64 get_ffi_type_uint64) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_char() { return &ffi_type_schar; }")
|
||||
(define-c (pointer void*) (get-ffi-type-char get_ffi_type_char) ())
|
||||
(c-declare "void* get_ffi_type_uchar() { return &ffi_type_uchar; }")
|
||||
(define-c (pointer void*) (get-ffi-type-uchar get_ffi_type_uchar) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_short() { return &ffi_type_sshort; }")
|
||||
(define-c (pointer void*) (get-ffi-type-short get_ffi_type_short) ())
|
||||
(c-declare "void* get_ffi_type_ushort() { return &ffi_type_ushort; }")
|
||||
(define-c (pointer void*) (get-ffi-type-ushort get_ffi_type_ushort) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_int() { return &ffi_type_sint; }")
|
||||
(define-c (pointer void*) (get-ffi-type-int get_ffi_type_int) ())
|
||||
(c-declare "void* get_ffi_type_uint() { return &ffi_type_uint; }")
|
||||
(define-c (pointer void*) (get-ffi-type-uint get_ffi_type_uint) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_long() { return &ffi_type_slong; }")
|
||||
(define-c (pointer void*) (get-ffi-type-long get_ffi_type_long) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_ulong() { return &ffi_type_ulong; }")
|
||||
(define-c (pointer void*) (get-ffi-type-ulong get_ffi_type_ulong) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_float() { return &ffi_type_float; }")
|
||||
(define-c (pointer void*) (get-ffi-type-float get_ffi_type_float) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_double() { return &ffi_type_double; }")
|
||||
(define-c (pointer void*) (get-ffi-type-double get_ffi_type_double) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_void() { return &ffi_type_void; }")
|
||||
(define-c (pointer void*) (get-ffi-type-void get_ffi_type_void) ())
|
||||
|
||||
(c-declare "void* get_ffi_type_pointer() { return &ffi_type_pointer; }")
|
||||
(define-c (pointer void*) (get-ffi-type-pointer get_ffi_type_pointer) ())
|
||||
|
||||
(define-c-const int (FFI-OK "FFI_OK"))
|
||||
(c-declare
|
||||
"int internal_ffi_prep_cif(unsigned int nargs, void* rtype, void* atypes[]) {
|
||||
printf(\"A1: %u, A2: %u, nargs: %u\\n\", &ffi_type_pointer, atypes[0], nargs);
|
||||
return ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
|
||||
}")
|
||||
(define-c int (internal-ffi-prep-cif internal_ffi_prep_cif) (unsigned-int (pointer void*) (array void*)))
|
||||
(c-declare
|
||||
"void internal_ffi_call(unsigned int nargs, void* rtype, void** atypes, void* fn, void* rvalue, struct sexp_struct* avalues[]) {
|
||||
ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
|
||||
void* c_avalues[nargs];
|
||||
for(int i = 0; i < nargs; i++) {
|
||||
c_avalues[i] = sexp_cpointer_value(avalues[i]);
|
||||
}
|
||||
ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues);
|
||||
}")
|
||||
(define-c void
|
||||
(internal-ffi-call internal_ffi_call)
|
||||
(unsigned-int
|
||||
(pointer void*)
|
||||
(array void*)
|
||||
(pointer void*)
|
||||
(pointer void*)
|
||||
(array sexp)))
|
||||
|
||||
(c-declare
|
||||
"void* scheme_procedure_to_pointer(sexp proc) {
|
||||
if(sexp_procedurep(proc) == 1) {
|
||||
return 0; //&sexp_unbox_fixnum(proc);
|
||||
} else {
|
||||
printf(\"NOT A FUNCTION\\n\");
|
||||
}
|
||||
return (void*)proc;
|
||||
}")
|
||||
(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp))
|
||||
|
|
@ -0,0 +1,249 @@
|
|||
|
||||
(define pffi-type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
((equal? type 'struct) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))) )
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((pffi-type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
((equal? type 'struct) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (list-ref expr 1))
|
||||
(c-name (symbol->string (cadr (list-ref expr 3))))
|
||||
(return-type (pffi-type->native-type (cadr (list-ref expr 4))))
|
||||
(argument-types (if (null? (cdr (list-ref expr 5)))
|
||||
(list)
|
||||
(map pffi-type->native-type
|
||||
(cadr (list-ref expr 5))))))
|
||||
(if (null? argument-types)
|
||||
`(define ,scheme-name
|
||||
(foreign-safe-lambda ,return-type ,c-name))
|
||||
`(define ,scheme-name
|
||||
(foreign-safe-lambda ,return-type ,c-name ,@ argument-types)))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((pffi-type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
((equal? type 'struct) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (list-ref expr 1))
|
||||
(return-type (pffi-type->native-type (cadr (list-ref expr 2))))
|
||||
(argument-types (map pffi-type->native-type (cadr (list-ref expr 3))))
|
||||
(argument-names (cadr (list-ref expr 4)))
|
||||
(arguments (map
|
||||
(lambda (name type)
|
||||
`(,name ,type))
|
||||
argument-types argument-names))
|
||||
(procedure-body (cdr (cdr (list-ref expr 4)))))
|
||||
`(begin (define-external ,(cons 'external_123456789 arguments)
|
||||
,return-type
|
||||
(begin ,@ procedure-body))
|
||||
(define ,scheme-name (location external_123456789)))))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int))
|
||||
((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int))
|
||||
((equal? type 'int16) (foreign-value "sizeof(int16_t)" int))
|
||||
((equal? type 'uint16) (foreign-value "sizeof(uint16_t)" int))
|
||||
((equal? type 'int32) (foreign-value "sizeof(int32_t)" int))
|
||||
((equal? type 'uint32) (foreign-value "sizeof(uint32_t)" int))
|
||||
((equal? type 'int64) (foreign-value "sizeof(int64_t)" int))
|
||||
((equal? type 'uint64) (foreign-value "sizeof(uint64_t)" int))
|
||||
((equal? type 'char) (foreign-value "sizeof(char)" int))
|
||||
((equal? type 'unsigned-char) (foreign-value "sizeof(unsigned char)" int))
|
||||
((equal? type 'short) (foreign-value "sizeof(short)" int))
|
||||
((equal? type 'unsigned-short) (foreign-value "sizeof(unsigned short)" int))
|
||||
((equal? type 'int) (foreign-value "sizeof(int)" int))
|
||||
((equal? type 'unsigned-int) (foreign-value "sizeof(unsigned int)" int))
|
||||
((equal? type 'long) (foreign-value "sizeof(long)" int))
|
||||
((equal? type 'unsigned-long) (foreign-value "sizeof(unsigned long)" int))
|
||||
((equal? type 'float) (foreign-value "sizeof(float)" int))
|
||||
((equal? type 'double) (foreign-value "sizeof(double)" int))
|
||||
((equal? type 'pointer) (foreign-value "sizeof(void*)" int))
|
||||
((equal? type 'string) (foreign-value "sizeof(void*)" int))
|
||||
((equal? type 'callback) (foreign-value "sizeof(void*)" int)))))
|
||||
|
||||
#;(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(allocate size)))
|
||||
|
||||
(define pffi-pointer-address
|
||||
(lambda (pointer)
|
||||
(pointer->address pointer)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(address->pointer 0)))
|
||||
|
||||
;(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
|
||||
;(pffi-define puts #f 'puts 'int (list 'pointer))
|
||||
;(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
|
||||
|
||||
#;(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(let* ((size (string-length string-content))
|
||||
(pointer (pffi-pointer-allocate (+ size 1))))
|
||||
(memset pointer 0 (+ size 1))
|
||||
(strncpy-ps pointer (location string-content) size)
|
||||
;(puts pointer)
|
||||
pointer)))
|
||||
|
||||
#;(define pffi-string->pointer
|
||||
(foreign-lambda* c-pointer
|
||||
((c-string str))
|
||||
"C_return((void*)str);"))
|
||||
|
||||
|
||||
;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
|
||||
;(pffi-define strlen #f 'strlen 'int (list 'pointer))
|
||||
|
||||
#;(define pffi-pointer->string
|
||||
(foreign-lambda* c-string
|
||||
((c-pointer p))
|
||||
"C_return((char*)p);"))
|
||||
|
||||
(define-syntax pffi-shared-object-load
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((headers (cadr (car (cdr expr)))))
|
||||
`(begin
|
||||
,@ (map
|
||||
(lambda (header)
|
||||
`(foreign-declare ,(string-append "#include <" header ">")))
|
||||
headers))))))
|
||||
|
||||
#;(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(if (not (pointer? pointer))
|
||||
(error "pffi-pointer-free -- Argument is not pointer" pointer))
|
||||
(free pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(if (and (not (pointer? pointer))
|
||||
pointer)
|
||||
#f
|
||||
(or (not pointer) ; #f counts as null pointer on Chicken
|
||||
(= (pointer->address pointer) 0)))))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond
|
||||
((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) (char->integer value)))
|
||||
((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'float) (pointer-f32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value))))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond
|
||||
((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset)))
|
||||
((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset)))
|
||||
((equal? type 'int16) (pointer-s16-ref (pointer+ pointer offset)))
|
||||
((equal? type 'uint16) (pointer-u16-ref (pointer+ pointer offset)))
|
||||
((equal? type 'int32) (pointer-s32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset)))
|
||||
((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset)))
|
||||
((equal? type 'char) (integer->char (pointer-s8-ref (pointer+ pointer offset))))
|
||||
((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset)))
|
||||
((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset)))
|
||||
((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
|
||||
((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))))))
|
||||
|
||||
(define pffi-struct-dereference
|
||||
(lambda (struct)
|
||||
(pffi-pointer-address (pffi-struct-pointer struct))))
|
||||
|
||||
|
|
@ -0,0 +1,376 @@
|
|||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) int)
|
||||
((equal? type 'uint8) int)
|
||||
((equal? type 'int16) int)
|
||||
((equal? type 'uint16) int)
|
||||
((equal? type 'int32) int)
|
||||
((equal? type 'uint32) int)
|
||||
((equal? type 'int64) int)
|
||||
((equal? type 'uint64) int)
|
||||
((equal? type 'char) char)
|
||||
((equal? type 'unsigned-char) char)
|
||||
((equal? type 'short) int)
|
||||
((equal? type 'unsigned-short) int)
|
||||
((equal? type 'int) int)
|
||||
((equal? type 'unsigned-int) int)
|
||||
((equal? type 'long) int)
|
||||
((equal? type 'unsigned-long) int)
|
||||
((equal? type 'float) float)
|
||||
((equal? type 'double) double)
|
||||
((equal? type 'pointer) opaque)
|
||||
((equal? type 'void) c-void)
|
||||
((equal? type 'struct) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(opaque? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'struct) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (car (cdr expr)))
|
||||
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
|
||||
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(argument-types
|
||||
(let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(if (null? types)
|
||||
'()
|
||||
(map pffi-type->native-type (map car (map cdr types)))))))
|
||||
(if (null? argument-types)
|
||||
`(c-define ,scheme-name ,return-type ,c-name)
|
||||
`(c-define ,scheme-name
|
||||
,return-type ,c-name ,@ argument-types))))))
|
||||
|
||||
(define pffi-define-callback
|
||||
(lambda (scheme-name return-type argument-types procedure)
|
||||
(error "pffi-define-callback not yet implemented on Cyclone")))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int))
|
||||
((equal? type 'uint8) (c-value "sizeof(uint8_t)" int))
|
||||
((equal? type 'int16) (c-value "sizeof(int16_t)" int))
|
||||
((equal? type 'uint16) (c-value "sizeof(uint16_t)" int))
|
||||
((equal? type 'int32) (c-value "sizeof(int32_t)" int))
|
||||
((equal? type 'uint32) (c-value "sizeof(uint32_t)" int))
|
||||
((equal? type 'int64) (c-value "sizeof(int64_t)" int))
|
||||
((equal? type 'uint64) (c-value "sizeof(uint64_t)" int))
|
||||
((equal? type 'char) (c-value "sizeof(char)" int))
|
||||
((equal? type 'unsigned-char) (c-value "sizeof(unsigned char)" int))
|
||||
((equal? type 'short) (c-value "sizeof(short)" int))
|
||||
((equal? type 'unsigned-short) (c-value "sizeof(unsigned short)" int))
|
||||
((equal? type 'int) (c-value "sizeof(int)" int))
|
||||
((equal? type 'unsigned-int) (c-value "sizeof(unsigned int)" int))
|
||||
((equal? type 'long) (c-value "sizeof(long)" int))
|
||||
((equal? type 'unsigned-long) (c-value "sizeof(unsigned long)" int))
|
||||
((equal? type 'float) (c-value "sizeof(float)" int))
|
||||
((equal? type 'double) (c-value "sizeof(double)" int))
|
||||
((equal? type 'pointer) (c-value "sizeof(void*)" int)))))
|
||||
|
||||
#;(define-c pffi-pointer-allocate
|
||||
"(void *data, int argc, closure _, object k, object size)"
|
||||
"make_c_opaque(opq, malloc(obj_obj2int(size)));
|
||||
return_closcall1(data, k, &opq);")
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(make-opaque)))
|
||||
|
||||
#;(define-c pffi-string->pointer
|
||||
"(void *data, int argc, closure _, object k, object s)"
|
||||
"make_c_opaque(opq, string_str(s));
|
||||
return_closcall1(data, k, &opq);")
|
||||
|
||||
#;(define-c pffi-pointer->string
|
||||
"(void *data, int argc, closure _, object k, object p)"
|
||||
"make_string(s, opaque_ptr(p));
|
||||
return_closcall1(data, k, &s);")
|
||||
|
||||
(define-syntax pffi-shared-object-load
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
`(begin
|
||||
,@ (map
|
||||
(lambda (header)
|
||||
`(include-c-header ,(string-append "<" header ">")))
|
||||
(cdr (car (cdr expr))))))))
|
||||
|
||||
#;(define-c pffi-pointer-free
|
||||
"(void *data, int argc, closure _, object k, object pointer)"
|
||||
"free(opaque_ptr(pointer));
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(and (opaque? pointer)
|
||||
(opaque-null? pointer))))
|
||||
|
||||
(define-c pffi-pointer-int8-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-uint8-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-int16-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-uint16-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-int32-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-uint32-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-int64-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-uint64-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-char-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"char* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2char(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-short-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-unsigned-short-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-int-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-unsigned-int-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-long-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-unsigned-long-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-float-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"float* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = double_value(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-double-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"double* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = double_value(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c pffi-pointer-pointer-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"uintptr_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = (uintptr_t)&opaque_ptr(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond
|
||||
((equal? type 'int8) (pffi-pointer-int8-set! pointer offset value))
|
||||
((equal? type 'uint8) (pffi-pointer-uint8-set! pointer offset value))
|
||||
((equal? type 'int16) (pffi-pointer-int16-set! pointer offset value))
|
||||
((equal? type 'uint16) (pffi-pointer-uint16-set! pointer offset value))
|
||||
((equal? type 'int32) (pffi-pointer-int32-set! pointer offset value))
|
||||
((equal? type 'uint32) (pffi-pointer-uint32-set! pointer offset value))
|
||||
((equal? type 'int64) (pffi-pointer-int64-set! pointer offset value))
|
||||
((equal? type 'uint64) (pffi-pointer-uint64-set! pointer offset value))
|
||||
((equal? type 'char) (pffi-pointer-char-set! pointer offset value))
|
||||
((equal? type 'short) (pffi-pointer-short-set! pointer offset value))
|
||||
((equal? type 'unsigned-short) (pffi-pointer-unsigned-short-set! pointer offset value))
|
||||
((equal? type 'int) (pffi-pointer-int-set! pointer offset value))
|
||||
((equal? type 'unsigned-int) (pffi-pointer-unsigned-int-set! pointer offset value))
|
||||
((equal? type 'long) (pffi-pointer-long-set! pointer offset value))
|
||||
((equal? type 'unsigned-long) (pffi-pointer-unsigned-long-set! pointer offset value))
|
||||
((equal? type 'float) (pffi-pointer-float-set! pointer offset value))
|
||||
((equal? type 'double) (pffi-pointer-double-set! pointer offset value))
|
||||
((equal? type 'pointer) (pffi-pointer-pointer-set! pointer offset value)))))
|
||||
|
||||
(define-c pffi-pointer-int8-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-uint8-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-int16-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-uint16-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-int32-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-uint32-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-int64-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-uint64-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-char-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"char* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_char2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-short-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-unsigned-short-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-int-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-unsigned-int-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-long-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-unsigned-long-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
return_closcall1(data, k, obj_int2obj(*p));")
|
||||
|
||||
(define-c pffi-pointer-float-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"float* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
alloca_double(d, *p);
|
||||
return_closcall1(data, k, d);")
|
||||
|
||||
(define-c pffi-pointer-double-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"double* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
alloca_double(d, *p);
|
||||
return_closcall1(data, k, d);")
|
||||
|
||||
(define-c pffi-pointer-pointer-get
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||
"make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset));
|
||||
return_closcall1(data, k, &opq);")
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond
|
||||
((equal? type 'int8) (pffi-pointer-int8-get pointer offset))
|
||||
((equal? type 'uint8) (pffi-pointer-uint8-get pointer offset))
|
||||
((equal? type 'int16) (pffi-pointer-int16-get pointer offset))
|
||||
((equal? type 'uint16) (pffi-pointer-uint16-get pointer offset))
|
||||
((equal? type 'int32) (pffi-pointer-int32-get pointer offset))
|
||||
((equal? type 'uint32) (pffi-pointer-uint32-get pointer offset))
|
||||
((equal? type 'int64) (pffi-pointer-int64-get pointer offset))
|
||||
((equal? type 'uint64) (pffi-pointer-uint64-get pointer offset))
|
||||
((equal? type 'char) (pffi-pointer-char-get pointer offset))
|
||||
((equal? type 'short) (pffi-pointer-short-get pointer offset))
|
||||
((equal? type 'unsigned-short) (pffi-pointer-unsigned-short-get pointer offset))
|
||||
((equal? type 'int) (pffi-pointer-int-get pointer offset))
|
||||
((equal? type 'unsigned-int) (pffi-pointer-unsigned-int-get pointer offset))
|
||||
((equal? type 'long) (pffi-pointer-long-get pointer offset))
|
||||
((equal? type 'unsigned-long) (pffi-pointer-unsigned-long-get pointer offset))
|
||||
((equal? type 'float) (pffi-pointer-float-get pointer offset))
|
||||
((equal? type 'double) (pffi-pointer-double-get pointer offset))
|
||||
((equal? type 'pointer) (pffi-pointer-pointer-get pointer offset)))))
|
||||
|
|
@ -0,0 +1,197 @@
|
|||
(c-declare "#include <stdlib.h>")
|
||||
(c-declare "#include <stdint.h>")
|
||||
|
||||
(define-macro
|
||||
(pffi-init)
|
||||
`(begin (c-define-type pointer (pointer void))
|
||||
(c-define-type callback (pointer void))))
|
||||
|
||||
(define size-of-int8_t (c-lambda () int "___return(sizeof(int8_t));"))
|
||||
(define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_t));"))
|
||||
(define size-of-int16_t (c-lambda () int "___return(sizeof(int16_t));"))
|
||||
(define size-of-uint16_t (c-lambda () int "___return(sizeof(uint16_t));"))
|
||||
(define size-of-int32_t (c-lambda () int "___return(sizeof(int32_t));"))
|
||||
(define size-of-uint32_t (c-lambda () int "___return(sizeof(uint32_t));"))
|
||||
(define size-of-int64_t (c-lambda () int "___return(sizeof(int64_t));"))
|
||||
(define size-of-uint64_t (c-lambda () int "___return(sizeof(uint64_t));"))
|
||||
(define size-of-char (c-lambda () int "___return(sizeof(char));"))
|
||||
(define size-of-unsigned-char (c-lambda () int "___return(sizeof(unsigned char));"))
|
||||
(define size-of-short (c-lambda () int "___return(sizeof(short));"))
|
||||
(define size-of-unsigned-short (c-lambda () int "___return(sizeof(unsigned short));"))
|
||||
(define size-of-int (c-lambda () int "___return(sizeof(int));"))
|
||||
(define size-of-unsigned-int (c-lambda () int "___return(sizeof(unsigned int));"))
|
||||
(define size-of-long (c-lambda () int "___return(sizeof(long));"))
|
||||
(define size-of-unsigned-long (c-lambda () int "___return(sizeof(unsigned long));"))
|
||||
(define size-of-float (c-lambda () int "___return(sizeof(float));"))
|
||||
(define size-of-double (c-lambda () int "___return(sizeof(double));"))
|
||||
(define size-of-void* (c-lambda () int "___return(sizeof(void*));"))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) (size-of-int8_t))
|
||||
((eq? type 'uint8) (size-of-uint8_t))
|
||||
((eq? type 'int16) (size-of-int16_t))
|
||||
((eq? type 'uint16) (size-of-uint16_t))
|
||||
((eq? type 'int32) (size-of-int32_t))
|
||||
((eq? type 'uint32) (size-of-uint32_t))
|
||||
((eq? type 'int64) (size-of-int64_t))
|
||||
((eq? type 'uint64) (size-of-uint64_t))
|
||||
((eq? type 'char) (size-of-char))
|
||||
((eq? type 'unsigned-char) (size-of-char))
|
||||
((eq? type 'short) (size-of-short))
|
||||
((eq? type 'unsigned-short) (size-of-unsigned-short))
|
||||
((eq? type 'int) (size-of-int))
|
||||
((eq? type 'unsigned-int) (size-of-unsigned-int))
|
||||
((eq? type 'long) (size-of-long))
|
||||
((eq? type 'unsigned-long) (size-of-unsigned-long))
|
||||
((eq? type 'float) (size-of-float))
|
||||
((eq? type 'double) (size-of-double))
|
||||
((eq? type 'pointer) (size-of-void*))
|
||||
((eq? type 'callback) (size-of-void*))
|
||||
((eq? type 'void) (size-of-void*))
|
||||
(else (error "Can not get size of unknown type" type)))))
|
||||
|
||||
(define-macro
|
||||
(pffi-define-library name headers object-name . options)
|
||||
`(begin (define ,name #t)
|
||||
(c-declare ,(apply string-append
|
||||
(map
|
||||
(lambda (header)
|
||||
(string-append "#include <" header ">" (string #\newline)))
|
||||
(cdr headers))))))
|
||||
|
||||
(define pointer? (c-lambda ((pointer void)) bool "___return(1);"))
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(call-with-current-continuation
|
||||
(lambda (k)
|
||||
(with-exception-handler
|
||||
(lambda (x) #f)
|
||||
(lambda () (pointer? object)))))))
|
||||
|
||||
(define pffi-pointer-null (c-lambda () (pointer void) "void* p = NULL; ___return(p);"))
|
||||
|
||||
(define pointer-null? (c-lambda ((pointer void)) bool "if(___arg1 == NULL) { ___return(1); } else { ___return(0); }"))
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(and (pffi-pointer? pointer)
|
||||
(pointer-null? pointer))))
|
||||
|
||||
;(define pffi-pointer-allocate (c-lambda (int) (pointer void) "void* p = malloc(___arg1); ___return(p);"))
|
||||
|
||||
(define pffi-pointer-address (c-lambda ((pointer void)) ptrdiff_t "void* p = ___arg1; ___return((intptr_t)&p);"))
|
||||
|
||||
;(define pffi-pointer-free (c-lambda ((pointer void)) void "free(___arg1);"))
|
||||
|
||||
(define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-int16_t! (c-lambda ((pointer void) int int16) void "*(int16_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-uint16_t! (c-lambda ((pointer void) int unsigned-int16) void "*(uint16_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-int32_t! (c-lambda ((pointer void) int int32) void "*(int32_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-uint32_t! (c-lambda ((pointer void) int unsigned-int32) void "*(uint32_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-int64_t! (c-lambda ((pointer void) int int64) void "*(int64_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-uint64_t! (c-lambda ((pointer void) int unsigned-int64) void "*(uint64_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-char! (c-lambda ((pointer void) int char) void "*((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-short! (c-lambda ((pointer void) int short) void "*(short*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-unsigned-short! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned short*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-int! (c-lambda ((pointer void) int int) void "*(int*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-unsigned-int! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned int*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-long! (c-lambda ((pointer void) int long) void "*(long*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-unsigned-long! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned long*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-float! (c-lambda ((pointer void) int float) void "*(float*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-double! (c-lambda ((pointer void) int double) void "*(double*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-pointer! (c-lambda ((pointer void) int (pointer void)) void "{ char* p = (char*)___arg1 + ___arg2; *(char**)p = ___arg3; }"))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
|
||||
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
|
||||
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
|
||||
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
|
||||
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
|
||||
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
|
||||
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
|
||||
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
|
||||
((equal? type 'char) (pointer-set-c-char! pointer offset value))
|
||||
((equal? type 'short) (pointer-set-c-short! pointer offset value))
|
||||
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
|
||||
((equal? type 'int) (pointer-set-c-int! pointer offset value))
|
||||
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
|
||||
((equal? type 'long) (pointer-set-c-long! pointer offset value))
|
||||
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
|
||||
((equal? type 'float) (pointer-set-c-float! pointer offset value))
|
||||
((equal? type 'double) (pointer-set-c-double! pointer offset value))
|
||||
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
|
||||
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
|
||||
|
||||
(define pointer-ref-c-int8_t (c-lambda ((pointer void) int) int8 "___return(*(int8_t*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-uint8_t (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-int16_t (c-lambda ((pointer void) int) int16 "___return(*(int16_t*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-uint16_t (c-lambda ((pointer void) int) unsigned-int16 "___return(*(uint16_t*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-int32_t (c-lambda ((pointer void) int) int32 "___return(*(int32_t*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-uint32_t (c-lambda ((pointer void) int) unsigned-int32 "___return(*(uint32_t*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-int64_t (c-lambda ((pointer void) int) int64 "___return(*(int64_t*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-uint64_t (c-lambda ((pointer void) int) unsigned-int64 "___return(*(uint64_t*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-char (c-lambda ((pointer void) int) char "___return(*((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-short (c-lambda ((pointer void) int) short "___return(*(short*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-unsigned-short (c-lambda ((pointer void) int) unsigned-short "___return(*(unsigned short*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-int (c-lambda ((pointer void) int) int "___return(*(int*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-unsigned-int (c-lambda ((pointer void) int) unsigned-int "___return(*(unsigned int*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-long (c-lambda ((pointer void) int) long "___return(*(long*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-unsigned-long (c-lambda ((pointer void) int) unsigned-long "___return(*(unsigned long*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-float (c-lambda ((pointer void) int) float "___return(*(float*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-double (c-lambda ((pointer void) int) double "___return(*(double*)((char*)___arg1 + ___arg2));"))
|
||||
(define pointer-ref-c-pointer (c-lambda ((pointer void) int) (pointer void) " char* p = (char*)___arg1 + ___arg2; ___return(*(char**)p);"))
|
||||
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
|
||||
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
|
||||
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
|
||||
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
|
||||
((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
|
||||
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
|
||||
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
|
||||
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
|
||||
((equal? type 'char) (pointer-ref-c-char pointer offset))
|
||||
((equal? type 'short) (pointer-ref-c-short pointer offset))
|
||||
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
|
||||
((equal? type 'int) (pointer-ref-c-int pointer offset))
|
||||
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
|
||||
((equal? type 'long) (pointer-ref-c-long pointer offset))
|
||||
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
|
||||
((equal? type 'float) (pointer-ref-c-float pointer offset))
|
||||
((equal? type 'double) (pointer-ref-c-double pointer offset))
|
||||
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
|
||||
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
|
||||
|
||||
(define-macro
|
||||
(pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(letrec* ((native-argument-types
|
||||
(if (equal? '(list) argument-types)
|
||||
(list)
|
||||
(let ((types (map cdr (cdr argument-types))))
|
||||
(if (null? types) types (map car types)))))
|
||||
(native-return-type (car (cdr return-type)))
|
||||
(c-arguments (lambda (index argument-count result)
|
||||
(if (> index argument-count)
|
||||
result
|
||||
(c-arguments (+ index 1)
|
||||
argument-count
|
||||
(string-append result
|
||||
"___arg"
|
||||
(number->string index)
|
||||
(if (< index argument-count)
|
||||
", "
|
||||
""))))))
|
||||
(c-code (string-append
|
||||
(if (equal? 'void (cadr return-type)) "" "___return(")
|
||||
(symbol->string (cadr c-name))
|
||||
"(" (c-arguments 1 (- (length argument-types) 1) "") ")"
|
||||
(if (equal? 'void (cadr return-type)) "" ")")
|
||||
";")))
|
||||
`(define ,scheme-name
|
||||
(c-lambda ,native-argument-types
|
||||
,native-return-type
|
||||
,c-code))))
|
||||
|
|
@ -0,0 +1,188 @@
|
|||
(define-module retropikzel.pffi.gauche
|
||||
(export size-of-type
|
||||
pffi-shared-object-load
|
||||
pffi-pointer-null
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-address
|
||||
pffi-pointer?
|
||||
pffi-pointer-free
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-define))
|
||||
|
||||
(select-module retropikzel.pffi.gauche)
|
||||
(dynamic-load "retropikzel/pffi/gauche-pffi")
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((equal? type 'int8) (size-of-int8))
|
||||
((equal? type 'uint8) (size-of-uint8))
|
||||
((equal? type 'int16) (size-of-int16))
|
||||
((equal? type 'uint16) (size-of-uint16))
|
||||
((equal? type 'int32) (size-of-int32))
|
||||
((equal? type 'uint32) (size-of-uint32))
|
||||
((equal? type 'int64) (size-of-int64))
|
||||
((equal? type 'uint64) (size-of-uint64))
|
||||
((equal? type 'char) (size-of-char))
|
||||
((equal? type 'unsigned-char) (size-of-unsigned-char))
|
||||
((equal? type 'short) (size-of-short))
|
||||
((equal? type 'unsigned-short) (size-of-unsigned-short))
|
||||
((equal? type 'int) (size-of-int))
|
||||
((equal? type 'unsigned-int) (size-of-unsigned-int))
|
||||
((equal? type 'long) (size-of-long))
|
||||
((equal? type 'unsigned-long) (size-of-unsigned-long))
|
||||
((equal? type 'float) (size-of-float))
|
||||
((equal? type 'double) (size-of-double))
|
||||
((equal? type 'string) (size-of-string))
|
||||
((equal? type 'pointer) (size-of-pointer))
|
||||
((equal? type 'void) (size-of-void)))))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (path options)
|
||||
(shared-object-load path)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(pointer-null)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(pointer-null? pointer)))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(pointer-allocate size)))
|
||||
|
||||
(define pffi-pointer-address
|
||||
(lambda (object)
|
||||
(pointer-address object)))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (pointer)
|
||||
(pointer? pointer)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(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-type->libffi-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) (get-ffi-type-int8))
|
||||
((equal? type 'uint8) (get-ffi-type-uint8))
|
||||
((equal? type 'int16) (get-ffi-type-int16))
|
||||
((equal? type 'uint16) (get-ffi-type-uint16))
|
||||
((equal? type 'int32) (get-ffi-type-int32))
|
||||
((equal? type 'uint32) (get-ffi-type-uint32))
|
||||
((equal? type 'int64) (get-ffi-type-int64))
|
||||
((equal? type 'uint64) (get-ffi-type-uint64))
|
||||
((equal? type 'char) (get-ffi-type-char))
|
||||
((equal? type 'unsigned-char) (get-ffi-type-uchar))
|
||||
((equal? type 'bool) (get-ffi-type-int8))
|
||||
((equal? type 'short) (get-ffi-type-short))
|
||||
((equal? type 'unsigned-short) (get-ffi-type-ushort))
|
||||
((equal? type 'int) (get-ffi-type-int))
|
||||
((equal? type 'unsigned-int) (get-ffi-type-uint))
|
||||
((equal? type 'long) (get-ffi-type-long))
|
||||
((equal? type 'unsigned-long) (get-ffi-type-ulong))
|
||||
((equal? type 'float) (get-ffi-type-float))
|
||||
((equal? type 'double) (get-ffi-type-double))
|
||||
((equal? type 'void) (get-ffi-type-void))
|
||||
((equal? type 'pointer) (get-ffi-type-pointer))
|
||||
((equal? type 'callback) (get-ffi-type-pointer)))))
|
||||
|
||||
(define argument->pointer
|
||||
(lambda (value type)
|
||||
(cond ((procedure? value) (scheme-procedure-to-pointer value))
|
||||
(else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
|
||||
(pffi-pointer-set! pointer type 0 value)
|
||||
pointer)))))
|
||||
|
||||
(define make-c-function
|
||||
(lambda (shared-object c-name return-type argument-types)
|
||||
(dlerror) ;; Clean all previous errors
|
||||
(let ((c-function (dlsym shared-object c-name))
|
||||
(maybe-dlerror (dlerror)))
|
||||
(when (not (pffi-pointer-null? maybe-dlerror))
|
||||
(error (pffi-pointer->string maybe-dlerror)))
|
||||
(lambda arguments
|
||||
(let ((return-value (pffi-pointer-allocate
|
||||
(if (equal? return-type 'void)
|
||||
0
|
||||
(size-of-type return-type)))))
|
||||
(internal-ffi-call (length argument-types)
|
||||
(pffi-type->libffi-type return-type)
|
||||
(map pffi-type->libffi-type argument-types)
|
||||
c-function
|
||||
return-value
|
||||
(map argument->pointer
|
||||
arguments
|
||||
argument-types))
|
||||
(cond ((not (equal? return-type 'void))
|
||||
(pffi-pointer-get return-value return-type 0))))))))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(symbol->string c-name)
|
||||
return-type
|
||||
argument-types)))))
|
||||
|
||||
(define make-c-callback
|
||||
(lambda (return-type argument-types procedure)
|
||||
(scheme-procedure-to-pointer procedure)))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback return-type 'argument-types procedure)))))
|
||||
|
|
@ -0,0 +1,692 @@
|
|||
#include <math.h>
|
||||
#include <stdint.h>
|
||||
#include <gauche.h>
|
||||
#include <gauche/extend.h>
|
||||
#include <gauche/module.h>
|
||||
#include <gauche/load.h>
|
||||
#include <gauche/number.h>
|
||||
#include <gauche/string.h>
|
||||
#include <gauche-pffi.h>
|
||||
#include <ffi.h>
|
||||
#include <dlfcn.h>
|
||||
|
||||
void print_pointer(ScmObj obj, ScmPort* sink, ScmWriteContext* G1788 SCM_UNUSED) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, obj);
|
||||
if(p == NULL) {
|
||||
Scm_Printf(sink, "<pffi-pointer: (null)>\n");
|
||||
} else {
|
||||
Scm_Printf(sink, "<pffi-pointer: %i>\n", &p);
|
||||
}
|
||||
}
|
||||
|
||||
void dprint_pointer(ScmObj obj, ScmPort* sink, ScmWriteContext* G1788 SCM_UNUSED) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, obj);
|
||||
if(p == NULL) {
|
||||
Scm_Printf(sink, "<DEBUG pffi-pointer: (null)>\n");
|
||||
} else {
|
||||
Scm_Printf(sink, "<DEBUG pffi-pointer: %i>\n", &p);
|
||||
}
|
||||
}
|
||||
|
||||
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;
|
||||
|
||||
ScmObj shared_object_load(ScmString* path) {
|
||||
const ScmStringBody* body = SCM_STRING_BODY(path);
|
||||
const char* c_path = SCM_STRING_BODY_START(body);
|
||||
void* shared_object = dlopen(c_path, RTLD_NOW);
|
||||
ScmClass* shared_object_class = Scm_MakeForeignPointerClass(module, "pffi-shared-object", print_pointer, NULL, 0);
|
||||
ScmObj scm_shared_object = Scm_MakeForeignPointer(shared_object_class, shared_object);
|
||||
return scm_shared_object;
|
||||
}
|
||||
|
||||
ScmObj pointer_null() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
ScmObj pointer = Scm_MakeForeignPointer(pointer_class, NULL);
|
||||
return pointer;
|
||||
}
|
||||
|
||||
ScmObj is_pointer_null(ScmObj pointer) {
|
||||
if(!Scm_TypeP(pointer, SCM_CLASS_FOREIGN_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* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
void* p = malloc(size);
|
||||
ScmObj pointer = Scm_MakeForeignPointer(pointer_class, p);
|
||||
return pointer;
|
||||
}
|
||||
|
||||
ScmObj pointer_address(ScmObj object) {
|
||||
if(!Scm_TypeP(object, SCM_CLASS_FOREIGN_POINTER)) {
|
||||
Scm_Error("Can only get pointer address of a pointer");
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, object);
|
||||
return SCM_MAKE_INT(&p);
|
||||
}
|
||||
|
||||
ScmObj is_pointer(ScmObj pointer) {
|
||||
if(Scm_TypeP(pointer, SCM_CLASS_FOREIGN_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));
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_int8(ScmObj pointer, int offset, int8_t value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(int8_t*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_uint8(ScmObj pointer, int offset, uint8_t value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(uint8_t*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_int16(ScmObj pointer, int offset, int16_t value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(int16_t*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_uint16(ScmObj pointer, int offset, uint16_t value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(uint16_t*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_int32(ScmObj pointer, int offset, int32_t value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(int32_t*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_uint32(ScmObj pointer, int offset, uint32_t value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(uint32_t*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_int64(ScmObj pointer, int offset, int64_t value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(int64_t*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_uint64(ScmObj pointer, int offset, uint64_t value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(uint64_t*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_char(ScmObj pointer, int offset, char value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(char*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_unsigned_char(ScmObj pointer, int offset, unsigned char value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(unsigned char*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_short(ScmObj pointer, int offset, short value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(short*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_unsigned_short(ScmObj pointer, int offset, unsigned short value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(unsigned short*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_int(ScmObj pointer, int offset, int value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(int*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_unsigned_int(ScmObj pointer, int offset, unsigned int value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(unsigned int*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_long(ScmObj pointer, int offset, long value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(long*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_unsigned_long(ScmObj pointer, int offset, unsigned long value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(unsigned long*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_float(ScmObj pointer, int offset, float value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(float*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_double(ScmObj pointer, int offset, double value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
*(double*)((char*)p + offset) = value;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_set_pointer(ScmObj pointer, int offset, ScmObj value) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* v = SCM_FOREIGN_POINTER_REF(void*, value);
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
char* p1 = (char*)p + offset;
|
||||
*(char**)p1 = v;
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_int8(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(int8_t*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_uint8(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(uint8_t*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_int16(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(int16_t*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_uint16(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(uint16_t*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_int32(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(int32_t*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_uint32(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(uint32_t*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_int64(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(int64_t*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_uint64(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(uint64_t*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_char(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(char*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_unsigned_char(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(unsigned char*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_short(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(short*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_unsigned_short(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(unsigned short*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_int(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(int*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_unsigned_int(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(unsigned int*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_long(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(long*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_unsigned_long(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return SCM_MAKE_INT(*(unsigned long*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_float(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return Scm_MakeFlonum(*(float*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_double(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
return Scm_MakeFlonum(*(double*)((char*)p + offset));
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_get_pointer(ScmObj pointer, int offset) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
char* p1 = (char*)p + offset;
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", dprint_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, (void*)*(char**)p1);
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj string_to_pointer(ScmObj string) {
|
||||
if(SCM_STRINGP(string)) {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, Scm_GetString(SCM_STRING(string)));
|
||||
} else {
|
||||
Scm_Error("Not a string: %S", string);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pointer_to_string(ScmObj pointer) {
|
||||
if(SCM_FOREIGN_POINTER_P(pointer)) {
|
||||
void* p = SCM_FOREIGN_POINTER_REF(void*, pointer);
|
||||
void* string = (char*)p;
|
||||
return Scm_MakeString(string, -1, -1, 0);
|
||||
} else {
|
||||
Scm_Error("Not a pointer: %S", pointer);
|
||||
}
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmObj pffi_dlerror() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
void* msg = dlerror();
|
||||
if(msg == NULL) {
|
||||
return Scm_MakeForeignPointer(pointer_class, NULL);
|
||||
} else {
|
||||
return Scm_MakeForeignPointer(pointer_class, msg);
|
||||
}
|
||||
}
|
||||
|
||||
ScmObj pffi_dlsym(ScmObj shared_object, ScmObj c_name) {
|
||||
|
||||
if(!SCM_FOREIGN_POINTER_P(shared_object)) {
|
||||
Scm_Error("Not a shared object: %S", shared_object);
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
if(!SCM_STRINGP(c_name)) {
|
||||
Scm_Error("Not a string: %S", c_name);
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
void* handle = SCM_FOREIGN_POINTER_REF(void*, shared_object);
|
||||
const ScmStringBody* body = SCM_STRING_BODY(c_name);
|
||||
const char* name = SCM_STRING_BODY_START(body);
|
||||
void* symbol = dlsym(handle, name);
|
||||
|
||||
if(symbol == NULL) {
|
||||
Scm_Error("Could not find function %S", c_name);
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, symbol);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_int8() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint8);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_uint8() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint8);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_int16() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint16);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_uint16() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint16);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_int32() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint32);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_uint32() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint32);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_int64() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint64);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_uint64() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint64);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_char() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_schar);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_unsigned_char() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uchar);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_short() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sshort);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_unsigned_short() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_ushort);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_int() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_unsigned_int() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_long() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_slong);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_unsigned_long() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_ulong);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_float() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_float);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_double() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_double);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_void() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_void);
|
||||
}
|
||||
|
||||
ScmObj get_ffi_type_pointer() {
|
||||
ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0);
|
||||
return Scm_MakeForeignPointer(pointer_class, &ffi_type_pointer);
|
||||
}
|
||||
|
||||
ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, ScmObj rvalue, ScmObj avalues) {
|
||||
|
||||
ffi_cif cif;
|
||||
|
||||
unsigned int c_nargs = SCM_INT_VALUE(nargs);
|
||||
ffi_type* c_rtype = SCM_FOREIGN_POINTER_REF(ffi_type*, rtype);
|
||||
int atypes_length = (int)Scm_Length(atypes);
|
||||
ffi_type* c_atypes[atypes_length];
|
||||
for(int i = 0; i < atypes_length; i++) {
|
||||
c_atypes[i] = SCM_FOREIGN_POINTER_REF(ffi_type*, Scm_ListRef(atypes, i, SCM_UNDEFINED));
|
||||
}
|
||||
int prep_status = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, c_nargs, c_rtype, c_atypes);
|
||||
|
||||
void* c_fn = SCM_FOREIGN_POINTER_REF(void*, fn);
|
||||
void* c_rvalue = SCM_FOREIGN_POINTER_REF(void*, rvalue);
|
||||
int avalues_length = (int)Scm_Length(avalues);
|
||||
void* c_avalues[avalues_length];
|
||||
for(int i = 0; i < avalues_length; i++) {
|
||||
ScmObj item = Scm_ListRef(avalues, i, SCM_UNDEFINED);
|
||||
void* pp = SCM_FOREIGN_POINTER_REF(void*, item);
|
||||
char* list_p = (char*)c_avalues + (sizeof(void) * i);
|
||||
c_avalues[i] = pp;
|
||||
}
|
||||
ffi_call(&cif, FFI_FN(c_fn), c_rvalue, c_avalues);
|
||||
|
||||
return SCM_UNDEFINED;
|
||||
}
|
||||
|
||||
/*
|
||||
ScmObj procedure_to_pointer(ScmObj procedure) {
|
||||
|
||||
return SCM_UNDEFINED;
|
||||
}*/
|
||||
|
||||
void Scm_Init_gauche_pffi(void)
|
||||
{
|
||||
SCM_INIT_EXTENSION(retropikzel.pffi.gauche);
|
||||
module = SCM_MODULE(SCM_FIND_MODULE("retropikzel.pffi.gauche", TRUE));
|
||||
Scm_Init_gauchelib();
|
||||
}
|
||||
|
|
@ -0,0 +1,102 @@
|
|||
(in-module retropikzel.pffi.gauche)
|
||||
|
||||
(inline-stub
|
||||
(.include "gauche-pffi.h")
|
||||
(define-cproc size-of-int8 () size_of_int8)
|
||||
(define-cproc size-of-uint8 () size_of_uint8)
|
||||
(define-cproc size-of-int16 () size_of_int16)
|
||||
(define-cproc size-of-uint16 () size_of_int16)
|
||||
(define-cproc size-of-int32 () size_of_int32)
|
||||
(define-cproc size-of-uint32 () size_of_int32)
|
||||
(define-cproc size-of-int64 () size_of_int64)
|
||||
(define-cproc size-of-uint64 () size_of_int64)
|
||||
(define-cproc size-of-char () size_of_char)
|
||||
(define-cproc size-of-unsigned-char () size_of_unsigned_char)
|
||||
(define-cproc size-of-short () size_of_short)
|
||||
(define-cproc size-of-unsigned-short () size_of_unsigned_short)
|
||||
(define-cproc size-of-int () size_of_int)
|
||||
(define-cproc size-of-unsigned-int () size_of_unsigned_int)
|
||||
(define-cproc size-of-long () size_of_long)
|
||||
(define-cproc size-of-unsigned-long () size_of_unsigned_long)
|
||||
(define-cproc size-of-float () size_of_float)
|
||||
(define-cproc size-of-double () size_of_double)
|
||||
(define-cproc size-of-string () size_of_string)
|
||||
(define-cproc size-of-pointer () size_of_pointer)
|
||||
(define-cproc size-of-void () size_of_void)
|
||||
(define-cproc shared-object-load (path::<string>) shared_object_load)
|
||||
(define-cproc pointer-null () pointer_null)
|
||||
(define-cproc pointer-null? (pointer) is_pointer_null)
|
||||
(define-cproc pointer-allocate (size::<int>) pointer_allocate)
|
||||
(define-cproc pointer-address (object) pointer_address)
|
||||
(define-cproc pointer? (pointer) is_pointer)
|
||||
(define-cproc pointer-free (pointer) pointer_free)
|
||||
|
||||
(define-cproc pointer-set-int8! (pointer offset::<int> value::<int8>) pointer_set_int8)
|
||||
(define-cproc pointer-set-uint8! (pointer offset::<int> value::<int8>) pointer_set_uint8)
|
||||
(define-cproc pointer-set-int16! (pointer offset::<int> value::<int16>) pointer_set_int16)
|
||||
(define-cproc pointer-set-uint16! (pointer offset::<int> value::<int16>) pointer_set_uint16)
|
||||
(define-cproc pointer-set-int32! (pointer offset::<int> value::<int32>) pointer_set_int32)
|
||||
(define-cproc pointer-set-uint32! (pointer offset::<int> value::<int32>) pointer_set_uint32)
|
||||
(define-cproc pointer-set-int64! (pointer offset::<int> value::<int64>) pointer_set_int64)
|
||||
(define-cproc pointer-set-uint64! (pointer offset::<int> value::<int64>) pointer_set_uint64)
|
||||
(define-cproc pointer-set-char! (pointer offset::<int> value::<char>) pointer_set_char)
|
||||
(define-cproc pointer-set-unsigned-char! (pointer offset::<int> value::<char>) pointer_set_unsigned_char)
|
||||
(define-cproc pointer-set-short! (pointer offset::<int> value::<short>) pointer_set_short)
|
||||
(define-cproc pointer-set-unsigned-short! (pointer offset::<int> value::<short>) pointer_set_unsigned_short)
|
||||
(define-cproc pointer-set-int! (pointer offset::<int> value::<int>) pointer_set_int)
|
||||
(define-cproc pointer-set-unsigned-int! (pointer offset::<int> value::<int>) pointer_set_unsigned_int)
|
||||
(define-cproc pointer-set-long! (pointer offset::<int> value::<long>) pointer_set_long)
|
||||
(define-cproc pointer-set-unsigned-long! (pointer offset::<int> value::<long>) pointer_set_unsigned_long)
|
||||
(define-cproc pointer-set-float! (pointer offset::<int> value::<float>) pointer_set_float)
|
||||
(define-cproc pointer-set-double! (pointer offset::<int> value::<double>) pointer_set_double)
|
||||
(define-cproc pointer-set-pointer! (pointer offset::<int> value) pointer_set_pointer)
|
||||
|
||||
(define-cproc pointer-get-int8 (pointer offset::<int>) pointer_get_int8)
|
||||
(define-cproc pointer-get-uint8 (pointer offset::<int>) pointer_get_uint8)
|
||||
(define-cproc pointer-get-int16 (pointer offset::<int>) pointer_get_int16)
|
||||
(define-cproc pointer-get-uint16 (pointer offset::<int>) pointer_get_uint16)
|
||||
(define-cproc pointer-get-int32 (pointer offset::<int>) pointer_get_int32)
|
||||
(define-cproc pointer-get-uint32 (pointer offset::<int>) pointer_get_uint32)
|
||||
(define-cproc pointer-get-int64 (pointer offset::<int>) pointer_get_int64)
|
||||
(define-cproc pointer-get-uint64 (pointer offset::<int>) pointer_get_uint64)
|
||||
(define-cproc pointer-get-char (pointer offset::<int>) pointer_get_char)
|
||||
(define-cproc pointer-get-unsigned-char (pointer offset::<int>) pointer_get_unsigned_char)
|
||||
(define-cproc pointer-get-short (pointer offset::<int>) pointer_get_short)
|
||||
(define-cproc pointer-get-unsigned-short (pointer offset::<int>) pointer_get_unsigned_short)
|
||||
(define-cproc pointer-get-int (pointer offset::<int>) pointer_get_int)
|
||||
(define-cproc pointer-get-unsigned-int (pointer offset::<int>) pointer_get_unsigned_int)
|
||||
(define-cproc pointer-get-long (pointer offset::<int>) pointer_get_long)
|
||||
(define-cproc pointer-get-unsigned-long (pointer offset::<int>) pointer_get_unsigned_long)
|
||||
(define-cproc pointer-get-float (pointer offset::<int>) pointer_get_float)
|
||||
(define-cproc pointer-get-double (pointer offset::<int>) pointer_get_double)
|
||||
(define-cproc pointer-get-pointer (pointer offset::<int>) pointer_get_pointer)
|
||||
|
||||
(define-cproc string->pointer (string-content) string_to_pointer)
|
||||
(define-cproc pointer->string (pointer) pointer_to_string)
|
||||
(define-cproc dlerror () pffi_dlerror)
|
||||
(define-cproc dlsym (shared-object c-name) pffi_dlsym)
|
||||
(define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call)
|
||||
|
||||
(define-cproc get-ffi-type-int8 () get_ffi_type_int8)
|
||||
(define-cproc get-ffi-type-uint8 () get_ffi_type_uint8)
|
||||
(define-cproc get-ffi-type-int16 () get_ffi_type_int16)
|
||||
(define-cproc get-ffi-type-uint16 () get_ffi_type_uint16)
|
||||
(define-cproc get-ffi-type-int32 () get_ffi_type_int32)
|
||||
(define-cproc get-ffi-type-uint32 () get_ffi_type_uint32)
|
||||
(define-cproc get-ffi-type-int64 () get_ffi_type_int64)
|
||||
(define-cproc get-ffi-type-uint64 () get_ffi_type_uint64)
|
||||
(define-cproc get-ffi-type-char () get_ffi_type_char)
|
||||
(define-cproc get-ffi-type-unsigned-char () get_ffi_type_unsigned_char)
|
||||
(define-cproc get-ffi-type-short () get_ffi_type_short)
|
||||
(define-cproc get-ffi-type-unsigned-short () get_ffi_type_unsigned_short)
|
||||
(define-cproc get-ffi-type-int () get_ffi_type_int)
|
||||
(define-cproc get-ffi-type-unsigned-int () get_ffi_type_unsigned_int)
|
||||
(define-cproc get-ffi-type-long () get_ffi_type_long)
|
||||
(define-cproc get-ffi-type-unsigned-long () get_ffi_type_unsigned_long)
|
||||
(define-cproc get-ffi-type-float () get_ffi_type_float)
|
||||
(define-cproc get-ffi-type-double () get_ffi_type_double)
|
||||
(define-cproc get-ffi-type-void() get_ffi_type_void)
|
||||
(define-cproc get-ffi-type-pointer () get_ffi_type_pointer)
|
||||
|
||||
;(define-cproc procedure-to-pointer (procedure) procedure_to_pointer)
|
||||
)
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(error "Not defined")))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(error "Not defined"))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(error "Not defined")))
|
||||
|
||||
#;(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(error "Not defined")))
|
||||
|
||||
#;(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(error "Not defined"))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
|
@ -0,0 +1,137 @@
|
|||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) int8)
|
||||
((equal? type 'uint8) uint8)
|
||||
((equal? type 'int16) int16)
|
||||
((equal? type 'uint16) uint16)
|
||||
((equal? type 'int32) int32)
|
||||
((equal? type 'uint32) uint32)
|
||||
((equal? type 'int64) int64)
|
||||
((equal? type 'uint64) uint64)
|
||||
((equal? type 'char) int8)
|
||||
((equal? type 'unsigned-char) uint8)
|
||||
((equal? type 'short) short)
|
||||
((equal? type 'unsigned-short) unsigned-short)
|
||||
((equal? type 'int) int)
|
||||
((equal? type 'unsigned-int) unsigned-int)
|
||||
((equal? type 'long) long)
|
||||
((equal? type 'unsigned-long) unsigned-long)
|
||||
((equal? type 'float) float)
|
||||
((equal? type 'double) double)
|
||||
((equal? type 'pointer) '*)
|
||||
((equal? type 'void) void)
|
||||
((equal? type 'string) '*)
|
||||
((equal? type 'callback) '*)
|
||||
((equal? type 'struct) '*)
|
||||
(else #f))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(foreign-library-function shared-object
|
||||
(symbol->string c-name)
|
||||
#:return-type (pffi-type->native-type return-type)
|
||||
#:arg-types (map pffi-type->native-type argument-types))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define-callback scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(procedure->pointer (pffi-type->native-type return-type)
|
||||
procedure
|
||||
(map pffi-type->native-type argument-types))))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(let ((native-type (pffi-type->native-type type)))
|
||||
(cond ((equal? native-type void) 0)
|
||||
(native-type (sizeof native-type))
|
||||
(else #f)))))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(bytevector->pointer (make-bytevector size 0))))
|
||||
|
||||
(define pffi-pointer-address
|
||||
(lambda (pointer)
|
||||
(pointer-address pointer)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(make-pointer 0)))
|
||||
|
||||
#;(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(string->pointer string-content)))
|
||||
|
||||
#;(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(pointer->string pointer)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path . options)
|
||||
(load-foreign-library path)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
#t))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(and (pffi-pointer? pointer)
|
||||
(null-pointer? pointer))))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p (pointer->bytevector pointer (+ offset 100))))
|
||||
(cond ((equal? type 'int8) (bytevector-s8-set! p offset value))
|
||||
((equal? type 'uint8) (bytevector-u8-set! p offset value))
|
||||
((equal? type 'int16) (bytevector-s16-set! p offset value (native-endianness)))
|
||||
((equal? type 'uint16) (bytevector-u16-set! p offset value (native-endianness)))
|
||||
((equal? type 'int32) (bytevector-s32-set! p offset value (native-endianness)))
|
||||
((equal? type 'uint32) (bytevector-u32-set! p offset value (native-endianness)))
|
||||
((equal? type 'int64) (bytevector-s64-set! p offset value (native-endianness)))
|
||||
((equal? type 'uint64) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? type 'char) (bytevector-s8-set! p offset (char->integer value)))
|
||||
((equal? type 'short) (bytevector-s8-set! p offset value))
|
||||
((equal? type 'unsigned-short) (bytevector-u8-set! p offset value))
|
||||
((equal? type 'int) (bytevector-sint-set! p offset value (native-endianness) (size-of-type type)))
|
||||
((equal? type 'unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (size-of-type type)))
|
||||
((equal? type 'long) (bytevector-s64-set! p offset value (native-endianness)))
|
||||
((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness)))
|
||||
((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness)))
|
||||
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))
|
||||
((equal? type 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer value)) (native-endianness) (size-of-type type)))))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(let ((p (pointer->bytevector pointer (+ offset 100))))
|
||||
(cond ((equal? type 'int8) (bytevector-s8-ref p offset))
|
||||
((equal? type 'uint8) (bytevector-u8-ref p offset))
|
||||
((equal? type 'int16) (bytevector-s16-ref p offset (native-endianness)))
|
||||
((equal? type 'uint16) (bytevector-u16-ref p offset (native-endianness)))
|
||||
((equal? type 'int32) (bytevector-s32-ref p offset (native-endianness)))
|
||||
((equal? type 'uint32) (bytevector-u32-ref p offset (native-endianness)))
|
||||
((equal? type 'int64) (bytevector-s64-ref p offset (native-endianness)))
|
||||
((equal? type 'uint64) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? type 'char) (integer->char (bytevector-s8-ref p offset)))
|
||||
((equal? type 'short) (bytevector-s8-ref p offset))
|
||||
((equal? type 'unsigned-short) (bytevector-u8-ref p offset))
|
||||
((equal? type 'int) (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))
|
||||
((equal? type 'unsigned-int) (bytevector-uint-ref p offset (native-endianness) (size-of-type type)))
|
||||
((equal? type 'long) (bytevector-s64-ref p offset (native-endianness)))
|
||||
((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness)))
|
||||
((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness)))
|
||||
((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))
|
||||
((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))))))))
|
||||
|
||||
(define pffi-struct-dereference
|
||||
(lambda (struct)
|
||||
(dereference-pointer (pffi-struct-pointer struct))))
|
||||
|
|
@ -0,0 +1,104 @@
|
|||
/*
|
||||
* 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 pointer_address(ScmObj object);
|
||||
extern ScmObj is_pointer(ScmObj pointer);
|
||||
extern ScmObj pointer_free(ScmObj pointer);
|
||||
|
||||
extern ScmObj pointer_set_int8(ScmObj pointer, int offset, int8_t value);
|
||||
extern ScmObj pointer_set_uint8(ScmObj pointer, int offset, uint8_t value);
|
||||
extern ScmObj pointer_set_int16(ScmObj pointer, int offset, int16_t value);
|
||||
extern ScmObj pointer_set_uint16(ScmObj pointer, int offset, uint16_t value);
|
||||
extern ScmObj pointer_set_int32(ScmObj pointer, int offset, int32_t value);
|
||||
extern ScmObj pointer_set_uint32(ScmObj pointer, int offset, uint32_t value);
|
||||
extern ScmObj pointer_set_int64(ScmObj pointer, int offset, int64_t value);
|
||||
extern ScmObj pointer_set_uint64(ScmObj pointer, int offset, uint64_t value);
|
||||
extern ScmObj pointer_set_char(ScmObj pointer, int offset, char value);
|
||||
extern ScmObj pointer_set_unsigned_char(ScmObj pointer, int offset, unsigned char value);
|
||||
extern ScmObj pointer_set_short(ScmObj pointer, int offset, short value);
|
||||
extern ScmObj pointer_set_unsigned_short(ScmObj pointer, int offset, unsigned short value);
|
||||
extern ScmObj pointer_set_int(ScmObj pointer, int offset, int value);
|
||||
extern ScmObj pointer_set_unsigned_int(ScmObj pointer, int offset, unsigned int value);
|
||||
extern ScmObj pointer_set_long(ScmObj pointer, int offset, long value);
|
||||
extern ScmObj pointer_set_unsigned_long(ScmObj pointer, int offset, unsigned long value);
|
||||
extern ScmObj pointer_set_float(ScmObj pointer, int offset, float value);
|
||||
extern ScmObj pointer_set_double(ScmObj pointer, int offset, double value);
|
||||
extern ScmObj pointer_set_pointer(ScmObj pointer, int offset, ScmObj value);
|
||||
|
||||
extern ScmObj pointer_get_int8(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_uint8(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_int16(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_uint16(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_int32(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_uint32(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_int64(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_uint64(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_char(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_unsigned_char(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_short(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_unsigned_short(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_int(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_unsigned_int(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_long(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_unsigned_long(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_float(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_double(ScmObj pointer, int offset);
|
||||
extern ScmObj pointer_get_pointer(ScmObj pointer, int offset);
|
||||
|
||||
extern ScmObj string_to_pointer(ScmObj string);
|
||||
extern ScmObj pointer_to_string(ScmObj pointer);
|
||||
extern ScmObj pffi_dlerror();
|
||||
extern ScmObj pffi_dlsym(ScmObj shared_object, ScmObj c_name);
|
||||
extern ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, ScmObj rvalue, ScmObj avalues);
|
||||
|
||||
extern ScmObj get_ffi_type_int8();
|
||||
extern ScmObj get_ffi_type_uint8();
|
||||
extern ScmObj get_ffi_type_int16();
|
||||
extern ScmObj get_ffi_type_uint16();
|
||||
extern ScmObj get_ffi_type_int32();
|
||||
extern ScmObj get_ffi_type_uint32();
|
||||
extern ScmObj get_ffi_type_int64();
|
||||
extern ScmObj get_ffi_type_uint64();
|
||||
extern ScmObj get_ffi_type_char();
|
||||
extern ScmObj get_ffi_type_unsigned_char();
|
||||
extern ScmObj get_ffi_type_short();
|
||||
extern ScmObj get_ffi_type_unsigned_short();
|
||||
extern ScmObj get_ffi_type_int();
|
||||
extern ScmObj get_ffi_type_unsigned_int();
|
||||
extern ScmObj get_ffi_type_long();
|
||||
extern ScmObj get_ffi_type_unsigned_long();
|
||||
extern ScmObj get_ffi_type_float();
|
||||
extern ScmObj get_ffi_type_double();
|
||||
extern ScmObj get_ffi_type_void();
|
||||
extern ScmObj get_ffi_type_pointer();
|
||||
|
||||
extern void Scm_Init_gauchelib(void);
|
||||
|
|
@ -0,0 +1,208 @@
|
|||
(define arena (invoke-static java.lang.foreign.Arena 'global))
|
||||
(define method-handle-lookup (invoke-static java.lang.invoke.MethodHandles 'lookup))
|
||||
(define native-linker (invoke-static java.lang.foreign.Linker 'nativeLinker))
|
||||
|
||||
(define value->object
|
||||
(lambda (value type)
|
||||
(cond ((equal? type 'byte)
|
||||
(java.lang.Byte value))
|
||||
((equal? type 'short)
|
||||
(java.lang.Short value))
|
||||
((equal? type 'unsigned-short)
|
||||
(java.lang.Short value))
|
||||
((equal? type 'int)
|
||||
(java.lang.Integer value))
|
||||
((equal? type 'unsigned-int)
|
||||
(java.lang.Integer value))
|
||||
((equal? type 'long)
|
||||
(java.lang.Long value))
|
||||
((equal? type 'unsigned-long)
|
||||
(java.lang.Long value))
|
||||
((equal? type 'float)
|
||||
(java.lang.Float value))
|
||||
((equal? type 'double)
|
||||
(java.lang.Double value))
|
||||
((equal? type 'char)
|
||||
(java.lang.Char value))
|
||||
(else value))))
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
|
||||
((equal? type 'uint8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
|
||||
((equal? type 'int16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2))
|
||||
((equal? type 'uint16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2))
|
||||
((equal? type 'int32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4))
|
||||
((equal? type 'uint32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4))
|
||||
((equal? type 'int64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8))
|
||||
((equal? type 'uint64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8))
|
||||
((equal? type 'char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
|
||||
((equal? type 'unsigned-char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
|
||||
((equal? type 'short) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT) 'withByteAlignment 2))
|
||||
((equal? type 'unsigned-short) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT) 'withByteAlignment 2))
|
||||
((equal? type 'int) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4))
|
||||
((equal? type 'unsigned-int) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4))
|
||||
((equal? type 'long) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_LONG) 'withByteAlignment 8))
|
||||
((equal? type 'unsigned-long) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_LONG) 'withByteAlignment 8))
|
||||
((equal? type 'float) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT) 'withByteAlignment 4))
|
||||
((equal? type 'double) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE) 'withByteAlignment 8))
|
||||
((equal? type 'pointer) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
((equal? type 'string) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
((equal? type 'void) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1))
|
||||
((equal? type 'callback) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
((equal? type 'struct) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
(else #f))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(string=? (invoke (invoke object 'getClass) 'getName)
|
||||
"jdk.internal.foreign.NativeMemorySegmentImpl")))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(lambda vals
|
||||
(invoke (invoke (cdr (assoc 'linker shared-object))
|
||||
'downcallHandle
|
||||
(invoke (invoke (cdr (assoc 'lookup shared-object))
|
||||
'find
|
||||
(symbol->string c-name))
|
||||
'orElseThrow)
|
||||
(if (equal? return-type 'void)
|
||||
(apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)
|
||||
(map pffi-type->native-type argument-types))
|
||||
(apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
|
||||
(pffi-type->native-type return-type)
|
||||
(map pffi-type->native-type argument-types))))
|
||||
'invokeWithArguments
|
||||
(map value->object vals argument-types)))))))
|
||||
|
||||
(define range
|
||||
(lambda (from to)
|
||||
(letrec*
|
||||
((looper
|
||||
(lambda (count result)
|
||||
(if (= count to)
|
||||
(append result (list count))
|
||||
(looper (+ count 1) (append result (list count)))))))
|
||||
(looper from (list)))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(let* ((callback-procedure
|
||||
(lambda (arg1 . args)
|
||||
(try-catch
|
||||
(begin
|
||||
(apply procedure (append (list arg1) args)))
|
||||
(ex <java.lang.Throwable>
|
||||
#f))))
|
||||
(function-descriptor
|
||||
(let ((function-descriptor
|
||||
(if (equal? return-type 'void)
|
||||
(apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)
|
||||
(map pffi-type->native-type argument-types))
|
||||
(apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
|
||||
(pffi-type->native-type return-type)
|
||||
(map pffi-type->native-type argument-types)))))
|
||||
(write function-descriptor)
|
||||
(newline)
|
||||
(write (invoke function-descriptor 'getClass))
|
||||
(newline)
|
||||
(write function-descriptor)
|
||||
(newline)
|
||||
function-descriptor))
|
||||
;(method-type (invoke function-descriptor 'toMethodType))
|
||||
(method-type (field callback-procedure 'applyMethodType))
|
||||
(method-handle
|
||||
(let* ((method-handle (field callback-procedure 'applyToConsumerDefault)))
|
||||
(write method-handle)
|
||||
(newline)
|
||||
method-handle)))
|
||||
(invoke native-linker 'upcallStub method-handle function-descriptor arena))))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(let ((native-type (pffi-type->native-type type)))
|
||||
(if native-type
|
||||
(invoke native-type 'byteAlignment)
|
||||
#f))))
|
||||
|
||||
#;(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(invoke (invoke arena 'allocate size 1) 'reinterpret size)))
|
||||
|
||||
(define pffi-pointer-address
|
||||
(lambda (pointer)
|
||||
(invoke pointer 'address)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(static-field java.lang.foreign.MemorySegment 'NULL)))
|
||||
|
||||
#;(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(let ((size (+ (invoke string-content 'length) 1)))
|
||||
(invoke (invoke arena 'allocateFrom (invoke string-content 'toString))
|
||||
'reinterpret size))))
|
||||
|
||||
#;(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getString 0)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (path options)
|
||||
(let* ((library-file (make java.io.File path))
|
||||
(file-name (invoke library-file 'getName))
|
||||
(library-parent-folder (make java.io.File (invoke library-file 'getParent)))
|
||||
(absolute-path (string-append (invoke library-parent-folder 'getCanonicalPath)
|
||||
"/"
|
||||
file-name))
|
||||
(linker (invoke-static java.lang.foreign.Linker 'nativeLinker))
|
||||
(lookup (invoke-static java.lang.foreign.SymbolLookup
|
||||
'libraryLookup
|
||||
absolute-path
|
||||
arena)))
|
||||
(list (cons 'linker linker)
|
||||
(cons 'lookup lookup)))))
|
||||
|
||||
#;(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
#t))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(invoke pointer 'equals (pffi-pointer-null))))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
|
||||
'set
|
||||
(pffi-type->native-type type)
|
||||
offset
|
||||
(if (equal? type 'char)
|
||||
(char->integer value)
|
||||
value))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(let ((r (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
|
||||
'get
|
||||
(pffi-type->native-type type)
|
||||
offset)))
|
||||
(if (equal? type 'char)
|
||||
(integer->char r)
|
||||
r))))
|
||||
|
||||
#;(define pffi-struct-dereference
|
||||
(lambda (struct)
|
||||
;; WIP
|
||||
(pffi-struct-pointer struct)
|
||||
#;(invoke (pffi-struct-pointer struct) 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
|
||||
#;(invoke (pffi-struct-pointer struct)
|
||||
'get
|
||||
(invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1)
|
||||
0)))
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
;; Copied from Larceny source
|
||||
;; Copyright 1998 Lars T Hansen.
|
||||
;; Copied code begins
|
||||
|
||||
(define %set32u)
|
||||
|
||||
; %peek* and %poke*: convenient access to values in memory.
|
||||
|
||||
(define (%peek8 addr)
|
||||
(let ((x (make-bytevector 1)))
|
||||
(peek-bytes addr x 1)
|
||||
(let ((v (bytevector-ref x 0)))
|
||||
(if (> v 127)
|
||||
(- (- 256 v))
|
||||
v))))
|
||||
|
||||
(define (%peek16 addr)
|
||||
(let ((x (make-bytevector 2)))
|
||||
(peek-bytes addr x 2)
|
||||
(%get16 x 0)))
|
||||
|
||||
(define (%peek32 addr)
|
||||
(let ((x (make-bytevector 4)))
|
||||
(peek-bytes addr x 4)
|
||||
(%get32 x 0)))
|
||||
|
||||
(define (%peek8u addr)
|
||||
(let ((x (make-bytevector 1)))
|
||||
(peek-bytes addr x 1)
|
||||
(bytevector-ref x 0)))
|
||||
|
||||
(define (%peek16u addr)
|
||||
(let ((x (make-bytevector 2)))
|
||||
(peek-bytes addr x 2)
|
||||
(%get16u x 0)))
|
||||
|
||||
(define (%peek32u addr)
|
||||
(let ((x (make-bytevector 4)))
|
||||
(peek-bytes addr x 4)
|
||||
(%get32u x 0)))
|
||||
|
||||
(define (%poke8 addr val)
|
||||
(let ((x (make-bytevector 1)))
|
||||
(if (< val 0)
|
||||
(bytevector-set! x 0 (+ 256 val))
|
||||
(bytevector-set! x 0 val))
|
||||
(poke-bytes addr x 1)))
|
||||
|
||||
(define (%poke16 addr val)
|
||||
(let ((x (make-bytevector 2)))
|
||||
(%set16 x 0 val)
|
||||
(poke-bytes addr x 2)))
|
||||
|
||||
(define (%poke32 addr val)
|
||||
(let ((x (make-bytevector 4)))
|
||||
(%set32 x 0 val)
|
||||
(poke-bytes addr x 4)))
|
||||
|
||||
(define (%poke8u addr val)
|
||||
(let ((x (make-bytevector 1)))
|
||||
(bytevector-set! x 0 val)
|
||||
(poke-bytes addr x 1)))
|
||||
|
||||
(define (%poke16u addr val)
|
||||
(let ((x (make-bytevector 2)))
|
||||
(%set16u x 0 val)
|
||||
(poke-bytes addr x 2)))
|
||||
|
||||
(define (%poke32u addr val)
|
||||
(let ((x (make-bytevector 4)))
|
||||
(%set32u x 0 val)
|
||||
(poke-bytes addr x 4)))
|
||||
|
||||
(define %peek-int %peek32)
|
||||
(define %peek-long %peek32)
|
||||
(define %peek-uint %peek32u)
|
||||
(define %peek-ulong %peek32u)
|
||||
(define %peek-short %peek16)
|
||||
(define %peek-ushort %peek16u)
|
||||
(define %peek-pointer %peek32u)
|
||||
|
||||
(define %poke-int %poke32)
|
||||
(define %poke-long %poke32)
|
||||
(define %poke-uint %poke32u)
|
||||
(define %poke-ulong %poke32u)
|
||||
(define %poke-short %poke16)
|
||||
(define %poke-ushort %poke16u)
|
||||
(define %poke-pointer %poke32u)
|
||||
|
|
@ -0,0 +1,141 @@
|
|||
(require 'std-ffi)
|
||||
;(require "Standard/foreign-stdlib")
|
||||
;(require "Lib/Common/system-interface")
|
||||
|
||||
;; FIXME
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) 1)
|
||||
((eq? type 'uint8) 1)
|
||||
((eq? type 'int16) 2)
|
||||
((eq? type 'uint16) 2)
|
||||
((eq? type 'int32) 4)
|
||||
((eq? type 'uint32) 4)
|
||||
((eq? type 'int64) 8)
|
||||
((eq? type 'uint64) 8)
|
||||
((eq? type 'char) 1)
|
||||
((eq? type 'unsigned-char) 1)
|
||||
((eq? type 'short) 2)
|
||||
((eq? type 'unsigned-short) 2)
|
||||
((eq? type 'int) 4)
|
||||
((eq? type 'unsigned-int) 4)
|
||||
((eq? type 'long) 4)
|
||||
((eq? type 'unsigned-long) 4)
|
||||
((eq? type 'float) 4)
|
||||
((eq? type 'double) 8)
|
||||
((eq? type 'pointer) 4)
|
||||
((eq? type 'void) 0)
|
||||
((eq? type 'callback) 4)
|
||||
(else (error "Can not get size of unknown type" type)))))
|
||||
|
||||
(define c-malloc (foreign-procedure "malloc" '(int) 'void*))
|
||||
;(define c-malloc (stdlib/malloc rtd-void*))
|
||||
#;(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(c-malloc size)))
|
||||
|
||||
#;(define c-free (foreign-procedure "free" '(void*) 'int))
|
||||
;(define c-malloc (stdlib/malloc rtd-void*))
|
||||
#;(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(c-free pointer)))
|
||||
|
||||
(define pffi-pointer-null (lambda () 0))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (object)
|
||||
(and (number? object)
|
||||
(= object 0))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
;(void*? object)
|
||||
(number? object)
|
||||
))
|
||||
|
||||
(define pffi-pointer-address
|
||||
(lambda (pointer)
|
||||
;(void*->address pointer)
|
||||
pointer
|
||||
))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
;(char*->string pointer)
|
||||
pointer
|
||||
))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
;(string->char* string-content)
|
||||
string-content
|
||||
))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (headers path . options)
|
||||
(foreign-file path)))
|
||||
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
0
|
||||
#;(cond ((equal? type 'int8) (%poke8 (+ pointer offset) value))
|
||||
((equal? type 'uint8) (%poke8u (+ pointer offset) value))
|
||||
((equal? type 'int16) (%poke16 (+ pointer offset) value))
|
||||
((equal? type 'uint16) (%poke16u (+ pointer offset) value))
|
||||
((equal? type 'int32) (%poke32 (+ pointer offset) value))
|
||||
((equal? type 'uint32) (%poke32u (+ pointer offset) value))
|
||||
;((equal? type 'int64) (%poke64 (+ pointer offset) value))
|
||||
;((equal? type 'uint64) (%poke64u (+ pointer offset) value))
|
||||
((equal? type 'char) (%poke8 (+ pointer offset) value))
|
||||
((equal? type 'short) (%poke-short (+ pointer offset) value))
|
||||
((equal? type 'unsigned-short) (%poke-ushort (+ pointer offset) value))
|
||||
((equal? type 'int) (%poke-int (+ pointer offset) value))
|
||||
((equal? type 'unsigned-int) (%poke-uint (+ pointer offset) value))
|
||||
((equal? type 'long) (%poke-long (+ pointer offset) value))
|
||||
((equal? type 'unsigned-long) (%poke-ulong (+ pointer offset) value))
|
||||
;((equal? type 'float) (%poke-ulong (+ pointer offset) value))
|
||||
;((equal? type 'double) (pointer-set-c-double! pointer offset value))
|
||||
((equal? type 'void) (%poke-pointer (+ pointer offset) value))
|
||||
((equal? type 'pointer) (%poke-pointer (+ pointer offset) value)))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
0
|
||||
#;(cond ((equal? type 'int8) (%peek8 (+ pointer offset)))
|
||||
((equal? type 'uint8) (%peek8u (+ pointer offset)))
|
||||
((equal? type 'int16) (%peek16 (+ pointer offset)))
|
||||
((equal? type 'uint16) (%peek16u (+ pointer offset)))
|
||||
((equal? type 'int32) (%peek32 (+ pointer offset)))
|
||||
((equal? type 'uint32) (%peek32u (+ pointer offset)))
|
||||
;((equal? type 'int64) (%peek64 (+ pointer offset)))
|
||||
;((equal? type 'uint64) (%peek64u (+ pointer offset)))
|
||||
((equal? type 'char) (%peek8 (+ pointer offset)))
|
||||
((equal? type 'short) (%peek-short (+ pointer offset)))
|
||||
((equal? type 'unsigned-short) (%peek-ushort (+ pointer offset)))
|
||||
((equal? type 'int) (%peek-int (+ pointer offset)))
|
||||
((equal? type 'unsigned-int) (%peek-uint (+ pointer offset)))
|
||||
((equal? type 'long) (%peek-long (+ pointer offset)))
|
||||
((equal? type 'unsigned-long) (%peek-ulong (+ pointer offset)))
|
||||
;((equal? type 'float) (%peek-ulong (+ pointer offset)))
|
||||
;((equal? type 'double) (pointer-set-c-double! pointer offset))
|
||||
((equal? type 'void) (%peek-pointer (+ pointer offset)))
|
||||
((equal? type 'pointer) (%peek-pointer (+ pointer offset))))))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
0
|
||||
|
||||
#;(make-c-function shared-object
|
||||
(symbol->string c-name)
|
||||
return-type
|
||||
argument-types)))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
0
|
||||
#;(make-c-callback return-type argument-types procedure)))))
|
||||
|
|
@ -0,0 +1,161 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) 1)
|
||||
((eq? type 'uint8) 1)
|
||||
((eq? type 'int16) 2)
|
||||
((eq? type 'uint16) 2)
|
||||
((eq? type 'int32) 4)
|
||||
((eq? type 'uint32) 4)
|
||||
((eq? type 'int64) 8)
|
||||
((eq? type 'uint64) 8)
|
||||
((eq? type 'char) 1)
|
||||
((eq? type 'unsigned-char) 1)
|
||||
((eq? type 'short) size-of-short)
|
||||
((eq? type 'unsigned-short) size-of-unsigned-short)
|
||||
((eq? type 'int) size-of-int)
|
||||
((eq? type 'unsigned-int) size-of-unsigned-int)
|
||||
((eq? type 'long) size-of-long)
|
||||
((eq? type 'unsigned-long) size-of-unsigned-long)
|
||||
((eq? type 'float) size-of-float)
|
||||
((eq? type 'double) size-of-double)
|
||||
((eq? type 'pointer) size-of-pointer)
|
||||
((eq? type 'string) size-of-pointer)
|
||||
((eq? type 'callback) size-of-pointer)
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (path . options)
|
||||
(open-shared-library path)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
pointer-null))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(pointer-null? pointer)))
|
||||
|
||||
#;(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(malloc size)))
|
||||
|
||||
(define pffi-pointer-address
|
||||
(lambda (pointer)
|
||||
(pointer->integer pointer)))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
#;(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(free pointer)))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond ((equal? type 'int8) (pointer-set-c-int8! pointer offset value))
|
||||
((equal? type 'uint8) (pointer-set-c-uint8! pointer offset value))
|
||||
((equal? type 'int16) (pointer-set-c-int16! pointer offset value))
|
||||
((equal? type 'uint16) (pointer-set-c-uint16! pointer offset value))
|
||||
((equal? type 'int32) (pointer-set-c-int32! pointer offset value))
|
||||
((equal? type 'uint32) (pointer-set-c-uint32! pointer offset value))
|
||||
((equal? type 'int64) (pointer-set-c-int64! pointer offset value))
|
||||
((equal? type 'uint64) (pointer-set-c-uint64! pointer offset value))
|
||||
((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value)))
|
||||
((equal? type 'short) (pointer-set-c-short! pointer offset value))
|
||||
((equal? type 'unsigned-short) (pointer-set-c-short! pointer offset value))
|
||||
((equal? type 'int) (pointer-set-c-int! pointer offset value))
|
||||
((equal? type 'unsigned-int) (pointer-set-c-int! pointer offset value))
|
||||
((equal? type 'long) (pointer-set-c-long! pointer offset value))
|
||||
((equal? type 'unsigned-long) (pointer-set-c-long! pointer offset value))
|
||||
((equal? type 'float) (pointer-set-c-float! pointer offset value))
|
||||
((equal? type 'double) (pointer-set-c-double! pointer offset value))
|
||||
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
|
||||
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond ((equal? type 'int8) (pointer-ref-c-int8 pointer offset))
|
||||
((equal? type 'uint8) (pointer-ref-c-uint8 pointer offset))
|
||||
((equal? type 'int16) (pointer-ref-c-int16 pointer offset))
|
||||
((equal? type 'uint16) (pointer-ref-c-uint16 pointer offset))
|
||||
((equal? type 'int32) (pointer-ref-c-int32 pointer offset))
|
||||
((equal? type 'uint32) (pointer-ref-c-uint32 pointer offset))
|
||||
((equal? type 'int64) (pointer-ref-c-int64 pointer offset))
|
||||
((equal? type 'uint64) (pointer-ref-c-uint64 pointer offset))
|
||||
((equal? type 'char) (integer->char (pointer-ref-c-signed-char pointer offset)))
|
||||
((equal? type 'short) (pointer-ref-c-signed-short pointer offset))
|
||||
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
|
||||
((equal? type 'int) (pointer-ref-c-signed-int pointer offset))
|
||||
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
|
||||
((equal? type 'long) (pointer-ref-c-signed-long pointer offset))
|
||||
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
|
||||
((equal? type 'float) (pointer-ref-c-float pointer offset))
|
||||
((equal? type 'double) (pointer-ref-c-double pointer offset))
|
||||
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
|
||||
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
|
||||
|
||||
#;(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(let ((pointer (pffi-pointer-allocate (+ (string-length string-content) 1)))
|
||||
(index 0))
|
||||
(string-for-each
|
||||
(lambda (c)
|
||||
(pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) c)
|
||||
(set! index (+ index 1)))
|
||||
string-content)
|
||||
(pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) #\null)
|
||||
pointer)))
|
||||
|
||||
#;(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(pointer->string pointer)))
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'string) 'char*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'void*)
|
||||
((equal? type 'struct) 'void*)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(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
|
||||
(pffi-type->native-type return-type)
|
||||
c-name
|
||||
(map pffi-type->native-type argument-types))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback (pffi-type->native-type return-type)
|
||||
(map pffi-type->native-type argument-types)
|
||||
procedure)))))
|
||||
|
||||
#;(define pffi-struct-dereference
|
||||
(lambda (struct)
|
||||
(pffi-struct-pointer struct)))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,120 @@
|
|||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) _int8)
|
||||
((equal? type 'uint8) _uint8)
|
||||
((equal? type 'int16) _int16)
|
||||
((equal? type 'uint16) _uint16)
|
||||
((equal? type 'int32) _int32)
|
||||
((equal? type 'uint32) _uint32)
|
||||
((equal? type 'int64) _int64)
|
||||
((equal? type 'uint64) _uint64)
|
||||
((equal? type 'char) _int8)
|
||||
((equal? type 'unsigned-char) _uint8)
|
||||
((equal? type 'short) _short)
|
||||
((equal? type 'unsigned-short) _ushort)
|
||||
((equal? type 'int) _int)
|
||||
((equal? type 'unsigned-int) _uint)
|
||||
((equal? type 'long) _long)
|
||||
((equal? type 'unsigned-long) _ulong)
|
||||
((equal? type 'float) _float)
|
||||
((equal? type 'double) _double)
|
||||
((equal? type 'pointer) _pointer)
|
||||
((equal? type 'void) _void)
|
||||
((equal? type 'callback) _pointer)
|
||||
((equal? type 'string) _pointer)
|
||||
((equal? type 'struct) _pointer)
|
||||
(else #f))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(cpointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(get-ffi-obj c-name
|
||||
shared-object
|
||||
(_cprocedure (mlist->list (map pffi-type->native-type argument-types))
|
||||
(pffi-type->native-type return-type)))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define-callback scheme-name return-type argument-types procedure)
|
||||
(define scheme-name (function-ptr procedure
|
||||
(_cprocedure
|
||||
(mlist->list (map pffi-type->native-type argument-types))
|
||||
(pffi-type->native-type return-type)))))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(let ((native-type (pffi-type->native-type type)))
|
||||
(if native-type
|
||||
(ctype-sizeof native-type)
|
||||
#f))))
|
||||
|
||||
#;(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(malloc 'raw size)))
|
||||
|
||||
(define pffi-pointer-address
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
#f )) ; #f is the null pointer on racket
|
||||
|
||||
#;(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(let* ((size (string-length string-content))
|
||||
(pointer (pffi-pointer-allocate (+ size 1))))
|
||||
(memmove pointer (cast (string-append string-content "") _string _pointer) (+ size 1))
|
||||
pointer)))
|
||||
|
||||
#;(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(when (pffi-pointer-null? pointer)
|
||||
(error "Can not make string from null pointer" pointer))
|
||||
(string-copy (cast pointer _pointer _string))))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (path options)
|
||||
(if (and (not (null? options))
|
||||
(assoc 'additional-versions options))
|
||||
(ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions
|
||||
options))
|
||||
(list #f))))
|
||||
(ffi-lib path))))
|
||||
|
||||
#;(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(free pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(not pointer))) ; #f is the null pointer on racket
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(ptr-set! pointer
|
||||
(pffi-type->native-type type)
|
||||
'abs
|
||||
offset
|
||||
(if (equal? type 'char)
|
||||
(char->integer value)
|
||||
value))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(let ((r (ptr-ref pointer
|
||||
(pffi-type->native-type type)
|
||||
'abs
|
||||
offset)))
|
||||
(if (equal? type 'char)
|
||||
(integer->char r)
|
||||
r))))
|
||||
|
||||
#;(define pffi-struct-dereference
|
||||
(lambda (struct)
|
||||
(pffi-struct-pointer struct)))
|
||||
|
|
@ -0,0 +1,159 @@
|
|||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'string) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'callback)
|
||||
((and (pair? type) (equal? 'struct (car type))) 'void*)
|
||||
(else #f))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(or (pointer? object)
|
||||
(string? object))))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(pffi-type->native-type return-type)
|
||||
c-name
|
||||
(map pffi-type->native-type argument-types))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback (pffi-type->native-type return-type)
|
||||
(map pffi-type->native-type argument-types)
|
||||
procedure)))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) size-of-int8_t)
|
||||
((eq? type 'uint8) size-of-uint8_t)
|
||||
((eq? type 'int16) size-of-int16_t)
|
||||
((eq? type 'uint16) size-of-uint16_t)
|
||||
((eq? type 'int32) size-of-int32_t)
|
||||
((eq? type 'uint32) size-of-uint32_t)
|
||||
((eq? type 'int64) size-of-int64_t)
|
||||
((eq? type 'uint64) size-of-uint64_t)
|
||||
((eq? type 'char) size-of-char)
|
||||
((eq? type 'unsigned-char) size-of-char)
|
||||
((eq? type 'short) size-of-short)
|
||||
((eq? type 'unsigned-short) size-of-unsigned-short)
|
||||
((eq? type 'int) size-of-int)
|
||||
((eq? type 'unsigned-int) size-of-unsigned-int)
|
||||
((eq? type 'long) size-of-long)
|
||||
((eq? type 'unsigned-long) size-of-unsigned-long)
|
||||
((eq? type 'float) size-of-float)
|
||||
((eq? type 'double) size-of-double)
|
||||
((eq? type 'pointer) size-of-void*)
|
||||
((eq? type 'void) 0)
|
||||
((eq? type 'string) size-of-void*)
|
||||
((eq? type 'callback) size-of-void*)
|
||||
(else #f))))
|
||||
|
||||
#;(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(c-malloc size)))
|
||||
|
||||
(define pffi-pointer-address
|
||||
(lambda (pointer)
|
||||
(address pointer 0)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(empty-pointer)))
|
||||
|
||||
#;(define (string->c-string s)
|
||||
(let* ((bv (string->utf8 s))
|
||||
(p (allocate-pointer (+ (bytevector-length bv) 1))))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i (bytevector-length bv)) p)
|
||||
(pointer-set-c-uint8! p i (bytevector-u8-ref bv i)))
|
||||
p))
|
||||
|
||||
#;(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(string->c-string string-content)))
|
||||
|
||||
#;(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(pointer->string pointer)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (path options)
|
||||
(open-shared-library path)))
|
||||
|
||||
#;(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(when (pointer? pointer)
|
||||
(c-free pointer))))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(null-pointer? pointer)))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
|
||||
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
|
||||
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
|
||||
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
|
||||
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
|
||||
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
|
||||
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
|
||||
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
|
||||
((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value)))
|
||||
((equal? type 'short) (pointer-set-c-short! pointer offset value))
|
||||
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
|
||||
((equal? type 'int) (pointer-set-c-int! pointer offset value))
|
||||
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
|
||||
((equal? type 'long) (pointer-set-c-long! pointer offset value))
|
||||
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
|
||||
((equal? type 'float) (pointer-set-c-float! pointer offset value))
|
||||
((equal? type 'double) (pointer-set-c-double! pointer offset value))
|
||||
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
|
||||
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
|
||||
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
|
||||
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
|
||||
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
|
||||
((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
|
||||
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
|
||||
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
|
||||
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
|
||||
((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset)))
|
||||
((equal? type 'short) (pointer-ref-c-short pointer offset))
|
||||
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
|
||||
((equal? type 'int) (pointer-ref-c-int pointer offset))
|
||||
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
|
||||
((equal? type 'long) (pointer-ref-c-long pointer offset))
|
||||
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
|
||||
((equal? type 'float) (pointer-ref-c-float pointer offset))
|
||||
((equal? type 'double) (pointer-ref-c-double pointer offset))
|
||||
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
|
||||
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
(define-record-type <pffi-array>
|
||||
(array-make type size pointer)
|
||||
pffi-array?
|
||||
(type pffi-array-type)
|
||||
(size pffi-array-size)
|
||||
(pointer pffi-array-pointer))
|
||||
|
||||
(define pffi-list->array
|
||||
(lambda (type list-arg)
|
||||
(let* ((array-size (length list-arg))
|
||||
(type-size (pffi-size-of type))
|
||||
(array (pffi-pointer-allocate (* type-size array-size)))
|
||||
(offset 0))
|
||||
(for-each
|
||||
(lambda (item)
|
||||
(pffi-pointer-set! array type offset item)
|
||||
(set! offset (+ offset type-size)))
|
||||
list-arg)
|
||||
(array-make type array-size array))))
|
||||
|
||||
(define pffi-pointer->array
|
||||
(lambda (pointer type size)
|
||||
(array-make type size pointer)))
|
||||
|
||||
(define pffi-array->list
|
||||
(lambda (array)
|
||||
(letrec* ((type (pffi-array-type array))
|
||||
(type-size (pffi-size-of type))
|
||||
(max-offset (* type-size (pffi-array-size array)))
|
||||
(array-pointer (pffi-array-pointer array))
|
||||
(looper (lambda (offset result)
|
||||
(if (= offset max-offset)
|
||||
result
|
||||
(looper (+ offset type-size)
|
||||
(append result
|
||||
(list (pffi-pointer-get array-pointer
|
||||
type
|
||||
offset))))))))
|
||||
(looper 0 (list)))))
|
||||
|
||||
(define pffi-array-allocate
|
||||
(lambda (type size)
|
||||
(array-make type size (pffi-pointer-allocate-calloc size (pffi-size-of type)))))
|
||||
|
||||
(define pffi-array-get
|
||||
(lambda (array index)
|
||||
(let ((type (pffi-array-type array)))
|
||||
(pffi-pointer-get (pffi-array-pointer array)
|
||||
type
|
||||
(* (pffi-size-of type) index)))))
|
||||
|
||||
(define pffi-array-set!
|
||||
(lambda (array index value)
|
||||
(let ((type (pffi-array-type array)))
|
||||
(pffi-pointer-set! (pffi-array-pointer array)
|
||||
type
|
||||
(* (pffi-size-of type) index)
|
||||
value))))
|
||||
|
|
@ -0,0 +1,234 @@
|
|||
(cond-expand
|
||||
(mosh (define pffi-init (lambda () #t)))
|
||||
(chicken
|
||||
(define-syntax pffi-init
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
'(import (chicken foreign)
|
||||
(chicken memory))
|
||||
#t))))
|
||||
(gambit #t)
|
||||
(ypsilon
|
||||
(define-syntax pffi-init
|
||||
(syntax-rules ()
|
||||
((_)
|
||||
(import (ypsilon ffi)
|
||||
(ypsilon c-types))))))
|
||||
(else (define pffi-init (lambda () #t))))
|
||||
|
||||
(define pffi-type?
|
||||
(lambda (object)
|
||||
(if (equal? (size-of-type object) #f)
|
||||
#f
|
||||
#t)))
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (object)
|
||||
(cond ((pffi-struct? object) (pffi-struct-size object))
|
||||
((pffi-type? object) (size-of-type object))
|
||||
(else (error "Not pffi-struct, pffi-enum of pffi-type" object)))))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (str)
|
||||
(letrec* ((str-length (string-length str))
|
||||
(pointer (pffi-pointer-allocate (+ str-length 1)))
|
||||
(looper (lambda (index)
|
||||
(when (< index str-length)
|
||||
(pffi-pointer-set! pointer
|
||||
'char
|
||||
index
|
||||
(string-ref str index))
|
||||
(looper (+ index 1))))))
|
||||
(looper 0)
|
||||
(pffi-pointer-set! pointer 'char str-length #\null)
|
||||
pointer)))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(letrec* ((looper (lambda (index str)
|
||||
(let ((c (pffi-pointer-get pointer 'char index)))
|
||||
(if (char=? c #\null)
|
||||
str
|
||||
(looper (+ index 1) (cons c str)))))))
|
||||
(list->string (reverse (looper 0 (list)))))))
|
||||
|
||||
|
||||
(define pffi-types
|
||||
'(int8
|
||||
uint8
|
||||
int16
|
||||
uint16
|
||||
int32
|
||||
uint32
|
||||
int64
|
||||
uint64
|
||||
char
|
||||
unsigned-char
|
||||
short
|
||||
unsigned-short
|
||||
int
|
||||
unsigned-int
|
||||
long
|
||||
unsigned-long
|
||||
float
|
||||
double
|
||||
pointer
|
||||
void))
|
||||
|
||||
(define string-split
|
||||
(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 #t)
|
||||
((or chicken cyclone)
|
||||
(define-syntax pffi-define-library
|
||||
(syntax-rules ()
|
||||
((_ scheme-name headers object-name options)
|
||||
(begin
|
||||
(define scheme-name #t)
|
||||
(pffi-shared-object-load headers))))))
|
||||
(else
|
||||
(define-syntax pffi-define-library
|
||||
(syntax-rules ()
|
||||
((_ scheme-name headers object-name options)
|
||||
(define scheme-name
|
||||
(let* ((internal-options (if (null? 'options)
|
||||
(list)
|
||||
(cadr 'options)))
|
||||
(additional-paths (if (assoc 'additional-paths internal-options)
|
||||
(cadr (assoc 'additional-paths internal-options))
|
||||
(list)))
|
||||
(additional-versions (if (assoc 'additional-versions internal-options)
|
||||
(map (lambda (version)
|
||||
(if (number? version)
|
||||
(number->string version)
|
||||
version))
|
||||
(cadr (assoc 'additional-versions internal-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 (windows "") (else "lib")))
|
||||
(platform-file-extension (cond-expand (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))
|
||||
(cond-expand
|
||||
(stklos shared-object)
|
||||
(else (pffi-shared-object-load shared-object
|
||||
`((additional-versions ,additional-versions)))))))))))))
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
(cond-expand
|
||||
(windows (pffi-define-library pffi-libc-stdlib
|
||||
'("stdlib.h")
|
||||
"ucrtbase"
|
||||
'((additional-versions ("0" "6")))))
|
||||
(else (pffi-define-library pffi-libc-stdlib
|
||||
'("stdlib.h")
|
||||
"c"
|
||||
'((additional-versions ("0" "6"))))))
|
||||
|
||||
(cond-expand
|
||||
(chibi #t) ; FIXME
|
||||
(else (pffi-define pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int))))
|
||||
|
||||
(pffi-define pffi-pointer-allocate-aligned pffi-libc-stdlib 'aligned_alloc 'pointer '(int int))
|
||||
(pffi-define pffi-pointer-allocate-calloc pffi-libc-stdlib 'calloc 'pointer '(int int))
|
||||
|
||||
(cond-expand
|
||||
(chibi #t) ; FIXME
|
||||
(else (pffi-define pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer))))
|
||||
|
|
@ -0,0 +1,128 @@
|
|||
(define-record-type <pffi-struct>
|
||||
(struct-make c-type size pointer members)
|
||||
pffi-struct?
|
||||
(c-type pffi-struct-c-type)
|
||||
(size pffi-struct-size)
|
||||
(pointer pffi-struct-pointer)
|
||||
(members pffi-struct-members))
|
||||
|
||||
(define-syntax pffi-define-struct
|
||||
(syntax-rules ()
|
||||
((_ name c-type members)
|
||||
(define name
|
||||
(lambda arguments
|
||||
(let* ((size-and-offsets (calculate-struct-size-and-offsets members))
|
||||
(size (cdr (assoc 'size size-and-offsets)))
|
||||
(offsets (cdr (assoc 'offsets size-and-offsets)))
|
||||
(pointer (if (and (not (null? arguments))
|
||||
(pffi-pointer? (car arguments)))
|
||||
(car arguments)
|
||||
(pffi-pointer-allocate size)))
|
||||
(c-type-string (if (string? c-type) c-type (symbol->string c-type))))
|
||||
(struct-make c-type-string size pointer offsets)))))))
|
||||
|
||||
(define pffi-struct-dereference
|
||||
(lambda (struct)
|
||||
(let ((pointer (pffi-pointer-allocate (pffi-struct-size struct)))
|
||||
(offset 0))
|
||||
(for-each
|
||||
(lambda (struct-member)
|
||||
(let* ((member-type (cadr struct-member))
|
||||
(member-name (car struct-member))
|
||||
(member-size (pffi-size-of member-type)))
|
||||
(display "HERE: ")
|
||||
(write member-size)
|
||||
(newline)
|
||||
(pffi-pointer-set! pointer
|
||||
member-type
|
||||
offset
|
||||
(pffi-struct-get struct member-name))
|
||||
(set! offset (+ offset member-size))))
|
||||
(pffi-struct-members struct))
|
||||
;(pffi-pointer-get (pffi-struct-pointer struct) 'pointer 0)
|
||||
;(pffi-pointer-get pointer 'pointer 0)
|
||||
pointer
|
||||
)))
|
||||
|
||||
(define pffi-align-of
|
||||
(lambda (type)
|
||||
(cond-expand
|
||||
;(guile (alignof (pffi-type->native-type type)))
|
||||
(else (size-of-type type)))))
|
||||
|
||||
(define round-to-next-modulo-of
|
||||
(lambda (to-round roundee)
|
||||
(if (= (floor-remainder to-round roundee) 0)
|
||||
to-round
|
||||
(round-to-next-modulo-of (+ to-round 1) roundee))))
|
||||
|
||||
(define calculate-struct-size-and-offsets
|
||||
(lambda (members)
|
||||
(let* ((size 0)
|
||||
(largest-member-size 0)
|
||||
(offsets (map (lambda (member)
|
||||
(let* ((name (cdr member))
|
||||
(type (car member))
|
||||
(type-alignment (pffi-align-of type)))
|
||||
(when (> (size-of-type type) largest-member-size)
|
||||
(set! largest-member-size (size-of-type type)))
|
||||
(if (or (= size 0)
|
||||
(= (floor-remainder size type-alignment) 0))
|
||||
(begin
|
||||
(set! size (+ size type-alignment))
|
||||
(list name type (- size type-alignment)))
|
||||
(let ((next-alignment (round-to-next-modulo-of size type-alignment)))
|
||||
(set! size (+ next-alignment type-alignment))
|
||||
(list name
|
||||
type
|
||||
next-alignment)))))
|
||||
members)))
|
||||
(list (cons 'size
|
||||
(cond-expand
|
||||
;(guile (sizeof (map pffi-type->native-type (map car members))))
|
||||
(else
|
||||
(if (= (modulo size largest-member-size) 0)
|
||||
size
|
||||
(round-to-next-modulo-of size largest-member-size)))))
|
||||
(cons 'offsets offsets)))))
|
||||
|
||||
#;(define pffi-struct-make
|
||||
(lambda (c-type members . pointer)
|
||||
(for-each
|
||||
(lambda (member)
|
||||
(when (not (pair? member))
|
||||
(error "All struct members must be pairs" (list c-type member)))
|
||||
(when (not (symbol? (car member)))
|
||||
(error "All struct member types must be symbols" (list c-type member)))
|
||||
(when (not (symbol? (cdr member)))
|
||||
(error "All struct member names must be symbols" (list c-type member))))
|
||||
members)
|
||||
(let* ((size-and-offsets (calculate-struct-size-and-offsets members))
|
||||
(size (cdr (assoc 'size size-and-offsets)))
|
||||
(offsets (cdr (assoc 'offsets size-and-offsets)))
|
||||
(pointer (if (null? pointer) (pffi-pointer-allocate size) (car pointer)))
|
||||
(c-type (if (string? c-type) c-type (symbol->string c-type))))
|
||||
(struct-make c-type size pointer offsets))))
|
||||
|
||||
(define (pffi-struct-offset-get struct member-name)
|
||||
(when (not (assoc member-name (pffi-struct-members struct)))
|
||||
(error "Struct has no such member" (list struct member-name)))
|
||||
(car (cdr (cdr (assoc member-name (pffi-struct-members struct))))))
|
||||
|
||||
(define (pffi-struct-get struct member-name)
|
||||
(when (not (assoc member-name (pffi-struct-members struct)))
|
||||
(error "Struct has no such member" (list struct member-name)))
|
||||
(let ((type (car (cdr (assoc member-name (pffi-struct-members struct)))))
|
||||
(offset (car (cdr (cdr (assoc member-name (pffi-struct-members struct)))))))
|
||||
(map display (list "type: " type
|
||||
", offset: " offset
|
||||
", value: " (pffi-pointer-get (pffi-struct-pointer struct) type offset)
|
||||
#\newline))
|
||||
(pffi-pointer-get (pffi-struct-pointer struct) type offset)))
|
||||
|
||||
(define (pffi-struct-set! struct member-name value)
|
||||
(when (not (assoc member-name (pffi-struct-members struct)))
|
||||
(error "Struct has no such member" (list struct member-name)))
|
||||
(let ((type (car (cdr (assoc member-name (pffi-struct-members struct)))))
|
||||
(offset (car (cdr (cdr (assoc member-name (pffi-struct-members struct)))))))
|
||||
(pffi-pointer-set! (pffi-struct-pointer struct) type offset value)))
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(define-record-type <pffi-union>
|
||||
(union-make c-type size pointer members)
|
||||
pffi-union?
|
||||
(c-type pffi-union-c-type)
|
||||
(size pffi-union-size)
|
||||
(pointer pffi-union-pointer)
|
||||
(members pffi-union-members))
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 1))))
|
||||
|
|
@ -0,0 +1,169 @@
|
|||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) :int)
|
||||
((equal? type 'uint8) :uint)
|
||||
((equal? type 'int16) :int)
|
||||
((equal? type 'uint16) :uint)
|
||||
((equal? type 'int32) :int)
|
||||
((equal? type 'uint32) :uint)
|
||||
((equal? type 'int64) :int)
|
||||
((equal? type 'uint64) :uint)
|
||||
((equal? type 'char) :char)
|
||||
((equal? type 'unsigned-char) :uchar)
|
||||
((equal? type 'short) :short)
|
||||
((equal? type 'unsigned-short) :ushort)
|
||||
((equal? type 'int) :int)
|
||||
((equal? type 'unsigned-int) :uint)
|
||||
((equal? type 'long) :long)
|
||||
((equal? type 'unsigned-long) :ulong)
|
||||
((equal? type 'float) :float)
|
||||
((equal? type 'double) :double)
|
||||
((equal? type 'pointer) :pointer)
|
||||
((equal? type 'string) :string)
|
||||
((equal? type 'void) :void)
|
||||
((equal? type 'struct) :void)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(display "HERE: ")
|
||||
(write object)
|
||||
(newline)
|
||||
(write (cpointer? object))
|
||||
(newline)
|
||||
(cpointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(begin
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) :int)
|
||||
((equal? type 'uint8) :uint)
|
||||
((equal? type 'int16) :int)
|
||||
((equal? type 'uint16) :uint)
|
||||
((equal? type 'int32) :int)
|
||||
((equal? type 'uint32) :uint)
|
||||
((equal? type 'int64) :int)
|
||||
((equal? type 'uint64) :uint)
|
||||
((equal? type 'char) :char)
|
||||
((equal? type 'unsigned-char) :uchar)
|
||||
((equal? type 'short) :short)
|
||||
((equal? type 'unsigned-short) :ushort)
|
||||
((equal? type 'int) :int)
|
||||
((equal? type 'unsigned-int) :uint)
|
||||
((equal? type 'long) :long)
|
||||
((equal? type 'unsigned-long) :ulong)
|
||||
((equal? type 'float) :float)
|
||||
((equal? type 'double) :double)
|
||||
((equal? type 'pointer) :pointer)
|
||||
((equal? type 'string) :string)
|
||||
((equal? type 'void) :void)
|
||||
((equal? type 'struct) :void)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(define scheme-name
|
||||
(make-external-function
|
||||
(symbol->string c-name)
|
||||
(map pffi-type->native-type argument-types)
|
||||
(pffi-type->native-type return-type)
|
||||
shared-object))))))
|
||||
|
||||
(define pffi-define-callback
|
||||
(lambda ()
|
||||
(error "Not implemented")))
|
||||
|
||||
; FIXME
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((equal? type 'int8) 1)
|
||||
((equal? type 'uint8) 1)
|
||||
((equal? type 'int16) 2)
|
||||
((equal? type 'uint16) 2)
|
||||
((equal? type 'int32) 4)
|
||||
((equal? type 'uint32) 4)
|
||||
((equal? type 'int64) 8)
|
||||
((equal? type 'uint64) 8)
|
||||
((equal? type 'char) 1)
|
||||
((equal? type 'unsigned-char) 1)
|
||||
((equal? type 'short) 2)
|
||||
((equal? type 'unsigned-short) 2)
|
||||
((equal? type 'int) 4)
|
||||
((equal? type 'unsigned-int) 4)
|
||||
((equal? type 'long) 8)
|
||||
((equal? type 'unsigned-long) 8)
|
||||
((equal? type 'float) 4)
|
||||
((equal? type 'double) 8)
|
||||
((equal? type 'pointer) 8)
|
||||
|
||||
)))
|
||||
|
||||
#;(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(allocate-bytes size)))
|
||||
|
||||
;; FIXME
|
||||
(define pffi-pointer-address
|
||||
(lambda (pointer)
|
||||
0))
|
||||
|
||||
;; FIXME
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(let ((p (allocate-bytes 0)))
|
||||
(free-bytes p)
|
||||
p)))
|
||||
|
||||
#;(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(free-bytes pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(and (cpointer? pointer)
|
||||
(cpointer-null? pointer))))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
|
||||
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
|
||||
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
|
||||
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
|
||||
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
|
||||
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
|
||||
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
|
||||
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
|
||||
((equal? type 'char) (pointer-set-c-char! pointer offset value))
|
||||
((equal? type 'short) (pointer-set-c-short! pointer offset value))
|
||||
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
|
||||
((equal? type 'int) (pointer-set-c-int! pointer offset value))
|
||||
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
|
||||
((equal? type 'long) (pointer-set-c-long! pointer offset value))
|
||||
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
|
||||
((equal? type 'float) (pointer-set-c-float! pointer offset value))
|
||||
((equal? type 'double) (pointer-set-c-double! pointer offset value))
|
||||
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
|
||||
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
|
||||
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
|
||||
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
|
||||
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
|
||||
((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
|
||||
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
|
||||
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
|
||||
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
|
||||
((equal? type 'char) (pointer-ref-c-char pointer offset))
|
||||
((equal? type 'short) (pointer-ref-c-short pointer offset))
|
||||
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
|
||||
((equal? type 'int) (pointer-ref-c-int pointer offset))
|
||||
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
|
||||
((equal? type 'long) (pointer-ref-c-long pointer offset))
|
||||
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
|
||||
((equal? type 'float) (pointer-ref-c-float pointer offset))
|
||||
((equal? type 'double) (pointer-ref-c-double pointer offset))
|
||||
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
|
||||
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 1))))
|
||||
|
|
@ -0,0 +1,158 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) (c-sizeof int8_t))
|
||||
((eq? type 'uint8) (c-sizeof uint8_t))
|
||||
((eq? type 'int16) (c-sizeof int16_t))
|
||||
((eq? type 'uint16) (c-sizeof uint16_t))
|
||||
((eq? type 'int32) (c-sizeof int32_t))
|
||||
((eq? type 'uint32) (c-sizeof uint32_t))
|
||||
((eq? type 'int64) (c-sizeof int64_t))
|
||||
((eq? type 'uint64) (c-sizeof uint64_t))
|
||||
((eq? type 'char) (c-sizeof char))
|
||||
((eq? type 'unsigned-char) (c-sizeof char))
|
||||
((eq? type 'short) (c-sizeof short))
|
||||
((eq? type 'unsigned-short) (c-sizeof unsigned-short))
|
||||
((eq? type 'int) (c-sizeof int))
|
||||
((eq? type 'unsigned-int) (c-sizeof unsigned-int))
|
||||
((eq? type 'long) (c-sizeof long))
|
||||
((eq? type 'unsigned-long) (c-sizeof unsigned-long))
|
||||
((eq? type 'float) (c-sizeof float))
|
||||
((eq? type 'double) (c-sizeof double))
|
||||
((eq? type 'pointer) (c-sizeof void*))
|
||||
((eq? type 'string) (c-sizeof void*))
|
||||
((eq? type 'struct) (c-sizeof void*))
|
||||
((eq? type 'callback) (c-sizeof void*))
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
;(define c-malloc (c-function void* malloc (size_t)))
|
||||
;(define c-free (c-function int free (void*)))
|
||||
|
||||
#;(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(c-malloc size)))
|
||||
|
||||
(define pffi-pointer-address
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(number? object)))
|
||||
|
||||
#;(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(c-free pointer)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
0))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(and (pffi-pointer? pointer)
|
||||
(= (pffi-pointer-address pointer) 0))))
|
||||
|
||||
#;(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(c-string-ref pointer)))
|
||||
|
||||
;(define c-memset(c-function int memset (void* int int)))
|
||||
;(define c-snprintf (c-function int snprintf (void* size_t void*) (long double)))
|
||||
#;(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(let* ((c-string (make-c-string string-content))
|
||||
(c-string-length (bytevector-length c-string))
|
||||
(pointer (c-malloc c-string-length)))
|
||||
(c-memset pointer 0 c-string-length)
|
||||
(c-snprintf pointer c-string-length (make-c-string "%s") c-string)
|
||||
pointer)))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((bv (make-bytevector-mapping (+ pointer offset) (pffi-size-of type))))
|
||||
(cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value))
|
||||
((equal? type 'uint8) (bytevector-c-int8-set! bv 0 value))
|
||||
((equal? type 'int16) (bytevector-c-int16-set! bv 0 value))
|
||||
((equal? type 'uint16) (bytevector-c-int16-set! bv 0 value))
|
||||
((equal? type 'int32) (bytevector-c-int32-set! bv 0 value))
|
||||
((equal? type 'uint32) (bytevector-c-int32-set! bv 0 value))
|
||||
((equal? type 'int64) (bytevector-c-int64-set! bv 0 value))
|
||||
((equal? type 'uint64) (bytevector-c-int64-set! bv 0 value))
|
||||
((equal? type 'char) (bytevector-c-int8-set! bv 0 (char->integer value)))
|
||||
((equal? type 'short) (bytevector-c-short-set! bv 0 value))
|
||||
((equal? type 'unsigned-short) (bytevector-c-short-set! bv 0 value))
|
||||
((equal? type 'int) (bytevector-c-int-set! bv 0 value))
|
||||
((equal? type 'unsigned-int) (bytevector-c-int-set! bv 0 value))
|
||||
((equal? type 'long) (bytevector-c-long-set! bv 0 value))
|
||||
((equal? type 'unsigned-long) (bytevector-c-long-set! bv 0 value))
|
||||
((equal? type 'float) (bytevector-c-float-set! bv 0 value))
|
||||
((equal? type 'double) (bytevector-c-double-set! bv 0 value))
|
||||
((equal? type 'void) (bytevector-c-void*-set! bv 0 value))
|
||||
((equal? type 'pointer) (bytevector-c-void*-set! bv 0 value))))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(let ((bv (make-bytevector-mapping (+ pointer offset) (pffi-size-of type))))
|
||||
(cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0))
|
||||
((equal? type 'uint8) (bytevector-c-uint8-ref bv 0))
|
||||
((equal? type 'int16) (bytevector-c-int16-ref bv 0))
|
||||
((equal? type 'uint16) (bytevector-c-uint16-ref bv 0))
|
||||
((equal? type 'int32) (bytevector-c-int32-ref bv 0))
|
||||
((equal? type 'uint32) (bytevector-c-uint32-ref bv 0))
|
||||
((equal? type 'int64) (bytevector-c-int64-ref bv 0))
|
||||
((equal? type 'uint64) (bytevector-c-uint64-ref bv 0))
|
||||
((equal? type 'char) (integer->char (bytevector-c-uint8-ref bv 0)))
|
||||
((equal? type 'short) (bytevector-c-short-ref bv 0))
|
||||
((equal? type 'unsigned-short) (bytevector-c-unsigned-short-ref bv 0))
|
||||
((equal? type 'int) (bytevector-c-int-ref bv 0))
|
||||
((equal? type 'unsigned-int) (bytevector-c-unsigned-int-ref bv 0))
|
||||
((equal? type 'long) (bytevector-c-long-ref bv 0))
|
||||
((equal? type 'unsigned-long) (bytevector-c-unsigned-long-ref bv 0))
|
||||
((equal? type 'float) (bytevector-c-float-ref bv 0))
|
||||
((equal? type 'double) (bytevector-c-double-ref bv 0))
|
||||
((equal? type 'void) (bytevector-c-void*-ref bv 0))
|
||||
((equal? type 'pointer) (bytevector-c-void*-ref bv 0))))))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (headers path options)
|
||||
(load-shared-object path)))
|
||||
|
||||
(define-macro (pffi-type->native-type type)
|
||||
`(cond ((equal? ,type int8) int8_t)
|
||||
((equal? ,type uint8) uint8_t)
|
||||
((equal? ,type int16) int16_t)
|
||||
((equal? ,type uint16) uint16_t)
|
||||
((equal? ,type int32) int32_t)
|
||||
((equal? ,type uint32) uint32_t)
|
||||
((equal? ,type int64) int64_t)
|
||||
((equal? ,type uint64) uint64_t)
|
||||
((equal? ,type char) char)
|
||||
((equal? ,type unsigned-char) char)
|
||||
((equal? ,type short) short)
|
||||
((equal? ,type unsigned-short) unsigned-short)
|
||||
((equal? ,type int) int)
|
||||
((equal? ,type unsigned-int) unsigned-int)
|
||||
((equal? ,type long) long)
|
||||
((equal? ,type unsigned-long) unsigned-long)
|
||||
((equal? ,type float) float)
|
||||
((equal? ,type double) double)
|
||||
((equal? ,type pointer) void*)
|
||||
((equal? ,type string) void*)
|
||||
((equal? ,type void) void)
|
||||
((equal? ,type callback) void*)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" ,type))))
|
||||
|
||||
(define-macro
|
||||
(pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
`(define ,scheme-name
|
||||
(c-function ,(pffi-type->native-type return-type)
|
||||
,(cadr c-name)
|
||||
,(map pffi-type->native-type (cdr argument-types)))))
|
||||
|
||||
(define-macro
|
||||
(pffi-define-callback scheme-name return-type argument-types procedure)
|
||||
`(define ,scheme-name
|
||||
(c-callback ,(pffi-type->native-type return-type)
|
||||
,(map pffi-type->native-type (cdr argument-types))
|
||||
,procedure)))
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#lang r7rs
|
||||
(import (scheme base))
|
||||
(include "170.sld")
|
||||
|
|
@ -0,0 +1,199 @@
|
|||
(pffi-init)
|
||||
|
||||
(cond-expand
|
||||
(chicken (import (chicken foreign)))
|
||||
(else #t))
|
||||
|
||||
(define slash (cond-expand (windows "\\") (else "/")))
|
||||
|
||||
(cond-expand
|
||||
(windows
|
||||
(pffi-define-library libc '("stdio.h") "ucrtbase"))
|
||||
(else
|
||||
(pffi-define-library libc
|
||||
'("stdio.h" "error.h")
|
||||
"c"
|
||||
'((additional-versions ("6"))))))
|
||||
|
||||
(pffi-define-library libuv
|
||||
'("uv.h")
|
||||
"uv"
|
||||
'((additional-versions ("1" "1.0.0"))))
|
||||
|
||||
(cond-expand
|
||||
(windows (pffi-define-library libkernel '("windows.h") "kernel32"))
|
||||
(else #f))
|
||||
|
||||
;(pffi-define c-puts libc 'puts 'int '(string))
|
||||
(pffi-define uv-default-loop libuv 'uv_default_loop 'pointer '())
|
||||
(pffi-define uv-translate-sys-error libuv 'uv_translate_sys_error 'int '(int))
|
||||
(pffi-define uv-strerror libuv 'uv_strerror 'pointer '(int))
|
||||
(pffi-define uv-fs-stat libuv 'uv_fs_stat 'int '(pointer pointer pointer pointer))
|
||||
(pffi-define uv-fs-mkdir libuv 'uv_fs_mkdir 'int '(pointer pointer pointer int pointer))
|
||||
(pffi-define uv-fs-rmdir libuv 'uv_fs_rmdir 'int '(pointer pointer pointer pointer))
|
||||
(pffi-define uv-fs-opendir libuv 'uv_fs_opendir 'int '(pointer pointer pointer pointer))
|
||||
(pffi-define uv-fs-closedir libuv 'uv_fs_closedir 'int '(pointer pointer pointer pointer))
|
||||
(pffi-define uv-fs-scandir libuv 'uv_fs_scandir 'int '(pointer pointer pointer int pointer))
|
||||
(pffi-define uv-fs-scandir-next libuv 'uv_fs_scandir_next 'int '(pointer pointer))
|
||||
(pffi-define uv-fs-get-ptr libuv 'uv_fs_get_ptr 'pointer '(pointer))
|
||||
;(pffi-define uv-fs-scandir libuv 'uv_fs_scandir 'int '(pointer pointer pointer int pointer))
|
||||
;(pffi-define c-printf libc 'printf 'int '(string))
|
||||
;(pffi-define c-cos libc 'cos 'double '(double))
|
||||
|
||||
(define UV-FS 6)
|
||||
(define uv-fs-t-make
|
||||
(lambda ()
|
||||
(let ((p (pffi-pointer-allocate (+ (pffi-size-of 'pointer) ; .loop
|
||||
(pffi-size-of 'int) ; .uv_fs_type
|
||||
(pffi-size-of 'pointer) ; .path
|
||||
(pffi-size-of 'int) ; .result
|
||||
(pffi-size-of 'pointer) ; .statbuf
|
||||
(pffi-size-of 'pointer) ; .ptr
|
||||
512 ; Temporary fix
|
||||
))))
|
||||
(pffi-pointer-set! p 'int (pffi-size-of 'pointer) UV-FS)
|
||||
p)))
|
||||
|
||||
(define handle-errors
|
||||
(lambda (return-code . irritants)
|
||||
(when (< return-code 0)
|
||||
(if (null? irritants)
|
||||
(raise-continuable (pffi-pointer->string (uv-strerror (uv-translate-sys-error return-code))))
|
||||
(raise-continuable (pffi-pointer->string (uv-strerror (uv-translate-sys-error return-code))))))
|
||||
return-code))
|
||||
|
||||
|
||||
(define-record-type file-info-record
|
||||
(file-info-record-make device inode mode nlinks uid gid rdev size blksize blocks atime mtime ctime fname/port follow?)
|
||||
file-info?
|
||||
(device file-info:device)
|
||||
(inode file-info:inode)
|
||||
(mode file-info:mode)
|
||||
(nlinks file-info:nlinks)
|
||||
(uid file-info:uid)
|
||||
(gid file-info:gid)
|
||||
(rdev file-info:rdev)
|
||||
(size file-info:size)
|
||||
(blksize file-info:blksize)
|
||||
(blocks file-info:blocks)
|
||||
(atime file-info:atime)
|
||||
(mtime file-info:mtime)
|
||||
(ctime file-info:ctime)
|
||||
(fname/port file-info:fname/port)
|
||||
(follow? file-info:follow?))
|
||||
|
||||
; FIX make the "follow?" argument work
|
||||
(define file-info
|
||||
(lambda (fname/port follow?)
|
||||
(let* ((req-type (uv-fs-t-make)))
|
||||
(handle-errors (uv-fs-stat (uv-default-loop)
|
||||
req-type
|
||||
(pffi-string->pointer fname/port)
|
||||
(pffi-pointer-null)))
|
||||
(let ((stat-pointer (uv-fs-get-ptr req-type)))
|
||||
(file-info-record-make (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 0))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 1))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 2))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 3))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 4))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 5))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 6))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 7))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 8))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 9))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 10))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 11))
|
||||
(pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 12))
|
||||
fname/port
|
||||
follow?)))))
|
||||
|
||||
(define file-info-directory?
|
||||
(lambda (file-info)
|
||||
; Try to open the file-info path as directory, if it fails say it's not a directory
|
||||
(let ((req-type (uv-fs-t-make)))
|
||||
(let* ((file-path (file-info:fname/port file-info))
|
||||
(result (uv-fs-opendir (uv-default-loop)
|
||||
req-type
|
||||
(pffi-string->pointer file-path)
|
||||
(pffi-pointer-null))))
|
||||
(cond ((not (file-exists? file-path)) #f)
|
||||
((not (= result -20)) #t)
|
||||
; If it is a dir then it's open and needs to be closed
|
||||
(else (uv-fs-closedir (uv-default-loop)
|
||||
req-type
|
||||
(uv-fs-get-ptr req-type)
|
||||
(pffi-pointer-null))
|
||||
#f))))))
|
||||
|
||||
(define create-directory
|
||||
(lambda (fname . permission-bits)
|
||||
(let ((req-type (uv-fs-t-make))
|
||||
(mode (if (null? permission-bits) #o775 (car permission-bits))))
|
||||
(handle-errors (uv-fs-mkdir (uv-default-loop)
|
||||
req-type
|
||||
(pffi-string->pointer fname)
|
||||
mode
|
||||
(pffi-pointer-null))
|
||||
fname))))
|
||||
|
||||
(define delete-directory
|
||||
(lambda (fname)
|
||||
(let ((req-type (uv-fs-t-make)))
|
||||
(handle-errors
|
||||
(uv-fs-rmdir (uv-default-loop)
|
||||
req-type
|
||||
(pffi-string->pointer fname)
|
||||
(pffi-pointer-null))
|
||||
fname))))
|
||||
|
||||
(define directory-files
|
||||
(lambda (dir . args)
|
||||
(letrec* ((dotfiles? (if (null? args) #f (car args)))
|
||||
(req-type (uv-fs-t-make))
|
||||
(result (handle-errors (uv-fs-scandir (uv-default-loop)
|
||||
req-type
|
||||
(pffi-string->pointer dir)
|
||||
0
|
||||
(pffi-pointer-null))
|
||||
dir))
|
||||
(uv-dirent-t (pffi-pointer-allocate (+ (pffi-size-of 'pointer)
|
||||
(pffi-size-of 'int)
|
||||
512)))
|
||||
(files (list))
|
||||
(looper
|
||||
(lambda ()
|
||||
(let ((next-file (uv-fs-scandir-next req-type uv-dirent-t)))
|
||||
(when (= next-file 0) ; End of file
|
||||
(let ((file-name (string-copy (pffi-pointer->string (pffi-pointer-get uv-dirent-t 'pointer 0)))))
|
||||
(if (and (> (string-length file-name) 0)
|
||||
(char=? (string-ref file-name 0) #\.))
|
||||
(if dotfiles? (set! files (append files (list file-name))))
|
||||
(set! files (append files (list file-name)))
|
||||
)
|
||||
(looper)))))))
|
||||
(looper)
|
||||
files
|
||||
;(write result)
|
||||
;(newline)
|
||||
;(write (uv-fs-scandir-next req-type uv-dirent-t))
|
||||
;(newline)
|
||||
;(write (pffi-pointer->string (pffi-pointer-get uv-dirent-t 'pointer 0)))
|
||||
;(newline)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;(write (uv-default-loop))
|
||||
;(newline)
|
||||
;(write (uv-fs-scandir (uv-default-loop) (pffi-string->pointer ".") 0 (pffi-pointer-null)))
|
||||
;(newline)
|
||||
;(write (c-opendir (pffi-string->pointer ".")))
|
||||
;(newline)
|
||||
;(c-puts (pffi-string->pointer "Hello world"))
|
||||
;(c-printf (pffi-string->pointer "Hello world\n"))
|
||||
;(newline)
|
||||
;(c-cos 5.5)
|
||||
;#t
|
||||
)))
|
||||
|
|
@ -0,0 +1,84 @@
|
|||
(define-library
|
||||
(srfi 170)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(retropikzel pffi))
|
||||
(export ;posix-error?
|
||||
;posix-error-name
|
||||
;posix-error-message
|
||||
;open-file
|
||||
;fd->port
|
||||
create-directory
|
||||
;create-fifo
|
||||
;create-hard-link
|
||||
;create-symlink
|
||||
;read-symlink
|
||||
;rename-file
|
||||
delete-directory
|
||||
;set-file-owner
|
||||
;set-file-times
|
||||
;truncate-file
|
||||
file-info
|
||||
file-info?
|
||||
file-info:device
|
||||
file-info:inode
|
||||
file-info:mode
|
||||
file-info:nlinks
|
||||
file-info:uid
|
||||
file-info:gid
|
||||
file-info:rdev
|
||||
file-info:size
|
||||
file-info:blksize
|
||||
file-info:blocks
|
||||
file-info:atime
|
||||
file-info:mtime
|
||||
file-info:ctime
|
||||
file-info-directory?
|
||||
;file-info-fifo?
|
||||
;file-info-symlink?
|
||||
;file-info-regular?
|
||||
;file-info-socket?
|
||||
;file-info-device?
|
||||
;set-file-mode
|
||||
directory-files
|
||||
;make-directory-files-generator
|
||||
;open-directory
|
||||
;read-directory
|
||||
;close-directory
|
||||
;real-path
|
||||
;file-space
|
||||
;temp-file-prefix
|
||||
;create-temp-file
|
||||
;call-with-temporary-filename
|
||||
;umask
|
||||
;set-umask!
|
||||
;current-directory
|
||||
;set-current-directory!
|
||||
;pid
|
||||
;nice
|
||||
;user-uid
|
||||
;user-gid
|
||||
;user-effective-uid
|
||||
;user-effective-gid
|
||||
;user-supplementary-gids
|
||||
;user-info
|
||||
;user-info?
|
||||
;user-info:name
|
||||
;user-info:uid
|
||||
;user-info:gid
|
||||
;user-info:home-dir
|
||||
;user-info:shell
|
||||
;user-info:full-name
|
||||
;user-info:parsed-full-name
|
||||
;group-info
|
||||
;group-info?
|
||||
;group-info:name
|
||||
;group-info:gid
|
||||
;posix-time
|
||||
;monotonic-time
|
||||
;set-environment-variable!
|
||||
;delete-environment-variable!
|
||||
;terminal?
|
||||
)
|
||||
(include "170.scm"))
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
;; This file exists for guile compability
|
||||
(define-library
|
||||
(srfi 170)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(retropikzel r7rs-pffi))
|
||||
(export ;posix-error?
|
||||
;posix-error-name
|
||||
;posix-error-message
|
||||
;open-file
|
||||
;fd->port
|
||||
create-directory
|
||||
;create-fifo
|
||||
;create-hard-link
|
||||
;create-symlink
|
||||
;read-symlink
|
||||
;rename-file
|
||||
delete-directory
|
||||
;set-file-owner
|
||||
;set-file-times
|
||||
;truncate-file
|
||||
file-info
|
||||
file-info?
|
||||
file-info:device
|
||||
file-info:inode
|
||||
file-info:mode
|
||||
file-info:nlinks
|
||||
file-info:uid
|
||||
file-info:gid
|
||||
file-info:rdev
|
||||
file-info:size
|
||||
file-info:blksize
|
||||
file-info:blocks
|
||||
file-info:atime
|
||||
file-info:mtime
|
||||
file-info:ctime
|
||||
file-info-directory?
|
||||
;file-info-fifo?
|
||||
;file-info-symlink?
|
||||
;file-info-regular?
|
||||
;file-info-socket?
|
||||
;file-info-device?
|
||||
;set-file-mode
|
||||
directory-files
|
||||
;make-directory-files-generator
|
||||
;open-directory
|
||||
;read-directory
|
||||
;close-directory
|
||||
;real-path
|
||||
;file-space
|
||||
;temp-file-prefix
|
||||
;create-temp-file
|
||||
;call-with-temporary-filename
|
||||
;umask
|
||||
;set-umask!
|
||||
;current-directory
|
||||
;set-current-directory!
|
||||
;pid
|
||||
;nice
|
||||
;user-uid
|
||||
;user-gid
|
||||
;user-effective-uid
|
||||
;user-effective-gid
|
||||
;user-supplementary-gids
|
||||
;user-info
|
||||
;user-info?
|
||||
;user-info:name
|
||||
;user-info:uid
|
||||
;user-info:gid
|
||||
;user-info:home-dir
|
||||
;user-info:shell
|
||||
;user-info:full-name
|
||||
;user-info:parsed-full-name
|
||||
;group-info
|
||||
;group-info?
|
||||
;group-info:name
|
||||
;group-info:gid
|
||||
;posix-time
|
||||
;monotonic-time
|
||||
;set-environment-variable!
|
||||
;delete-environment-variable!
|
||||
;terminal?
|
||||
)
|
||||
(include "170.scm"))
|
||||
Binary file not shown.
|
|
@ -0,0 +1,233 @@
|
|||
/* Generated from snow/retropikzel/pffi.sld by the CHICKEN compiler
|
||||
http://www.call-cc.org
|
||||
Version 6.0.0 (rev fbb6ce81)
|
||||
linux-unix-gnu-x86-64 [ 64bit dload ptables ]
|
||||
command line: snow/retropikzel/pffi.sld -output-file src/retropikzel.pffi.c -emit-all-import-libraries -optimize-level 3
|
||||
uses: eval extras expand lolevel r7lib library
|
||||
*/
|
||||
#include "chicken.h"
|
||||
|
||||
static C_PTABLE_ENTRY *create_ptable(void);
|
||||
C_noret_decl(C_eval_toplevel)
|
||||
C_extern void C_ccall C_eval_toplevel(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(C_extras_toplevel)
|
||||
C_extern void C_ccall C_extras_toplevel(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(C_expand_toplevel)
|
||||
C_extern void C_ccall C_expand_toplevel(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(C_lolevel_toplevel)
|
||||
C_extern void C_ccall C_lolevel_toplevel(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(C_r7lib_toplevel)
|
||||
C_extern void C_ccall C_r7lib_toplevel(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(C_library_toplevel)
|
||||
C_extern void C_ccall C_library_toplevel(C_word c,C_word *av) C_noret;
|
||||
|
||||
static C_word lf[2];
|
||||
static double C_possibly_force_alignment;
|
||||
static C_char li0[] C_aligned={C_lihdr(0,0,10),40,116,111,112,108,101,118,101,108,41,0,0,0,0,0,0};
|
||||
|
||||
|
||||
C_noret_decl(f_149)
|
||||
static void C_ccall f_149(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(f_152)
|
||||
static void C_ccall f_152(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(f_155)
|
||||
static void C_ccall f_155(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(f_158)
|
||||
static void C_ccall f_158(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(f_161)
|
||||
static void C_ccall f_161(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(f_164)
|
||||
static void C_ccall f_164(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(f_170)
|
||||
static void C_ccall f_170(C_word c,C_word *av) C_noret;
|
||||
C_noret_decl(C_toplevel)
|
||||
C_extern void C_ccall C_toplevel(C_word c,C_word *av) C_noret;
|
||||
|
||||
/* k147 */
|
||||
static void C_ccall f_149(C_word c,C_word *av){
|
||||
C_word tmp;
|
||||
C_word t0=av[0];
|
||||
C_word t1=av[1];
|
||||
C_word t2;
|
||||
C_word t3;
|
||||
C_word *a;
|
||||
C_check_for_interrupt;
|
||||
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
|
||||
C_save_and_reclaim((void *)f_149,c,av);}
|
||||
a=C_alloc(3);
|
||||
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_152,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
|
||||
C_word *av2=av;
|
||||
av2[0]=C_SCHEME_UNDEFINED;
|
||||
av2[1]=t2;
|
||||
C_eval_toplevel(2,av2);}}
|
||||
|
||||
/* k150 in k147 */
|
||||
static void C_ccall f_152(C_word c,C_word *av){
|
||||
C_word tmp;
|
||||
C_word t0=av[0];
|
||||
C_word t1=av[1];
|
||||
C_word t2;
|
||||
C_word t3;
|
||||
C_word t4;
|
||||
C_word *a;
|
||||
C_check_for_interrupt;
|
||||
if(C_unlikely(!C_demand(C_calculate_demand(11,c,2)))){
|
||||
C_save_and_reclaim((void *)f_152,c,av);}
|
||||
a=C_alloc(11);
|
||||
t2=C_a_i_provide(&a,1,lf[0]);
|
||||
t3=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_155,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
|
||||
C_word *av2=av;
|
||||
av2[0]=C_SCHEME_UNDEFINED;
|
||||
av2[1]=t3;
|
||||
C_r7lib_toplevel(2,av2);}}
|
||||
|
||||
/* k153 in k150 in k147 */
|
||||
static void C_ccall f_155(C_word c,C_word *av){
|
||||
C_word tmp;
|
||||
C_word t0=av[0];
|
||||
C_word t1=av[1];
|
||||
C_word t2;
|
||||
C_word t3;
|
||||
C_word *a;
|
||||
C_check_for_interrupt;
|
||||
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
|
||||
C_save_and_reclaim((void *)f_155,c,av);}
|
||||
a=C_alloc(3);
|
||||
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_158,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
|
||||
C_word *av2=av;
|
||||
av2[0]=C_SCHEME_UNDEFINED;
|
||||
av2[1]=t2;
|
||||
C_lolevel_toplevel(2,av2);}}
|
||||
|
||||
/* k156 in k153 in k150 in k147 */
|
||||
static void C_ccall f_158(C_word c,C_word *av){
|
||||
C_word tmp;
|
||||
C_word t0=av[0];
|
||||
C_word t1=av[1];
|
||||
C_word t2;
|
||||
C_word t3;
|
||||
C_word *a;
|
||||
C_check_for_interrupt;
|
||||
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
|
||||
C_save_and_reclaim((void *)f_158,c,av);}
|
||||
a=C_alloc(3);
|
||||
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_161,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
|
||||
C_word *av2=av;
|
||||
av2[0]=C_SCHEME_UNDEFINED;
|
||||
av2[1]=t2;
|
||||
C_expand_toplevel(2,av2);}}
|
||||
|
||||
/* k159 in k156 in k153 in k150 in k147 */
|
||||
static void C_ccall f_161(C_word c,C_word *av){
|
||||
C_word tmp;
|
||||
C_word t0=av[0];
|
||||
C_word t1=av[1];
|
||||
C_word t2;
|
||||
C_word t3;
|
||||
C_word *a;
|
||||
C_check_for_interrupt;
|
||||
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
|
||||
C_save_and_reclaim((void *)f_161,c,av);}
|
||||
a=C_alloc(3);
|
||||
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_164,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
|
||||
C_word *av2=av;
|
||||
av2[0]=C_SCHEME_UNDEFINED;
|
||||
av2[1]=t2;
|
||||
C_extras_toplevel(2,av2);}}
|
||||
|
||||
/* k162 in k159 in k156 in k153 in k150 in k147 */
|
||||
static void C_ccall f_164(C_word c,C_word *av){
|
||||
C_word tmp;
|
||||
C_word t0=av[0];
|
||||
C_word t1=av[1];
|
||||
C_word t2;
|
||||
C_word t3;
|
||||
C_word *a;
|
||||
C_check_for_interrupt;
|
||||
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
|
||||
C_save_and_reclaim((void *)f_164,c,av);}
|
||||
a=C_alloc(3);
|
||||
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_170,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);
|
||||
C_trace(C_text("chicken.base#implicit-exit-handler"));
|
||||
t3=C_fast_retrieve(lf[1]);{
|
||||
C_word *av2=av;
|
||||
av2[0]=t3;
|
||||
av2[1]=t2;
|
||||
((C_proc)(void*)(*((C_word*)t3+1)))(2,av2);}}
|
||||
|
||||
/* k168 in k162 in k159 in k156 in k153 in k150 in k147 */
|
||||
static void C_ccall f_170(C_word c,C_word *av){
|
||||
C_word tmp;
|
||||
C_word t0=av[0];
|
||||
C_word t1=av[1];
|
||||
C_word t2;
|
||||
C_word *a;
|
||||
C_check_for_interrupt;
|
||||
if(C_unlikely(!C_demand(C_calculate_demand(0,c,1)))){
|
||||
C_save_and_reclaim((void *)f_170,c,av);}
|
||||
t2=t1;{
|
||||
C_word *av2=av;
|
||||
av2[0]=t2;
|
||||
av2[1]=((C_word*)t0)[2];
|
||||
((C_proc)(void*)(*((C_word*)t2+1)))(2,av2);}}
|
||||
|
||||
/* toplevel */
|
||||
static int toplevel_initialized=0;
|
||||
C_main_entry_point
|
||||
|
||||
void C_ccall C_toplevel(C_word c,C_word *av){
|
||||
C_word tmp;
|
||||
C_word t0=av[0];
|
||||
C_word t1=av[1];
|
||||
C_word t2;
|
||||
C_word t3;
|
||||
C_word *a;
|
||||
if(toplevel_initialized) {C_kontinue(t1,C_SCHEME_UNDEFINED);}
|
||||
else C_toplevel_entry(C_text("toplevel"));
|
||||
C_check_nursery_minimum(C_calculate_demand(3,c,2));
|
||||
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
|
||||
C_save_and_reclaim((void*)C_toplevel,c,av);}
|
||||
toplevel_initialized=1;
|
||||
if(C_unlikely(!C_demand_2(14))){
|
||||
C_save(t1);
|
||||
C_rereclaim2(14*sizeof(C_word),1);
|
||||
t1=C_restore;}
|
||||
a=C_alloc(3);
|
||||
C_initialize_lf(lf,2);
|
||||
lf[0]=C_h_intern(&lf[0],17, C_text("retropikzel.pffi#"));
|
||||
lf[1]=C_h_intern(&lf[1],34, C_text("chicken.base#implicit-exit-handler"));
|
||||
C_register_lf2(lf,2,create_ptable());{}
|
||||
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_149,a[2]=t1,tmp=(C_word)a,a+=3,tmp);{
|
||||
C_word *av2=av;
|
||||
av2[0]=C_SCHEME_UNDEFINED;
|
||||
av2[1]=t2;
|
||||
C_library_toplevel(2,av2);}}
|
||||
|
||||
#ifdef C_ENABLE_PTABLES
|
||||
static C_PTABLE_ENTRY ptable[9] = {
|
||||
{C_text("f_149:snow_2fretropikzel_2fpffi_2esld"),(void*)f_149},
|
||||
{C_text("f_152:snow_2fretropikzel_2fpffi_2esld"),(void*)f_152},
|
||||
{C_text("f_155:snow_2fretropikzel_2fpffi_2esld"),(void*)f_155},
|
||||
{C_text("f_158:snow_2fretropikzel_2fpffi_2esld"),(void*)f_158},
|
||||
{C_text("f_161:snow_2fretropikzel_2fpffi_2esld"),(void*)f_161},
|
||||
{C_text("f_164:snow_2fretropikzel_2fpffi_2esld"),(void*)f_164},
|
||||
{C_text("f_170:snow_2fretropikzel_2fpffi_2esld"),(void*)f_170},
|
||||
{C_text("toplevel:snow_2fretropikzel_2fpffi_2esld"),(void*)C_toplevel},
|
||||
{NULL,NULL}};
|
||||
#endif
|
||||
|
||||
static C_PTABLE_ENTRY *create_ptable(void){
|
||||
#ifdef C_ENABLE_PTABLES
|
||||
return ptable;
|
||||
#else
|
||||
return NULL;
|
||||
#endif
|
||||
}
|
||||
|
||||
/*
|
||||
(o e)|safe calls: 2
|
||||
o|replaced variables: 1
|
||||
o|removed binding forms: 15
|
||||
o|removed binding forms: 1
|
||||
*/
|
||||
/* end of file */
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,5 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(bar baz))
|
||||
|
||||
(hello)
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
(define-library
|
||||
(bar baz)
|
||||
(import (scheme base)
|
||||
(scheme write))
|
||||
(export hello)
|
||||
(begin
|
||||
(define hello (lambda () (display "Hello") (newline)))))
|
||||
Loading…
Reference in New Issue