Move towards using chibi
This commit is contained in:
parent
053dd9a697
commit
339ad3c408
|
|
@ -10,5 +10,5 @@ test
|
|||
*.so
|
||||
!src
|
||||
*.rkt
|
||||
README.txt
|
||||
README.html
|
||||
*.import.*
|
||||
|
|
|
|||
56
Makefile
56
Makefile
|
|
@ -1,56 +1,22 @@
|
|||
PREFIX=/usr/local
|
||||
|
||||
build:
|
||||
csc -R r7rs -X r7rs -I snow/foreign/c -I snow/foreign/c/primitives -static -c -J -unit foreign.c -o foreign.c.o snow/foreign/c.sld
|
||||
ar rcs foreign.c.a foreign.c.o
|
||||
csc -R r7rs -X r7rs -static -c -J -unit srfi-170 -o srfi-170.o snow/srfi/170.sld
|
||||
ar rcs srfi-170.a srfi-170.o
|
||||
csc -R r7rs -X r7rs -static -c -J -unit libs.util -o libs.util.o libs/util.sld
|
||||
ar rcs libs.util.a libs.util.o
|
||||
csc -R r7rs -X r7rs -static -c -J -unit libs.library-util -o libs.library-util.o libs/library-util.sld
|
||||
ar rcs libs.library-util.a libs.library-util.o
|
||||
csc -R r7rs -X r7rs -static -c -J -unit libs.data -o libs.data.o libs/data.sld
|
||||
ar rcs libs.data.a libs.data.o
|
||||
csc -R r7rs -X r7rs -I snow/foreign/c -static \
|
||||
-o compile-r7rs \
|
||||
-uses libs.util \
|
||||
-uses libs.library-util \
|
||||
-uses libs.data \
|
||||
-uses foreign.c \
|
||||
-uses srfi-170 \
|
||||
compile-r7rs.scm
|
||||
all: build
|
||||
|
||||
# Does uninstall because without that the changes do not seem to update
|
||||
install: uninstall
|
||||
#mkdir -p ${PREFIX}/lib/compile-r7rs/snow
|
||||
#cp -r snow/* ${PREFIX}/lib/compile-r7rs/snow
|
||||
#cp -r libs ${PREFIX}/lib/compile-r7rs/snow/libs
|
||||
#cp compile-r7rs.scm ${PREFIX}/lib/compile-r7rs/main.scm
|
||||
build:
|
||||
markdown README.md > README.html
|
||||
echo "#!/bin/sh" > compile-r7rs
|
||||
echo "chibi-scheme -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/main.scm" >> compile-r7rs
|
||||
|
||||
install:
|
||||
mkdir -p ${PREFIX}/lib/compile-r7rs
|
||||
cp -r libs ${PREFIX}/lib/compile-r7rs/libs
|
||||
cp compile-r7rs.scm ${PREFIX}/lib/compile-r7rs/main.scm
|
||||
install compile-r7rs ${PREFIX}/bin/compile-r7rs
|
||||
|
||||
snow:
|
||||
mkdir -p snow
|
||||
cp -r ../foreign-c/foreign snow/
|
||||
cp -r ../foreign-c-srfi-170/srfi snow/
|
||||
|
||||
clean-snow:
|
||||
rm -rf snow
|
||||
|
||||
install-compile-r7rs-docker:
|
||||
install compile-r7rs-docker.sh ${PREFIX}/bin/compile-r7rs-docker
|
||||
|
||||
uninstall:
|
||||
rm -rf ${PREFIX}/lib/compile-r7rs/snow
|
||||
rm -rf ${PREFIX}/lib/compile-r7rs
|
||||
rm -rf ${PREFIX}/bin/compile-r7rs
|
||||
|
||||
dist:
|
||||
mkdir -p dist
|
||||
|
||||
# Uses wine and innosetup
|
||||
installer-exe: dist
|
||||
cp README.md README.txt
|
||||
wine "${HOME}/.wine/drive_c/Program Files (x86)/Inno Setup 6./Compil32.exe" /cc installer.iss
|
||||
|
||||
test-r6rs:
|
||||
rm -rf /tmp/compile-r7rs-test-result.txt
|
||||
mkdir -p test
|
||||
|
|
|
|||
|
|
@ -1,393 +0,0 @@
|
|||
(define-library
|
||||
(foreign c)
|
||||
(cond-expand
|
||||
(chibi
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(chibi ast)
|
||||
(scheme inexact)
|
||||
(chibi))
|
||||
(include-shared "c/primitives/chibi/foreign-c"))
|
||||
(chicken
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(chicken base)
|
||||
(chicken foreign)
|
||||
(chicken locative)
|
||||
(chicken syntax)
|
||||
(chicken memory)
|
||||
(chicken random)))
|
||||
#;(cyclone
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(cyclone foreign)
|
||||
(scheme cyclone primitives)))
|
||||
(gambit
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(only (gambit) c-declare c-lambda c-define define-macro)))
|
||||
(gauche
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(gauche base)
|
||||
(foreign c primitives gauche)))
|
||||
#;(gerbil
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)))
|
||||
(guile
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(system foreign)
|
||||
(system foreign-library)
|
||||
(only (guile) include-from-path)
|
||||
(only (rnrs bytevectors)
|
||||
bytevector-uint-set!
|
||||
bytevector-uint-ref)))
|
||||
(kawa
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)))
|
||||
(mit-scheme
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)))
|
||||
#;(larceny
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(rename (primitives r5rs:require) (r5rs:require require))
|
||||
(primitives std-ffi)
|
||||
(primitives foreign-procedure)
|
||||
(primitives foreign-file)
|
||||
(primitives foreign-stdlib)
|
||||
(primitives system-interface)))
|
||||
(mosh
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(mosh ffi)))
|
||||
(racket
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(only (racket base) system-type)
|
||||
(ffi winapi)
|
||||
(compatibility mlist)
|
||||
(ffi unsafe)
|
||||
(ffi vector)))
|
||||
(sagittarius
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(except (sagittarius ffi) c-free c-malloc)
|
||||
(sagittarius)))
|
||||
#;(skint
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)))
|
||||
(stklos
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(only (stklos)
|
||||
%make-callback
|
||||
make-external-function
|
||||
allocate-bytes
|
||||
free-bytes
|
||||
cpointer?
|
||||
cpointer-null?
|
||||
cpointer-data
|
||||
cpointer-data-set!
|
||||
cpointer-set!
|
||||
cpointer-ref
|
||||
void?))
|
||||
(export ; calculate-struct-size-and-offsets
|
||||
;struct-make
|
||||
get-environment-variable
|
||||
file-exists?
|
||||
make-external-function
|
||||
foreign-c:string-split
|
||||
c-bytevector-pointer-set!
|
||||
c-bytevector-pointer-ref))
|
||||
#;(tr7
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
;(scheme inexact)
|
||||
(scheme process-context)))
|
||||
(ypsilon
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme process-context)
|
||||
(ypsilon c-ffi)
|
||||
(ypsilon c-types)
|
||||
(only (core) define-macro syntax-case))))
|
||||
(export ;;;; Primitives 1
|
||||
c-type-size
|
||||
define-c-library
|
||||
define-c-procedure
|
||||
c-bytevector?
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-pointer-set!
|
||||
c-bytevector-pointer-ref
|
||||
|
||||
;;;; Primitives 2
|
||||
define-c-callback
|
||||
|
||||
;;;; c-bytevector
|
||||
make-c-null
|
||||
c-null?
|
||||
c-free
|
||||
call-with-address-of
|
||||
|
||||
bytevector->c-bytevector
|
||||
c-bytevector->bytevector
|
||||
|
||||
;;;; Utilities
|
||||
libc-name
|
||||
|
||||
;; TODO endianness
|
||||
native-endianness
|
||||
make-c-bytevector
|
||||
;; TODO c-bytevector=?
|
||||
;; TODO c-bytevector-fill!
|
||||
;; TODO c-bytevector-copy!
|
||||
;; TODO c-bytevector-copy
|
||||
c-bytevector-s8-set!
|
||||
c-bytevector-s8-ref
|
||||
;; TODO c-bytevector->u8-list
|
||||
;; TODO u8-list->c-bytevector
|
||||
|
||||
c-bytevector-uchar-ref
|
||||
c-bytevector-char-ref
|
||||
c-bytevector-char-set!
|
||||
c-bytevector-uchar-set!
|
||||
|
||||
c-bytevector-uint-ref
|
||||
c-bytevector-sint-ref
|
||||
c-bytevector-sint-set!
|
||||
c-bytevector-uint-set!
|
||||
;; TODO bytevector->uint-list
|
||||
;; TODO bytevector->sint-list
|
||||
;; TODO uint-list->bytevector
|
||||
;; TODO sint-list->bytevector
|
||||
|
||||
c-bytevector-u16-ref
|
||||
c-bytevector-s16-ref
|
||||
c-bytevector-u16-native-ref
|
||||
c-bytevector-s16-native-ref
|
||||
c-bytevector-u16-set!
|
||||
c-bytevector-s16-set!
|
||||
c-bytevector-u16-native-set!
|
||||
c-bytevector-s16-native-set!
|
||||
|
||||
c-bytevector-u32-ref
|
||||
c-bytevector-s32-ref
|
||||
c-bytevector-u32-native-ref
|
||||
c-bytevector-s32-native-ref
|
||||
c-bytevector-u32-set!
|
||||
c-bytevector-s32-set!
|
||||
c-bytevector-u32-native-set!
|
||||
c-bytevector-s32-native-set!
|
||||
|
||||
c-bytevector-u64-ref
|
||||
c-bytevector-s64-ref
|
||||
c-bytevector-s64-native-ref
|
||||
c-bytevector-u64-native-ref
|
||||
c-bytevector-u64-set!
|
||||
c-bytevector-s64-set!
|
||||
c-bytevector-u64-native-set!
|
||||
c-bytevector-s64-native-set!
|
||||
|
||||
c-bytevector-ieee-single-native-ref
|
||||
c-bytevector-ieee-single-ref
|
||||
|
||||
c-bytevector-ieee-double-native-ref
|
||||
c-bytevector-ieee-double-ref
|
||||
|
||||
c-bytevector-ieee-single-native-set!
|
||||
c-bytevector-ieee-single-set!
|
||||
|
||||
c-bytevector-ieee-double-native-set!
|
||||
c-bytevector-ieee-double-set!
|
||||
|
||||
string->c-utf8
|
||||
;; TODO string->c-utf16
|
||||
;; TODO string->c-utf32
|
||||
|
||||
c-utf8->string
|
||||
;; TODO c-utf16->string
|
||||
;; TODO c-utf32->string
|
||||
|
||||
|
||||
;c-string-length ;; TODO Documentation, Testing
|
||||
|
||||
;; c-struct
|
||||
;pffi-define-struct;define-c-struct
|
||||
;pffi-struct-pointer;c-struct-bytevector
|
||||
;pffi-struct-offset-get;c-struct-offset
|
||||
;pffi-struct-set!;c-struct-set!
|
||||
;pffi-struct-get;c-struct-get
|
||||
|
||||
;; c-array
|
||||
;define-c-array (?)
|
||||
;pffi-array-allocate;make-c-array
|
||||
;pffi-array-pointer;c-array-pointer
|
||||
;pffi-array?;c-array?
|
||||
;pffi-pointer->array;c-bytevector->array
|
||||
;pffi-array-get;c-array-get
|
||||
;pffi-array-set!;c-array-set!
|
||||
;pffi-list->array;list->c-array
|
||||
;pffi-array->list;c-array->list
|
||||
|
||||
;; c-variable
|
||||
;define-c-variable (?)
|
||||
)
|
||||
(begin
|
||||
(define type->libffi-type-number
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 1)
|
||||
((equal? type 'uint8) 2)
|
||||
((equal? type 'int16) 3)
|
||||
((equal? type 'uint16) 4)
|
||||
((equal? type 'int32) 5)
|
||||
((equal? type 'uint32) 6)
|
||||
((equal? type 'int64) 7)
|
||||
((equal? type 'uint64) 8)
|
||||
((equal? type 'char) 9)
|
||||
((equal? type 'unsigned-char) 10)
|
||||
((equal? type 'short) 11)
|
||||
((equal? type 'unsigned-short) 12)
|
||||
((equal? type 'int) 13)
|
||||
((equal? type 'unsigned-int) 14)
|
||||
((equal? type 'long) 15)
|
||||
((equal? type 'unsigned-long) 16)
|
||||
((equal? type 'float) 17)
|
||||
((equal? type 'double) 18)
|
||||
((equal? type 'void) 19)
|
||||
((equal? type 'pointer) 20)
|
||||
((equal? type 'pointer-address) 21)
|
||||
((equal? type 'callback) 22)
|
||||
(else (error "Undefined type" type)))))
|
||||
(define c-bytevector-get
|
||||
(lambda (pointer type offset)
|
||||
(cond ((equal? type 'int8) (c-bytevector-s8-ref pointer offset))
|
||||
((equal? type 'uint8) (c-bytevector-u8-ref pointer offset))
|
||||
((equal? type 'int16) (c-bytevector-s16-ref pointer offset))
|
||||
((equal? type 'uint16) (c-bytevector-u16-ref pointer offset))
|
||||
((equal? type 'int32) (c-bytevector-s32-ref pointer offset))
|
||||
((equal? type 'uint32) (c-bytevector-u32-ref pointer offset))
|
||||
((equal? type 'int64) (c-bytevector-s64-ref pointer offset))
|
||||
((equal? type 'uint64) (c-bytevector-u64-ref pointer offset))
|
||||
((equal? type 'char) (integer->char (c-bytevector-s8-ref pointer offset)))
|
||||
((equal? type 'unsigned-char) (integer->char (c-bytevector-u8-ref pointer offset)))
|
||||
((equal? type 'short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'short)))
|
||||
((equal? type 'unsigned-short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-short)))
|
||||
((equal? type 'int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'int)))
|
||||
((equal? type 'unsigned-int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-int)))
|
||||
((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'long)))
|
||||
((equal? type 'unsigned-long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-long)))
|
||||
((equal? type 'float) (c-bytevector-ieee-single-native-ref pointer offset))
|
||||
((equal? type 'double) (c-bytevector-ieee-double-native-ref pointer offset))
|
||||
((equal? type 'pointer) (c-bytevector-pointer-ref pointer offset))
|
||||
((not (equal? type 'void)) (error "No such foreign type" type))
|
||||
;; Return unspecified on purpose if type is void
|
||||
))))
|
||||
#;(cond-expand
|
||||
(chicken-6 (include-relative "c/internal.scm"))
|
||||
(else (include "c/internal.scm")))
|
||||
(cond-expand
|
||||
(chibi (include "c/primitives/chibi.scm"))
|
||||
(chicken-5 (export foreign-declare
|
||||
foreign-safe-lambda
|
||||
void)
|
||||
(include "c/primitives/chicken.scm"))
|
||||
(chicken-6 (include-relative "c/primitives/chicken.scm"))
|
||||
;(cyclone (include "c/primitives/cyclone.scm"))
|
||||
(gambit (include "c/primitives/gambit.scm"))
|
||||
(gauche (include "c/primitives/gauche/define-c-procedure.scm"))
|
||||
;(gerbil (include "c/primitives/gerbil.scm"))
|
||||
(guile (include "./c/primitives/guile.scm"))
|
||||
(kawa (include "c/primitives/kawa.scm"))
|
||||
(mit-scheme (include "c/primitives/mit-scheme.scm"))
|
||||
;(larceny (include "c/primitives/larceny.scm"))
|
||||
(mosh (include "c/primitives/mosh.scm"))
|
||||
(racket (include "c/primitives/racket.scm"))
|
||||
(sagittarius (include "c/primitives/sagittarius.scm"))
|
||||
;(skint (include "c/primitives/skint.scm"))
|
||||
(stklos (include "c/primitives/stklos.scm"))
|
||||
;(tr7 (include "c/primitives/tr7.scm"))
|
||||
(ypsilon (export c-function c-callback)
|
||||
(include "c/primitives/ypsilon.scm")))
|
||||
(cond-expand
|
||||
(chicken-6 (include-relative "c/main.scm")
|
||||
(include-relative "c/libc.scm")
|
||||
(include-relative "c/c-bytevectors.scm")
|
||||
(include-relative "c/pointer.scm")
|
||||
;(include-relative "c/array.scm")
|
||||
;(include-relative "c/struct.scm")
|
||||
)
|
||||
(else (include "c/main.scm")
|
||||
(include "c/libc.scm")
|
||||
;(include "c/struct.scm")
|
||||
(include "c/c-bytevectors.scm")
|
||||
(include "c/pointer.scm")
|
||||
;(include "c/array.scm")
|
||||
)))
|
||||
|
|
@ -1,69 +0,0 @@
|
|||
CC=gcc
|
||||
|
||||
chibi: foreign/c/primitives/chibi/foreign-c.stub
|
||||
chibi-ffi foreign/c/primitives/chibi/foreign-c.stub
|
||||
${CC} \
|
||||
-g3 \
|
||||
-o foreign/c/primitives/chibi/foreign-c.so \
|
||||
foreign/c/primitives/chibi/foreign-c.c \
|
||||
-fPIC \
|
||||
-lffi \
|
||||
-shared
|
||||
|
||||
chicken:
|
||||
@echo "Nothing to build for Chicken"
|
||||
|
||||
cyclone:
|
||||
@echo "Nothing to build for Cyclone"
|
||||
|
||||
gambit:
|
||||
@echo "Nothing to build for Gambit"
|
||||
|
||||
gauche: primitives/gauche/foreign-c-primitives-gauche.c primitives/gauche/gauchelib.scm
|
||||
gauche-package compile \
|
||||
--srcdir=primitives/gauche \
|
||||
--cc=${CC} \
|
||||
--cflags="-I./primitives/include" \
|
||||
--libs=-lffi \
|
||||
foreign-c-primitives-gauche foreign-c-primitives-gauche.c gauchelib.scm
|
||||
mkdir -p lib
|
||||
mv foreign-c-primitives-gauche.so lib/gauche.so
|
||||
mv foreign-c-primitives-gauche.o lib/gauche.o
|
||||
|
||||
|
||||
gerbil:
|
||||
@echo "Nothing to build for Gerbil"
|
||||
|
||||
guile:
|
||||
@echo "Nothing to build for Guile"
|
||||
|
||||
kawa:
|
||||
@echo "Nothing to build for Kawa"
|
||||
|
||||
larceny:
|
||||
@echo "Nothing to build for Larceny"
|
||||
|
||||
mosh:
|
||||
@echo "Nothing to build for Mosh"
|
||||
|
||||
racket:
|
||||
@echo "Nothing to build for Racket"
|
||||
|
||||
sagittarius:
|
||||
@echo "Nothing to build for Sagittarius"
|
||||
|
||||
skint:
|
||||
@echo "Nothing to build for Skint"
|
||||
|
||||
stklos:
|
||||
@echo "Nothing to build for Stklos"
|
||||
|
||||
tr7:
|
||||
@echo "Nothing to build for tr7"
|
||||
|
||||
ypsilon:
|
||||
@echo "Nothing to build for Ypsilon"
|
||||
|
||||
clean:
|
||||
@rm -rf primitives/chibi/foreign-c.c
|
||||
@rm -rf lib
|
||||
|
|
@ -1,58 +0,0 @@
|
|||
(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 (c-size-of type))
|
||||
(array (make-c-bytevector (* 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 (c-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 (c-size-of type)))))
|
||||
|
||||
(define pffi-array-get
|
||||
(lambda (array index)
|
||||
(let ((type (pffi-array-type array)))
|
||||
(pffi-pointer-get (pffi-array-pointer array)
|
||||
type
|
||||
(* (c-size-of type) index)))))
|
||||
|
||||
(define pffi-array-set!
|
||||
(lambda (array index value)
|
||||
(let ((type (pffi-array-type array)))
|
||||
(pffi-pointer-set! (pffi-array-pointer array)
|
||||
type
|
||||
(* (c-size-of type) index)
|
||||
value))))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,50 +0,0 @@
|
|||
(define type->libffi-type-number
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 1)
|
||||
((equal? type 'uint8) 2)
|
||||
((equal? type 'int16) 3)
|
||||
((equal? type 'uint16) 4)
|
||||
((equal? type 'int32) 5)
|
||||
((equal? type 'uint32) 6)
|
||||
((equal? type 'int64) 7)
|
||||
((equal? type 'uint64) 8)
|
||||
((equal? type 'char) 9)
|
||||
((equal? type 'unsigned-char) 10)
|
||||
((equal? type 'short) 11)
|
||||
((equal? type 'unsigned-short) 12)
|
||||
((equal? type 'int) 13)
|
||||
((equal? type 'unsigned-int) 14)
|
||||
((equal? type 'long) 15)
|
||||
((equal? type 'unsigned-long) 16)
|
||||
((equal? type 'float) 17)
|
||||
((equal? type 'double) 18)
|
||||
((equal? type 'void) 19)
|
||||
((equal? type 'pointer) 20)
|
||||
((equal? type 'pointer-address) 21)
|
||||
((equal? type 'callback) 22)
|
||||
(else (error "Undefined type" type)))))
|
||||
|
||||
(define c-bytevector-get
|
||||
(lambda (pointer type offset)
|
||||
(cond ((equal? type 'int8) (c-bytevector-s8-ref pointer offset))
|
||||
((equal? type 'uint8) (c-bytevector-u8-ref pointer offset))
|
||||
((equal? type 'int16) (c-bytevector-s16-ref pointer offset))
|
||||
((equal? type 'uint16) (c-bytevector-u16-ref pointer offset))
|
||||
((equal? type 'int32) (c-bytevector-s32-ref pointer offset))
|
||||
((equal? type 'uint32) (c-bytevector-u32-ref pointer offset))
|
||||
((equal? type 'int64) (c-bytevector-s64-ref pointer offset))
|
||||
((equal? type 'uint64) (c-bytevector-u64-ref pointer offset))
|
||||
((equal? type 'char) (integer->char (c-bytevector-s8-ref pointer offset)))
|
||||
((equal? type 'unsigned-char) (integer->char (c-bytevector-u8-ref pointer offset)))
|
||||
((equal? type 'short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'short)))
|
||||
((equal? type 'unsigned-short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-short)))
|
||||
((equal? type 'int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'int)))
|
||||
((equal? type 'unsigned-int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-int)))
|
||||
((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'long)))
|
||||
((equal? type 'unsigned-long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-long)))
|
||||
((equal? type 'float) (c-bytevector-ieee-single-native-ref pointer offset))
|
||||
((equal? type 'double) (c-bytevector-ieee-double-native-ref pointer offset))
|
||||
((equal? type 'pointer) (c-bytevector-pointer-ref pointer offset))
|
||||
((not (equal? type 'void)) (error "No such foreign type" type))
|
||||
;; Return unspecified on purpose if type is void
|
||||
)))
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
(cond-expand
|
||||
(windows
|
||||
(define libc-name "ucrtbase"))
|
||||
(else
|
||||
(define libc-name
|
||||
(cond ((get-environment-variable "BE_HOST_CPU") "root") ; Haiku
|
||||
(else "c")))))
|
||||
|
|
@ -1,164 +0,0 @@
|
|||
(define c-type-size
|
||||
(lambda (type)
|
||||
(size-of-type type)))
|
||||
|
||||
(define foreign-c: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) ; Defined in gambit.scm
|
||||
(chicken #t) ; Defined in chicken.scm
|
||||
(cyclone #t) ; Defined in cyclone.scm
|
||||
(else
|
||||
(define-syntax define-c-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 "FOREIGN_C_LOAD_PATH")
|
||||
(foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\;)
|
||||
(list))
|
||||
(if (get-environment-variable "SYSTEM")
|
||||
(list (get-environment-variable "SYSTEM"))
|
||||
(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")
|
||||
(foreign-c:string-split (get-environment-variable "PATH") #\;)
|
||||
(list))
|
||||
(if (get-environment-variable "PWD")
|
||||
(list (get-environment-variable "PWD"))
|
||||
(list))))
|
||||
(else
|
||||
(append
|
||||
(if (get-environment-variable "FOREIGN_C_LOAD_PATH")
|
||||
(foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\:)
|
||||
(list))
|
||||
; 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")
|
||||
(foreign-c: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"
|
||||
; Haiku
|
||||
"/boot/system/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 (shared-object-load shared-object
|
||||
`((additional-versions ,additional-versions)))))))))))))
|
||||
|
|
@ -1,138 +0,0 @@
|
|||
(define-c-library libc
|
||||
'("stdlib.h" "stdio.h" "string.h")
|
||||
libc-name
|
||||
'((additional-versions ("0" "6"))))
|
||||
|
||||
(define-c-procedure c-calloc libc 'calloc 'pointer '(int int))
|
||||
(cond-expand
|
||||
(gambit
|
||||
(define c-memset-address->pointer
|
||||
(c-lambda (unsigned-int64 unsigned-int8 int)
|
||||
(pointer void)
|
||||
"___return(memset((void*)___arg1, ___arg2, ___arg3));")))
|
||||
(chicken
|
||||
(define c-memset-address->pointer
|
||||
(lambda (address value offset)
|
||||
(address->pointer address))))
|
||||
(else
|
||||
(define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int))))
|
||||
|
||||
(cond-expand
|
||||
(gambit
|
||||
(define c-memset-pointer->address
|
||||
(c-lambda ((pointer void) unsigned-int8 int)
|
||||
unsigned-int64
|
||||
"___return((uint64_t)memset(___arg1, ___arg2, ___arg3));")))
|
||||
(chicken (define c-memset-pointer->address
|
||||
(lambda (pointer value offset)
|
||||
(pointer->address pointer))))
|
||||
(else (define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int))))
|
||||
;(define-c-procedure c-memset-address libc 'memset 'pointer '(uint64 uint8 int))
|
||||
;(define-c-procedure c-printf libc 'printf 'int '(pointer pointer))
|
||||
(define-c-procedure c-malloc libc 'malloc 'pointer '(int))
|
||||
(define-c-procedure c-strlen libc 'strlen 'int '(pointer))
|
||||
|
||||
(define make-c-bytevector
|
||||
(lambda (k . byte)
|
||||
(if (null? byte)
|
||||
(c-malloc k)
|
||||
(bytevector->c-bytevector (make-bytevector k (car byte))))))
|
||||
|
||||
(define c-bytevector
|
||||
(lambda bytes
|
||||
(bytevector->c-bytevector (apply bytevector bytes))))
|
||||
|
||||
(cond-expand
|
||||
(else (define-c-procedure c-free libc 'free 'void '(pointer))))
|
||||
|
||||
(define bytevector->c-bytevector
|
||||
(lambda (bytes)
|
||||
(letrec* ((bytes-length (bytevector-length bytes))
|
||||
(pointer (make-c-bytevector bytes-length))
|
||||
(looper (lambda (index)
|
||||
(when (< index bytes-length)
|
||||
(c-bytevector-u8-set! pointer
|
||||
index
|
||||
(bytevector-u8-ref bytes index))
|
||||
(looper (+ index 1))))))
|
||||
(looper 0)
|
||||
pointer)))
|
||||
|
||||
(define c-bytevector->bytevector
|
||||
(lambda (pointer size)
|
||||
(letrec* ((bytes (make-bytevector size))
|
||||
(looper (lambda (index)
|
||||
(let ((byte (c-bytevector-u8-ref pointer index)))
|
||||
(if (= index size)
|
||||
bytes
|
||||
(begin
|
||||
(bytevector-u8-set! bytes index byte)
|
||||
(looper (+ index 1))))))))
|
||||
(looper 0))))
|
||||
|
||||
(define c-string-length
|
||||
(lambda (bytevector-var)
|
||||
(c-strlen bytevector-var)))
|
||||
|
||||
(define c-utf8->string
|
||||
(lambda (c-bytevector)
|
||||
(let ((size (c-strlen c-bytevector)))
|
||||
(utf8->string (c-bytevector->bytevector c-bytevector size)))))
|
||||
|
||||
(define string->c-utf8
|
||||
(lambda (string-var)
|
||||
(bytevector->c-bytevector (string->utf8 (string-append string-var (string #\null))))))
|
||||
|
||||
(cond-expand
|
||||
(chicken #t) ; FIXME
|
||||
(kawa #t) ; FIXME
|
||||
(else (define make-c-null
|
||||
(lambda ()
|
||||
(cond-expand (stklos (let ((pointer (make-c-bytevector 1)))
|
||||
(free-bytes pointer)
|
||||
pointer))
|
||||
(else (c-memset-address->pointer 0 0 0)))))))
|
||||
|
||||
(cond-expand
|
||||
(chicken #t) ; FIXME
|
||||
(kawa #t) ; FIXME
|
||||
(else (define c-null?
|
||||
(lambda (pointer)
|
||||
(if (c-bytevector? pointer)
|
||||
(= (c-memset-pointer->address pointer 0 0) 0)
|
||||
#f)))))
|
||||
|
||||
#;(define c-bytevector->address
|
||||
(lambda (c-bytevector)
|
||||
(c-memset-pointer->address c-bytevector 0 0)))
|
||||
|
||||
#;(define address->c-bytevector
|
||||
(lambda (address)
|
||||
(c-memset-address->pointer address 0 0)))
|
||||
|
||||
#;(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(c-bytevector-uint-set! c-bytevector
|
||||
0
|
||||
(c-bytevector->address pointer)
|
||||
(native-endianness)
|
||||
(c-type-size 'pointer))))
|
||||
|
||||
#;(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(address->c-bytevector (c-bytevector-uint-ref c-bytevector
|
||||
0
|
||||
(native-endianness)
|
||||
(c-type-size 'pointer)))))
|
||||
|
||||
(cond-expand
|
||||
;(kawa #t) ; Defined in kawa.scm
|
||||
(else (define-syntax call-with-address-of
|
||||
(syntax-rules ()
|
||||
((_ input-pointer thunk)
|
||||
(let ((address-pointer (make-c-bytevector (c-type-size 'pointer))))
|
||||
(c-bytevector-pointer-set! address-pointer 0 input-pointer)
|
||||
(let ((result (apply thunk (list address-pointer))))
|
||||
(set! input-pointer (c-bytevector-pointer-ref address-pointer 0))
|
||||
(c-free address-pointer)
|
||||
result)))))))
|
||||
|
|
@ -1,104 +0,0 @@
|
|||
(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 'pointer-address) (size-of-pointer))
|
||||
((eq? type 'callback) (size-of-pointer))
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(let ((shared-object (dlopen path RTLD-NOW))
|
||||
(maybe-error (dlerror)))
|
||||
shared-object)))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(or (equal? object #f) ; False can be null pointer
|
||||
(pointer? object))))
|
||||
|
||||
(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 pointer void*))
|
||||
((equal? type 'pointer-address) '(maybe-null pointer void*))
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) '(maybe-null pointer void*))
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
;; define-c-procedure
|
||||
|
||||
(define make-c-function
|
||||
(lambda (shared-object c-name return-type argument-types)
|
||||
(dlerror) ;; Clean all previous errors
|
||||
(let ((c-function (dlsym shared-object c-name))
|
||||
(maybe-dlerror (dlerror)))
|
||||
(lambda arguments
|
||||
(display "NAME: ")
|
||||
(display c-name)
|
||||
(newline)
|
||||
(display "ARGS: ")
|
||||
(write arguments)
|
||||
(newline)
|
||||
(let* ((return-pointer
|
||||
(internal-ffi-call (length argument-types)
|
||||
(type->libffi-type-number return-type)
|
||||
(map type->libffi-type-number argument-types)
|
||||
c-function
|
||||
(c-type-size return-type)
|
||||
arguments)))
|
||||
(c-bytevector-get return-pointer return-type 0))))))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(symbol->string c-name)
|
||||
return-type
|
||||
argument-types)))))
|
||||
|
||||
(define make-c-callback
|
||||
(lambda (return-type argument-types procedure)
|
||||
(scheme-procedure-to-pointer procedure)))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback return-type 'argument-types procedure)))))
|
||||
|
|
@ -1,277 +0,0 @@
|
|||
; vim: ft=scheme
|
||||
|
||||
(c-system-include "stdint.h")
|
||||
(c-system-include "dlfcn.h")
|
||||
(c-system-include "stdio.h")
|
||||
(c-system-include "ffi.h")
|
||||
(c-link "ffi")
|
||||
|
||||
;; make-c-null
|
||||
(c-declare "void* make_c_null() { return NULL; }")
|
||||
(define-c (maybe-null pointer void*) make-c-null ())
|
||||
|
||||
;; c-type-size
|
||||
(c-declare "
|
||||
int size_of_int8_t() { return sizeof(int8_t); }
|
||||
int size_of_uint8_t() { return sizeof(uint8_t); }
|
||||
int size_of_int16_t() { return sizeof(int16_t); }
|
||||
int size_of_uint16_t() { return sizeof(uint16_t); }
|
||||
int size_of_int32_t() { return sizeof(int32_t); }
|
||||
int size_of_uint32_t() { return sizeof(uint32_t); }
|
||||
int size_of_int64_t() { return sizeof(int64_t); }
|
||||
int size_of_uint64_t() { return sizeof(uint64_t); }
|
||||
int size_of_char() { return sizeof(char); }
|
||||
int size_of_unsigned_char() { return sizeof(unsigned char); }
|
||||
int size_of_short() { return sizeof(short); }
|
||||
int size_of_unsigned_short() { return sizeof(unsigned short); }
|
||||
int size_of_int() { return sizeof(int); }
|
||||
int size_of_unsigned_int() { return sizeof(unsigned int); }
|
||||
int size_of_long() { return sizeof(long); }
|
||||
int size_of_unsigned_long() { return sizeof(unsigned long); }
|
||||
int size_of_float() { return sizeof(float); }
|
||||
int size_of_double() { return sizeof(double); }
|
||||
int size_of_pointer() { return sizeof(void*); }
|
||||
")
|
||||
|
||||
(define-c int (size-of-int8_t size_of_int8_t) ())
|
||||
(define-c int (size-of-uint8_t size_of_uint8_t) ())
|
||||
(define-c int (size-of-int16_t size_of_int16_t) ())
|
||||
(define-c int (size-of-uint16_t size_of_uint16_t) ())
|
||||
(define-c int (size-of-int32_t size_of_int32_t) ())
|
||||
(define-c int (size-of-uint32_t size_of_uint32_t) ())
|
||||
(define-c int (size-of-int64_t size_of_int64_t) ())
|
||||
(define-c int (size-of-uint64_t size_of_uint64_t) ())
|
||||
(define-c int (size-of-char size_of_char) ())
|
||||
(define-c int (size-of-unsigned-char size_of_unsigned_char) ())
|
||||
(define-c int (size-of-short size_of_short) ())
|
||||
(define-c int (size-of-unsigned-short size_of_unsigned_short) ())
|
||||
(define-c int (size-of-int size_of_int) ())
|
||||
(define-c int (size-of-unsigned-int size_of_unsigned_int) ())
|
||||
(define-c int (size-of-long size_of_long) ())
|
||||
(define-c int (size-of-unsigned-long size_of_unsigned_long) ())
|
||||
(define-c int (size-of-float size_of_float) ())
|
||||
(define-c int (size-of-double size_of_double) ())
|
||||
(define-c int (size-of-pointer size_of_pointer) ())
|
||||
|
||||
;; shared-object-load
|
||||
(define-c-const int (RTLD-NOW "RTLD_NOW"))
|
||||
(define-c (maybe-null pointer void*) dlopen (string int))
|
||||
(define-c (maybe-null pointer void*) dlerror ())
|
||||
|
||||
(c-declare "sexp is_pointer(struct sexp_struct* object) { if(sexp_cpointerp(object)) { return SEXP_TRUE; } else { return SEXP_FALSE; } }")
|
||||
(define-c sexp (pointer? is_pointer) (sexp))
|
||||
|
||||
(c-declare "void c_bytevector_u8_set(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }")
|
||||
(define-c void (c-bytevector-u8-set! c_bytevector_u8_set) ((maybe-null pointer void*) int uint8_t))
|
||||
|
||||
(c-declare "int8_t c_bytevector_u8_ref (void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }")
|
||||
(define-c int8_t (c-bytevector-u8-ref c_bytevector_u8_ref) ((maybe-null pointer void*) int))
|
||||
|
||||
(c-declare "void c_bytevector_pointer_set (void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }")
|
||||
(define-c void (c-bytevector-pointer-set! c_bytevector_pointer_set) ((pointer void*) int (maybe-null pointer void*)))
|
||||
|
||||
(c-declare "void* c_bytevector_pointer_ref (void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }")
|
||||
(define-c (maybe-null pointer void*) (c-bytevector-pointer-ref c_bytevector_pointer_ref) ((maybe-null pointer void*) int))
|
||||
|
||||
(c-declare "ffi_cif cif;")
|
||||
(define-c (maybe-null pointer void*) dlsym ((maybe-null pointer void*) string))
|
||||
|
||||
(define-c-const int (FFI-OK "FFI_OK"))
|
||||
(c-declare
|
||||
"void* internal_ffi_call(
|
||||
unsigned int nargs,
|
||||
unsigned int rtype,
|
||||
unsigned int atypes[],
|
||||
void* fn,
|
||||
unsigned int rvalue_size,
|
||||
struct sexp_struct* avalues[])
|
||||
{
|
||||
ffi_type* c_atypes[nargs];
|
||||
void* c_avalues[nargs];
|
||||
|
||||
int8_t vals1[nargs];
|
||||
uint8_t vals2[nargs];
|
||||
int16_t vals3[nargs];
|
||||
uint16_t vals4[nargs];
|
||||
int32_t vals5[nargs];
|
||||
uint32_t vals6[nargs];
|
||||
int64_t vals7[nargs];
|
||||
uint64_t vals8[nargs];
|
||||
char vals9[nargs];
|
||||
unsigned char vals10[nargs];
|
||||
short vals11[nargs];
|
||||
unsigned short vals12[nargs];
|
||||
int vals13[nargs];
|
||||
unsigned int vals14[nargs];
|
||||
long vals15[nargs];
|
||||
unsigned long vals16[nargs];
|
||||
float vals17[nargs];
|
||||
double vals18[nargs];
|
||||
void* vals20[nargs];
|
||||
|
||||
printf(\"nargs: %i\\n\", nargs);
|
||||
for(int i = 0; i < nargs; i++) {
|
||||
printf(\"i: %i\\n\", i);
|
||||
void* arg = NULL;
|
||||
switch(atypes[i]) {
|
||||
case 1:
|
||||
c_atypes[i] = &ffi_type_sint8;
|
||||
vals1[i] = (int8_t)sexp_sint_value(avalues[i]);
|
||||
c_avalues[i] = &vals1[i];
|
||||
break;
|
||||
case 2:
|
||||
c_atypes[i] = &ffi_type_uint8;
|
||||
vals2[i] = (uint8_t)sexp_uint_value(avalues[i]);
|
||||
c_avalues[i] = &vals2[i];
|
||||
break;
|
||||
case 3:
|
||||
c_atypes[i] = &ffi_type_sint16;
|
||||
vals3[i] = (int16_t)sexp_sint_value(avalues[i]);
|
||||
c_avalues[i] = &vals3[i];
|
||||
break;
|
||||
case 4:
|
||||
c_atypes[i] = &ffi_type_uint16;
|
||||
vals4[i] = (uint16_t)sexp_uint_value(avalues[i]);
|
||||
c_avalues[i] = &vals4[i];
|
||||
break;
|
||||
case 5:
|
||||
c_atypes[i] = &ffi_type_sint32;
|
||||
vals5[i] = (int32_t)sexp_sint_value(avalues[i]);
|
||||
c_avalues[i] = &vals5[i];
|
||||
break;
|
||||
case 6:
|
||||
c_atypes[i] = &ffi_type_uint32;
|
||||
vals6[i] = (int64_t)sexp_uint_value(avalues[i]);
|
||||
c_avalues[i] = &vals6[i];
|
||||
break;
|
||||
case 7:
|
||||
c_atypes[i] = &ffi_type_sint64;
|
||||
vals7[i] = (int64_t) sexp_sint_value(avalues[i]);
|
||||
c_avalues[i] = &vals7[i];
|
||||
break;
|
||||
case 8:
|
||||
c_atypes[i] = &ffi_type_uint64;
|
||||
vals8[i] = (uint64_t)sexp_uint_value(avalues[i]);
|
||||
c_avalues[i] = &vals8[i];
|
||||
break;
|
||||
case 9:
|
||||
c_atypes[i] = &ffi_type_schar;
|
||||
vals9[i] = (char)sexp_sint_value(avalues[i]);
|
||||
c_avalues[i] = &vals9[i];
|
||||
break;
|
||||
case 10:
|
||||
c_atypes[i] = &ffi_type_uchar;
|
||||
vals10[i] = (unsigned char)sexp_uint_value(avalues[i]);
|
||||
break;
|
||||
case 11:
|
||||
c_atypes[i] = &ffi_type_sshort;
|
||||
vals11[i] = (short)sexp_sint_value(avalues[i]);
|
||||
break;
|
||||
case 12:
|
||||
c_atypes[i] = &ffi_type_ushort;
|
||||
vals12[i] = (unsigned short)sexp_uint_value(avalues[i]);
|
||||
break;
|
||||
case 13:
|
||||
c_atypes[i] = &ffi_type_sint;
|
||||
vals13[i] = (int)sexp_sint_value(avalues[i]);
|
||||
c_avalues[i] = &vals13[i];
|
||||
break;
|
||||
case 14:
|
||||
c_atypes[i] = &ffi_type_uint;
|
||||
vals14[i] = (unsigned int)sexp_uint_value(avalues[i]);
|
||||
c_avalues[i] = &vals14[i];
|
||||
break;
|
||||
case 15:
|
||||
c_atypes[i] = &ffi_type_slong;
|
||||
vals15[i] = (long)sexp_sint_value(avalues[i]);
|
||||
c_avalues[i] = &vals15[i];
|
||||
break;
|
||||
case 16:
|
||||
c_atypes[i] = &ffi_type_ulong;
|
||||
vals16[i] = (unsigned long)sexp_uint_value(avalues[i]);
|
||||
c_avalues[i] = &vals16[i];
|
||||
break;
|
||||
case 17:
|
||||
c_atypes[i] = &ffi_type_float;
|
||||
vals17[i] = (float)sexp_flonum_value(avalues[i]);
|
||||
c_avalues[i] = &vals17[i];
|
||||
break;
|
||||
case 18:
|
||||
c_atypes[i] = &ffi_type_double;
|
||||
vals18[i] = (double)sexp_flonum_value(avalues[i]);
|
||||
c_avalues[i] = &vals18[i];
|
||||
break;
|
||||
case 19:
|
||||
c_atypes[i] = &ffi_type_void;
|
||||
arg = NULL;
|
||||
c_avalues[i] = NULL;
|
||||
break;
|
||||
case 20:
|
||||
c_atypes[i] = &ffi_type_pointer;
|
||||
if(sexp_cpointerp(avalues[i])) {
|
||||
vals20[i] = sexp_cpointer_value(avalues[i]);
|
||||
} else {
|
||||
vals20[i] = NULL;
|
||||
}
|
||||
c_avalues[i] = &vals20[i];
|
||||
break;
|
||||
default:
|
||||
printf(\"Undefined argument type integer: %i, index: %i\\n\", atypes[i], i);
|
||||
//c_avalues[i] = sexp_cpointer_value(avalues[i]);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
ffi_type* c_rtype = &ffi_type_void;
|
||||
switch(rtype) {
|
||||
case 1: c_rtype = &ffi_type_sint8; break;
|
||||
case 2: c_rtype = &ffi_type_uint8; break;
|
||||
case 3: c_rtype = &ffi_type_sint16; break;
|
||||
case 4: c_rtype = &ffi_type_uint16; break;
|
||||
case 5: c_rtype = &ffi_type_sint32; break;
|
||||
case 6: c_rtype = &ffi_type_uint32; break;
|
||||
case 7: c_rtype = &ffi_type_sint64; break;
|
||||
case 8: c_rtype = &ffi_type_uint64; break;
|
||||
case 9: c_rtype = &ffi_type_schar; break;
|
||||
case 10: c_rtype = &ffi_type_uchar; break;
|
||||
case 11: c_rtype = &ffi_type_sshort; break;
|
||||
case 12: c_rtype = &ffi_type_ushort; break;
|
||||
case 13: c_rtype = &ffi_type_sint; break;
|
||||
case 14: c_rtype = &ffi_type_uint; break;
|
||||
case 15: c_rtype = &ffi_type_slong; break;
|
||||
case 16: c_rtype = &ffi_type_ulong; break;
|
||||
case 17: c_rtype = &ffi_type_float; break;
|
||||
case 18: c_rtype = &ffi_type_double; break;
|
||||
case 19: c_rtype = &ffi_type_void; break;
|
||||
case 20: c_rtype = &ffi_type_pointer; break;
|
||||
default:
|
||||
printf(\"Undefined return type: %i\\n\", rtype);
|
||||
c_rtype = &ffi_type_pointer;
|
||||
break;
|
||||
}
|
||||
|
||||
int r = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, c_rtype, c_atypes);
|
||||
|
||||
void* rvalue = malloc(rvalue_size);
|
||||
ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues);
|
||||
return rvalue;
|
||||
}")
|
||||
(define-c (maybe-null pointer void*)
|
||||
(internal-ffi-call internal_ffi_call)
|
||||
(unsigned-int
|
||||
unsigned-int
|
||||
(array unsigned-int)
|
||||
(maybe-null pointer void*)
|
||||
unsigned-int
|
||||
(array sexp)))
|
||||
|
||||
(c-declare
|
||||
"void* scheme_procedure_to_pointer(sexp proc) {
|
||||
if(sexp_procedurep(proc) == 1) {
|
||||
return 0; //&sexp_unbox_fixnum(proc);
|
||||
} else {
|
||||
printf(\"NOT A FUNCTION\\n\");
|
||||
}
|
||||
return (void*)proc;
|
||||
}")
|
||||
(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp))
|
||||
|
|
@ -1,226 +0,0 @@
|
|||
|
||||
(define type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'short)
|
||||
((equal? type 'uint16) 'unsigned-short)
|
||||
((equal? type 'int32) 'integer32)
|
||||
((equal? type 'uint32) 'unsigned-integer32)
|
||||
((equal? type 'int64) 'integer64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((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 "type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'short)
|
||||
((equal? type 'uint16) 'unsigned-short)
|
||||
((equal? type 'int32) 'integer32)
|
||||
((equal? type 'uint32) 'unsigned-integer32)
|
||||
((equal? type 'int64) 'integer64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((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 "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 (type->native-type (cadr (list-ref expr 4))))
|
||||
(argument-types (if (null? (cdr (list-ref expr 5)))
|
||||
(list)
|
||||
(map 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 define-c-callback
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'short)
|
||||
((equal? type 'uint16) 'unsigned-short)
|
||||
((equal? type 'int32) 'integer32)
|
||||
((equal? type 'uint32) 'unsigned-integer32)
|
||||
((equal? type 'int64) 'integer64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((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 "type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (list-ref expr 1))
|
||||
(return-type (type->native-type (cadr (list-ref expr 2))))
|
||||
(argument-types (map type->native-type (cadr (list-ref expr 3))))
|
||||
(argument-names (cadr (list-ref expr 4)))
|
||||
(arguments (map
|
||||
(lambda (name type)
|
||||
`(,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 make-c-null
|
||||
(lambda ()
|
||||
(address->pointer 0)))
|
||||
|
||||
(define-syntax define-c-library
|
||||
(syntax-rules ()
|
||||
((_ scheme-name headers object-name options)
|
||||
(begin
|
||||
(define scheme-name #t)
|
||||
(shared-object-load headers)))))
|
||||
|
||||
(define-syntax 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 c-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 c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(pointer-u8-ref (pointer+ c-bytevector k))))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(pointer-u8-set! (pointer+ c-bytevector k) byte)))
|
||||
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(address->pointer (pointer-u64-ref (pointer+ c-bytevector k)))))
|
||||
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(pointer-u64-set! (pointer+ c-bytevector k) (pointer->address pointer))))
|
||||
|
||||
#;(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond
|
||||
((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
|
||||
((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)))))))
|
||||
|
|
@ -1,372 +0,0 @@
|
|||
(define 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 'callback) opaque)
|
||||
(else (error "type->native-type -- No such type" type)))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(opaque? object)))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((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) '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) 'opaque)
|
||||
((equal? type 'void) 'c-void)
|
||||
((equal? type 'callback) 'opaque)
|
||||
(else (error "type->native-type -- No such type" type)))))
|
||||
(scheme-name (cadr expr))
|
||||
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
|
||||
(return-type (type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(argument-types
|
||||
(let ((types (cadr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(if (null? types)
|
||||
'()
|
||||
(map type->native-type types)))))
|
||||
(if (null? argument-types)
|
||||
`(c-define ,scheme-name ,return-type ,c-name)
|
||||
`(c-define ,scheme-name
|
||||
,return-type ,c-name ,@argument-types))))))
|
||||
|
||||
(define define-c-callback
|
||||
(lambda (scheme-name return-type argument-types procedure)
|
||||
(error "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 pointer-address
|
||||
"(void *data, int argc, closure _, object k, object pointer)"
|
||||
"make_c_opaque(opq, &(void*)opaque_ptr(pointer));
|
||||
return_closcall1(data, k, &opq);")
|
||||
|
||||
(define pointer-null
|
||||
(lambda ()
|
||||
(make-opaque)))
|
||||
|
||||
(define-syntax define-c-library
|
||||
(syntax-rules ()
|
||||
((_ scheme-name headers object-name options)
|
||||
(begin
|
||||
(define scheme-name #t)
|
||||
(shared-object-load headers)))))
|
||||
|
||||
(define-syntax shared-object-load
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((headers (cadr (cadr expr)))
|
||||
(includes (map
|
||||
(lambda (header)
|
||||
`(include-c-header ,(string-append "<" header ">")))
|
||||
headers)))
|
||||
`(,@includes)))))
|
||||
|
||||
(define pointer-null?
|
||||
(lambda (pointer)
|
||||
(and (opaque? pointer)
|
||||
(opaque-null? pointer))))
|
||||
|
||||
(define-c pointer-int8-set!
|
||||
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||
"int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||
*p = obj_obj2int(value);
|
||||
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||
|
||||
(define-c 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond
|
||||
((equal? type 'int8) (pointer-int8-set! pointer offset value))
|
||||
((equal? type 'uint8) (pointer-uint8-set! pointer offset value))
|
||||
((equal? type 'int16) (pointer-int16-set! pointer offset value))
|
||||
((equal? type 'uint16) (pointer-uint16-set! pointer offset value))
|
||||
((equal? type 'int32) (pointer-int32-set! pointer offset value))
|
||||
((equal? type 'uint32) (pointer-uint32-set! pointer offset value))
|
||||
((equal? type 'int64) (pointer-int64-set! pointer offset value))
|
||||
((equal? type 'uint64) (pointer-uint64-set! pointer offset value))
|
||||
((equal? type 'char) (pointer-char-set! pointer offset value))
|
||||
((equal? type 'short) (pointer-short-set! pointer offset value))
|
||||
((equal? type 'unsigned-short) (pointer-unsigned-short-set! pointer offset value))
|
||||
((equal? type 'int) (pointer-int-set! pointer offset value))
|
||||
((equal? type 'unsigned-int) (pointer-unsigned-int-set! pointer offset value))
|
||||
((equal? type 'long) (pointer-long-set! pointer offset value))
|
||||
((equal? type 'unsigned-long) (pointer-unsigned-long-set! pointer offset value))
|
||||
((equal? type 'float) (pointer-float-set! pointer offset value))
|
||||
((equal? type 'double) (pointer-double-set! pointer offset value))
|
||||
((equal? type 'pointer) (pointer-pointer-set! pointer offset value)))))
|
||||
|
||||
(define-c 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 c-bytevector-u8-set! pointer-uint8-set!)
|
||||
(define c-bytevector-u8-ref pointer-uint8-get)
|
||||
|
||||
(define pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond
|
||||
((equal? type 'int8) (pointer-int8-get pointer offset))
|
||||
((equal? type 'uint8) (pointer-uint8-get pointer offset))
|
||||
((equal? type 'int16) (pointer-int16-get pointer offset))
|
||||
((equal? type 'uint16) (pointer-uint16-get pointer offset))
|
||||
((equal? type 'int32) (pointer-int32-get pointer offset))
|
||||
((equal? type 'uint32) (pointer-uint32-get pointer offset))
|
||||
((equal? type 'int64) (pointer-int64-get pointer offset))
|
||||
((equal? type 'uint64) (pointer-uint64-get pointer offset))
|
||||
((equal? type 'char) (pointer-char-get pointer offset))
|
||||
((equal? type 'short) (pointer-short-get pointer offset))
|
||||
((equal? type 'unsigned-short) (pointer-unsigned-short-get pointer offset))
|
||||
((equal? type 'int) (pointer-int-get pointer offset))
|
||||
((equal? type 'unsigned-int) (pointer-unsigned-int-get pointer offset))
|
||||
((equal? type 'long) (pointer-long-get pointer offset))
|
||||
((equal? type 'unsigned-long) (pointer-unsigned-long-get pointer offset))
|
||||
((equal? type 'float) (pointer-float-get pointer offset))
|
||||
((equal? type 'double) (pointer-double-get pointer offset))
|
||||
((equal? type 'pointer) (pointer-pointer-get pointer offset)))))
|
||||
|
|
@ -1,252 +0,0 @@
|
|||
(c-declare "#include <stdlib.h>")
|
||||
(c-declare "#include <stdint.h>")
|
||||
|
||||
(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
|
||||
(define-c-library name headers object-name options)
|
||||
(display "HERE: ")
|
||||
(write (cons `(define ,name #t)
|
||||
(map (lambda (header)
|
||||
`(c-declare ,(string-append "#include <" header ">")))
|
||||
(car (cdr headers)))))
|
||||
(newline)
|
||||
(cons `(define ,name #t)
|
||||
(map (lambda (header)
|
||||
`(c-declare ,(string-append "#include <" header ">")))
|
||||
(car (cdr headers)))))
|
||||
|
||||
(define-macro
|
||||
(define-c-library name headers object-name . options)
|
||||
(begin
|
||||
(let ((c-code (apply string-append
|
||||
(map
|
||||
(lambda (header)
|
||||
(string-append "#include <" header ">" (string #\newline)))
|
||||
(car (cdr headers))))))
|
||||
`(begin (define ,name #t) (c-declare ,c-code)))))
|
||||
|
||||
|
||||
(define pointer? (c-lambda ((pointer void)) bool "___return(1);"))
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(call-with-current-continuation
|
||||
(lambda (k)
|
||||
(with-exception-handler
|
||||
(lambda (x) #f)
|
||||
(lambda () (pointer? object)))))))
|
||||
|
||||
(define c-bytevector-u8-set! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define c-bytevector-u8-ref (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));"))
|
||||
|
||||
(define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(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
|
||||
(define-c-procedure scheme-name shared-object c-name return-type argument-types)
|
||||
(begin
|
||||
(letrec* ((pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-int8)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'int64)
|
||||
((equal? type 'uint64) 'unsigned-int64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) '(pointer void))
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) '(pointer void))
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(native-argument-types
|
||||
(if (equal? '(list) argument-types)
|
||||
(list)
|
||||
(let ((types (map pffi-type->native-type (cadr argument-types))))
|
||||
(if (null? types) types types))))
|
||||
(native-return-type (pffi-type->native-type (cadr return-type)))
|
||||
(argument-count (length native-argument-types))
|
||||
(c-arguments (lambda (index result)
|
||||
(if (>= index argument-count)
|
||||
result
|
||||
(c-arguments (+ index 1)
|
||||
(string-append result
|
||||
"___arg"
|
||||
(number->string (+ index 1))
|
||||
(if (<= index (- argument-count 2))
|
||||
", "
|
||||
""))))))
|
||||
(c-code (string-append
|
||||
(if (equal? 'void (cadr return-type)) "" "___return(")
|
||||
(symbol->string (cadr c-name))
|
||||
"(" (c-arguments 0 "") ")"
|
||||
(if (equal? 'void (cadr return-type)) "" ")")
|
||||
";")))
|
||||
`(define ,scheme-name
|
||||
(c-lambda ,native-argument-types
|
||||
,native-return-type
|
||||
,c-code)))))
|
||||
|
||||
(define-macro
|
||||
(define-c-callback scheme-name return-type argument-types procedure)
|
||||
(let* ((type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-int8)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'int64)
|
||||
((equal? type 'uint64) 'unsigned-int64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) '(pointer void))
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) '(pointer void))
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(native-return-type (type->native-type (cadr return-type)))
|
||||
(native-argument-types (map type->native-type (cadr argument-types))))
|
||||
`(define ,scheme-name ,procedure
|
||||
#;(c-callback ,native-return-type ,native-argument-types ,procedure))))
|
||||
|
|
@ -1,182 +0,0 @@
|
|||
(define-module foreign.c.primitives.gauche
|
||||
(export size-of-type
|
||||
shared-object-load
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-pointer-set!
|
||||
c-bytevector-pointer-ref
|
||||
;pointer-null
|
||||
;pointer-null?
|
||||
;make-c-bytevector
|
||||
;pointer-address
|
||||
c-bytevector?
|
||||
c-free
|
||||
;pointer-set!
|
||||
;pointer-get
|
||||
;define-c-procedure
|
||||
define-c-callback
|
||||
dlerror
|
||||
dlsym
|
||||
internal-ffi-call
|
||||
))
|
||||
|
||||
(select-module foreign.c.primitives.gauche)
|
||||
(dynamic-load "foreign/c/lib/gauche")
|
||||
|
||||
(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 shared-object-load
|
||||
(lambda (path options)
|
||||
(shared-object-load path)))
|
||||
|
||||
#;(define make-c-bytevector
|
||||
(lambda (size)
|
||||
(pointer-allocate size)))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (pointer)
|
||||
(pointer? pointer)))
|
||||
|
||||
#;(define c-free
|
||||
(lambda (pointer)
|
||||
(pointer-free pointer)))
|
||||
|
||||
(define c-bytevector-u8-set! pointer-set-uint8!)
|
||||
(define c-bytevector-u8-ref pointer-get-uint8)
|
||||
(define c-bytevector-pointer-set! pointer-set-pointer!)
|
||||
(define c-bytevector-pointer-ref pointer-get-pointer)
|
||||
|
||||
#;(define pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond ((equal? type 'int8) (pointer-set-int8! pointer offset value))
|
||||
((equal? type 'uint8) (pointer-set-uint8! pointer offset value))
|
||||
((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 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 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 type->libffi-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 1)
|
||||
((equal? type 'uint8) 2)
|
||||
((equal? type 'int16) 3)
|
||||
((equal? type 'uint16) 4)
|
||||
((equal? type 'int32) 5)
|
||||
((equal? type 'uint32) 6)
|
||||
((equal? type 'int64) 7)
|
||||
((equal? type 'uint64) 8)
|
||||
((equal? type 'char) 9)
|
||||
((equal? type 'unsigned-char) 10)
|
||||
((equal? type 'bool) 11)
|
||||
((equal? type 'short) 12)
|
||||
((equal? type 'unsigned-short) 13)
|
||||
((equal? type 'int) 14)
|
||||
((equal? type 'unsigned-int) 15)
|
||||
((equal? type 'long) 16)
|
||||
((equal? type 'unsigned-long) 17)
|
||||
((equal? type 'float) 18)
|
||||
((equal? type 'double) 19)
|
||||
((equal? type 'void) 20)
|
||||
((equal? type 'pointer) 21)
|
||||
((equal? type 'callback) 21))))
|
||||
|
||||
#;(define argument->pointer
|
||||
(lambda (value type)
|
||||
(cond ((procedure? value) (scheme-procedure-to-pointer value))
|
||||
(else (let ((pointer (make-c-bytevector (size-of-type type))))
|
||||
(pointer-set! pointer type 0 value)
|
||||
pointer)))))
|
||||
|
||||
|
||||
(define make-c-callback
|
||||
(lambda (return-type argument-types procedure)
|
||||
(scheme-procedure-to-pointer procedure)))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback return-type 'argument-types procedure)))))
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
;;;; This file is dependent on content of other files added trough (include...)
|
||||
;;;; And that's why it is separated
|
||||
|
||||
(define make-c-function
|
||||
(lambda (shared-object c-name return-type argument-types)
|
||||
(dlerror) ;; Clean all previous errors
|
||||
(let ((c-function (dlsym shared-object c-name))
|
||||
(maybe-dlerror (dlerror)))
|
||||
(lambda arguments
|
||||
(let ((return-pointer (internal-ffi-call (length argument-types)
|
||||
(type->libffi-type-number return-type)
|
||||
(map type->libffi-type-number argument-types)
|
||||
c-function
|
||||
(size-of-type return-type)
|
||||
arguments)))
|
||||
(c-bytevector-get return-pointer return-type 0))))))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(symbol->string c-name)
|
||||
return-type
|
||||
argument-types)))))
|
||||
|
|
@ -1,83 +0,0 @@
|
|||
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, ScmObj options);
|
||||
//extern ScmObj pointer_null();
|
||||
//extern ScmObj is_pointer_null();
|
||||
//extern ScmObj pointer_allocate(int size);
|
||||
//extern ScmObj pointer_address(ScmObj pointer);
|
||||
extern ScmObj is_pointer(ScmObj pointer);
|
||||
//extern ScmObj pointer_free(ScmObj pointer);
|
||||
|
||||
|
||||
//extern ScmObj pointer_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_get_pointer(ScmObj pointer, int offset);
|
||||
//extern ScmObj string_to_pointer(ScmObj string);
|
||||
//extern ScmObj pointer_to_string(ScmObj pointer);
|
||||
|
||||
extern ScmObj internal_dlerror();
|
||||
extern ScmObj internal_dlsym(ScmObj shared_object, ScmObj c_name);
|
||||
extern ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, ScmObj rvalue, ScmObj avalues);
|
||||
extern ScmObj scheme_procedure_to_pointer(ScmObj procedure);
|
||||
|
||||
extern ScmObj get_ffi_type_int8();
|
||||
extern ScmObj get_ffi_type_uint8();
|
||||
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);
|
||||
|
||||
|
|
@ -1,101 +0,0 @@
|
|||
(in-module foreign.c.primitives.gauche)
|
||||
|
||||
(inline-stub
|
||||
(.include "foreign-c-primitives-gauche.h")
|
||||
(define-cproc size-of-int8 () size_of_int8)
|
||||
(define-cproc size-of-uint8 () size_of_uint8)
|
||||
(define-cproc size-of-int16 () size_of_int16)
|
||||
(define-cproc size-of-uint16 () size_of_int16)
|
||||
(define-cproc size-of-int32 () size_of_int32)
|
||||
(define-cproc size-of-uint32 () size_of_int32)
|
||||
(define-cproc size-of-int64 () size_of_int64)
|
||||
(define-cproc size-of-uint64 () size_of_int64)
|
||||
(define-cproc size-of-char () size_of_char)
|
||||
(define-cproc size-of-unsigned-char () size_of_unsigned_char)
|
||||
(define-cproc size-of-short () size_of_short)
|
||||
(define-cproc size-of-unsigned-short () size_of_unsigned_short)
|
||||
(define-cproc size-of-int () size_of_int)
|
||||
(define-cproc size-of-unsigned-int () size_of_unsigned_int)
|
||||
(define-cproc size-of-long () size_of_long)
|
||||
(define-cproc size-of-unsigned-long () size_of_unsigned_long)
|
||||
(define-cproc size-of-float () size_of_float)
|
||||
(define-cproc size-of-double () size_of_double)
|
||||
(define-cproc size-of-string () size_of_string)
|
||||
(define-cproc size-of-pointer () size_of_pointer)
|
||||
(define-cproc size-of-void () size_of_void)
|
||||
(define-cproc shared-object-load (path::<string> options) shared_object_load)
|
||||
;(define-cproc pointer-null () pointer_null)
|
||||
;(define-cproc pointer-null? (pointer) is_pointer_null)
|
||||
;(define-cproc pointer-allocate (size::<int>) pointer_allocate)
|
||||
;(define-cproc pointer-address (object) pointer_address)
|
||||
(define-cproc pointer? (pointer) is_pointer)
|
||||
;(define-cproc pointer-free (pointer) pointer_free)
|
||||
|
||||
;(define-cproc pointer-set-int8! (pointer offset::<int> value::<int8>) pointer_set_int8)
|
||||
(define-cproc pointer-set-uint8! (pointer offset::<int> value::<int8>) pointer_set_uint8)
|
||||
;(define-cproc pointer-set-int16! (pointer offset::<int> value::<int16>) pointer_set_int16)
|
||||
;(define-cproc pointer-set-uint16! (pointer offset::<int> value::<int16>) pointer_set_uint16)
|
||||
;(define-cproc pointer-set-int32! (pointer offset::<int> value::<int32>) pointer_set_int32)
|
||||
;(define-cproc pointer-set-uint32! (pointer offset::<int> value::<int32>) pointer_set_uint32)
|
||||
;(define-cproc pointer-set-int64! (pointer offset::<int> value::<int64>) pointer_set_int64)
|
||||
;(define-cproc pointer-set-uint64! (pointer offset::<int> value::<int64>) pointer_set_uint64)
|
||||
;(define-cproc pointer-set-char! (pointer offset::<int> value::<char>) pointer_set_char)
|
||||
;(define-cproc pointer-set-unsigned-char! (pointer offset::<int> value::<char>) pointer_set_unsigned_char)
|
||||
;(define-cproc pointer-set-short! (pointer offset::<int> value::<short>) pointer_set_short)
|
||||
;(define-cproc pointer-set-unsigned-short! (pointer offset::<int> value::<short>) pointer_set_unsigned_short)
|
||||
;(define-cproc pointer-set-int! (pointer offset::<int> value::<int>) pointer_set_int)
|
||||
;(define-cproc pointer-set-unsigned-int! (pointer offset::<int> value::<int>) pointer_set_unsigned_int)
|
||||
;(define-cproc pointer-set-long! (pointer offset::<int> value::<long>) pointer_set_long)
|
||||
;(define-cproc pointer-set-unsigned-long! (pointer offset::<int> value::<long>) pointer_set_unsigned_long)
|
||||
;(define-cproc pointer-set-float! (pointer offset::<int> value::<float>) pointer_set_float)
|
||||
;(define-cproc pointer-set-double! (pointer offset::<int> value::<double>) pointer_set_double)
|
||||
(define-cproc pointer-set-pointer! (pointer offset::<int> value) pointer_set_pointer)
|
||||
|
||||
;(define-cproc pointer-get-int8 (pointer offset::<int>) pointer_get_int8)
|
||||
(define-cproc pointer-get-uint8 (pointer offset::<int>) pointer_get_uint8)
|
||||
;(define-cproc pointer-get-int16 (pointer offset::<int>) pointer_get_int16)
|
||||
;(define-cproc pointer-get-uint16 (pointer offset::<int>) pointer_get_uint16)
|
||||
;(define-cproc pointer-get-int32 (pointer offset::<int>) pointer_get_int32)
|
||||
;(define-cproc pointer-get-uint32 (pointer offset::<int>) pointer_get_uint32)
|
||||
;(define-cproc pointer-get-int64 (pointer offset::<int>) pointer_get_int64)
|
||||
;(define-cproc pointer-get-uint64 (pointer offset::<int>) pointer_get_uint64)
|
||||
;(define-cproc pointer-get-char (pointer offset::<int>) pointer_get_char)
|
||||
;(define-cproc pointer-get-unsigned-char (pointer offset::<int>) pointer_get_unsigned_char)
|
||||
;(define-cproc pointer-get-short (pointer offset::<int>) pointer_get_short)
|
||||
;(define-cproc pointer-get-unsigned-short (pointer offset::<int>) pointer_get_unsigned_short)
|
||||
;(define-cproc pointer-get-int (pointer offset::<int>) pointer_get_int)
|
||||
;(define-cproc pointer-get-unsigned-int (pointer offset::<int>) pointer_get_unsigned_int)
|
||||
;(define-cproc pointer-get-long (pointer offset::<int>) pointer_get_long)
|
||||
;(define-cproc pointer-get-unsigned-long (pointer offset::<int>) pointer_get_unsigned_long)
|
||||
;(define-cproc pointer-get-float (pointer offset::<int>) pointer_get_float)
|
||||
;(define-cproc pointer-get-double (pointer offset::<int>) pointer_get_double)
|
||||
(define-cproc pointer-get-pointer (pointer offset::<int>) pointer_get_pointer)
|
||||
|
||||
(define-cproc dlerror () internal_dlerror)
|
||||
(define-cproc dlsym (shared-object c-name) internal_dlsym)
|
||||
(define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call)
|
||||
(define-cproc scheme-procedure-to-pointer (procedure) scheme_procedure_to_pointer)
|
||||
|
||||
;(define-cproc get-ffi-type-int8 () get_ffi_type_int8)
|
||||
;(define-cproc get-ffi-type-uint8 () get_ffi_type_uint8)
|
||||
;(define-cproc get-ffi-type-int16 () get_ffi_type_int16)
|
||||
;(define-cproc get-ffi-type-uint16 () get_ffi_type_uint16)
|
||||
;(define-cproc get-ffi-type-int32 () get_ffi_type_int32)
|
||||
;(define-cproc get-ffi-type-uint32 () get_ffi_type_uint32)
|
||||
;(define-cproc get-ffi-type-int64 () get_ffi_type_int64)
|
||||
;(define-cproc get-ffi-type-uint64 () get_ffi_type_uint64)
|
||||
;(define-cproc get-ffi-type-char () get_ffi_type_char)
|
||||
;(define-cproc get-ffi-type-unsigned-char () get_ffi_type_unsigned_char)
|
||||
;(define-cproc get-ffi-type-short () get_ffi_type_short)
|
||||
;(define-cproc get-ffi-type-unsigned-short () get_ffi_type_unsigned_short)
|
||||
;(define-cproc get-ffi-type-int () get_ffi_type_int)
|
||||
;(define-cproc get-ffi-type-unsigned-int () get_ffi_type_unsigned_int)
|
||||
;(define-cproc get-ffi-type-long () get_ffi_type_long)
|
||||
;(define-cproc get-ffi-type-unsigned-long () get_ffi_type_unsigned_long)
|
||||
;(define-cproc get-ffi-type-float () get_ffi_type_float)
|
||||
;(define-cproc get-ffi-type-double () get_ffi_type_double)
|
||||
;(define-cproc get-ffi-type-void() get_ffi_type_void)
|
||||
;(define-cproc get-ffi-type-pointer () get_ffi_type_pointer)
|
||||
|
||||
;(define-cproc procedure-to-pointer (procedure) procedure_to_pointer)
|
||||
)
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(error "Not defined")))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(error "Not defined"))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(error "Not defined"))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not defined")))
|
||||
|
|
@ -1,126 +0,0 @@
|
|||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) int8)
|
||||
((equal? type 'uint8) uint8)
|
||||
((equal? type 'int16) int16)
|
||||
((equal? type 'uint16) uint16)
|
||||
((equal? type 'int32) int32)
|
||||
((equal? type 'uint32) uint32)
|
||||
((equal? type 'int64) int64)
|
||||
((equal? type 'uint64) uint64)
|
||||
((equal? type 'char) int8)
|
||||
((equal? type 'unsigned-char) uint8)
|
||||
((equal? type 'short) short)
|
||||
((equal? type 'unsigned-short) unsigned-short)
|
||||
((equal? type 'int) int)
|
||||
((equal? type 'unsigned-int) unsigned-int)
|
||||
((equal? type 'long) long)
|
||||
((equal? type 'unsigned-long) unsigned-long)
|
||||
((equal? type 'float) float)
|
||||
((equal? type 'double) double)
|
||||
((equal? type 'pointer) '*)
|
||||
((equal? type 'void) void)
|
||||
((equal? type 'callback) '*)
|
||||
((equal? type 'struct) '*)
|
||||
(else #f))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(foreign-library-function shared-object
|
||||
(symbol->string c-name)
|
||||
#:return-type (type->native-type return-type)
|
||||
#:arg-types (map type->native-type argument-types))))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(procedure->pointer (type->native-type return-type)
|
||||
procedure
|
||||
(map type->native-type argument-types))))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(let ((native-type (type->native-type type)))
|
||||
(cond ((equal? native-type void) 0)
|
||||
(native-type (sizeof native-type))
|
||||
(else #f)))))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(load-foreign-library path)))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(let ((p (pointer->bytevector c-bytevector (+ k 100))))
|
||||
(bytevector-u8-set! p k byte))))
|
||||
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(let ((p (pointer->bytevector c-bytevector (+ k 100))))
|
||||
(bytevector-u8-ref p k))))
|
||||
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(c-bytevector-uint-set! c-bytevector
|
||||
k
|
||||
(pointer-address pointer)
|
||||
(native-endianness)
|
||||
(size-of-type 'pointer))))
|
||||
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(make-pointer (c-bytevector-uint-ref c-bytevector
|
||||
k
|
||||
(native-endianness)
|
||||
(size-of-type 'pointer)))))
|
||||
|
||||
#;(define pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p (pointer->bytevector pointer (+ offset 100))))
|
||||
(cond ((equal? type 'int8) (bytevector-s8-set! p offset value))
|
||||
((equal? type 'uint8) (bytevector-u8-set! p offset value))
|
||||
((equal? type 'int16) (bytevector-s16-set! p offset value (native-endianness)))
|
||||
((equal? type 'uint16) (bytevector-u16-set! p offset value (native-endianness)))
|
||||
((equal? type 'int32) (bytevector-s32-set! p offset value (native-endianness)))
|
||||
((equal? type 'uint32) (bytevector-u32-set! p offset value (native-endianness)))
|
||||
((equal? type 'int64) (bytevector-s64-set! p offset value (native-endianness)))
|
||||
((equal? type 'uint64) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? type 'char) (bytevector-s8-set! p offset (char->integer value)))
|
||||
((equal? type 'short) (bytevector-s8-set! p offset value))
|
||||
((equal? type 'unsigned-short) (bytevector-u8-set! p offset value))
|
||||
((equal? type 'int) (bytevector-sint-set! p offset value (native-endianness) (size-of-type type)))
|
||||
((equal? type 'unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (size-of-type type)))
|
||||
((equal? type 'long) (bytevector-s64-set! p offset value (native-endianness)))
|
||||
((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness)))
|
||||
((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness)))
|
||||
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))))))
|
||||
|
||||
#;(define pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(let ((p (pointer->bytevector pointer (+ offset 100))))
|
||||
(cond ((equal? type 'int8) (bytevector-s8-ref p offset))
|
||||
((equal? type 'uint8) (bytevector-u8-ref p offset))
|
||||
((equal? type 'int16) (bytevector-s16-ref p offset (native-endianness)))
|
||||
((equal? type 'uint16) (bytevector-u16-ref p offset (native-endianness)))
|
||||
((equal? type 'int32) (bytevector-s32-ref p offset (native-endianness)))
|
||||
((equal? type 'uint32) (bytevector-u32-ref p offset (native-endianness)))
|
||||
((equal? type 'int64) (bytevector-s64-ref p offset (native-endianness)))
|
||||
((equal? type 'uint64) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? type 'char) (integer->char (bytevector-s8-ref p offset)))
|
||||
((equal? type 'short) (bytevector-s8-ref p offset))
|
||||
((equal? type 'unsigned-short) (bytevector-u8-ref p offset))
|
||||
((equal? type 'int) (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))
|
||||
((equal? type 'unsigned-int) (bytevector-uint-ref p offset (native-endianness) (size-of-type type)))
|
||||
((equal? type 'long) (bytevector-s64-ref p offset (native-endianness)))
|
||||
((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness)))
|
||||
((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness)))
|
||||
((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))))))
|
||||
|
|
@ -1,196 +0,0 @@
|
|||
(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 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 '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 c-bytevector?
|
||||
(lambda (object)
|
||||
(string=? (invoke (invoke object 'getClass) 'getName)
|
||||
"jdk.internal.foreign.NativeMemorySegmentImpl")))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ 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 type->native-type argument-types))
|
||||
(apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
|
||||
(type->native-type return-type)
|
||||
(map 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 define-c-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 type->native-type argument-types))
|
||||
(apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
|
||||
(type->native-type return-type)
|
||||
(map 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 (type->native-type type)))
|
||||
(if native-type
|
||||
(invoke native-type 'byteAlignment)
|
||||
#f))))
|
||||
|
||||
(define make-c-null
|
||||
(lambda ()
|
||||
(static-field java.lang.foreign.MemorySegment 'NULL)))
|
||||
|
||||
(define 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 null-pointer (make-c-null))
|
||||
(define c-null?
|
||||
(lambda (pointer)
|
||||
(invoke pointer 'equals null-pointer)))
|
||||
|
||||
(define u8-value-layout (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
|
||||
'set
|
||||
u8-value-layout
|
||||
k
|
||||
byte)))
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
|
||||
'get
|
||||
u8-value-layout
|
||||
k)))
|
||||
|
||||
(define pointer-value-layout (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
|
||||
'set
|
||||
pointer-value-layout
|
||||
k
|
||||
pointer)))
|
||||
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
|
||||
'get
|
||||
pointer-value-layout
|
||||
k)))
|
||||
|
||||
#;(define-syntax call-with-address-of-c-bytevector
|
||||
(syntax-rules ()
|
||||
((_ input-pointer thunk)
|
||||
(let ((address-pointer (make-c-bytevector (c-type-size 'pointer))))
|
||||
(pointer-set! address-pointer 'pointer 0 input-pointer)
|
||||
(apply thunk (list address-pointer))
|
||||
(set! input-pointer (pointer-get address-pointer 'pointer 0))
|
||||
(c-free address-pointer)))))
|
||||
|
|
@ -1,88 +0,0 @@
|
|||
;; 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)
|
||||
|
|
@ -1,76 +0,0 @@
|
|||
(require 'std-ffi)
|
||||
(require 'ffi-load)
|
||||
(require 'foreign-ctools)
|
||||
(require 'foreign-cenums)
|
||||
(require 'foreign-stdlib)
|
||||
(require 'foreign-sugar)
|
||||
(require 'system-interface)
|
||||
|
||||
;; FIXME
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) 1)
|
||||
((eq? type 'uint8) 1)
|
||||
((eq? type 'int16) 2)
|
||||
((eq? type 'uint16) 2)
|
||||
((eq? type 'int32) 4)
|
||||
((eq? type 'uint32) 4)
|
||||
((eq? type 'int64) 8)
|
||||
((eq? type 'uint64) 8)
|
||||
((eq? type 'char) 1)
|
||||
((eq? type 'unsigned-char) 1)
|
||||
((eq? type 'short) 2)
|
||||
((eq? type 'unsigned-short) 2)
|
||||
((eq? type 'int) 4)
|
||||
((eq? type 'unsigned-int) 4)
|
||||
((eq? type 'long) 4)
|
||||
((eq? type 'unsigned-long) 4)
|
||||
((eq? type 'float) 4)
|
||||
((eq? type 'double) 8)
|
||||
((eq? type 'pointer) sizeof:pointer)
|
||||
((eq? type 'void) 0)
|
||||
((eq? type 'callback) sizeof:pointer)
|
||||
(else (error "Can not get size of unknown type" type)))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
;(void*? object)
|
||||
(number? object)))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (headers path . options)
|
||||
(foreign-file path)))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(syscall syscall:poke-bytes c-bytevector k (c-type-size 'uint8) byte)))
|
||||
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(syscall syscall:peek-bytes c-bytevector k (c-type-size 'uint8))))
|
||||
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(syscall syscall:poke-bytes c-bytevector k (c-type-size 'pointer) pointer)))
|
||||
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(syscall syscall:peek-bytes c-bytevector k (c-type-size 'pointer))))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
0
|
||||
|
||||
#;(make-c-function shared-object
|
||||
(symbol->string c-name)
|
||||
return-type
|
||||
argument-types)))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
0
|
||||
#;(make-c-callback return-type argument-types procedure)))))
|
||||
|
|
@ -1,79 +0,0 @@
|
|||
(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 'callback) size-of-pointer)
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(open-shared-library path)))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define c-bytevector-u8-set! pointer-set-c-uint8!)
|
||||
(define c-bytevector-u8-ref pointer-ref-c-uint8)
|
||||
(define c-bytevector-pointer-set! pointer-set-c-pointer!)
|
||||
(define c-bytevector-pointer-ref pointer-ref-c-pointer)
|
||||
|
||||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'void*)
|
||||
(else (error "type->native-type -- No such type" type)))))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(type->native-type return-type)
|
||||
c-name
|
||||
(map type->native-type argument-types))))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback (type->native-type return-type)
|
||||
(map type->native-type argument-types)
|
||||
procedure)))))
|
||||
|
|
@ -1,83 +0,0 @@
|
|||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) _int8)
|
||||
((equal? type 'uint8) _uint8)
|
||||
((equal? type 'int16) _int16)
|
||||
((equal? type 'uint16) _uint16)
|
||||
((equal? type 'int32) _int32)
|
||||
((equal? type 'uint32) _uint32)
|
||||
((equal? type 'int64) _int64)
|
||||
((equal? type 'uint64) _uint64)
|
||||
((equal? type 'char) _int8)
|
||||
((equal? type 'unsigned-char) _uint8)
|
||||
((equal? type 'short) _short)
|
||||
((equal? type 'unsigned-short) _ushort)
|
||||
((equal? type 'int) _int)
|
||||
((equal? type 'unsigned-int) _uint)
|
||||
((equal? type 'long) _long)
|
||||
((equal? type 'unsigned-long) _ulong)
|
||||
((equal? type 'float) _float)
|
||||
((equal? type 'double) _double)
|
||||
((equal? type 'pointer) _pointer)
|
||||
((equal? type 'void) _void)
|
||||
((equal? type 'callback) _pointer)
|
||||
(else #f))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(cpointer? object)))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(get-ffi-obj c-name
|
||||
shared-object
|
||||
(_cprocedure (mlist->list (map type->native-type argument-types))
|
||||
(type->native-type return-type)))))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name (function-ptr procedure
|
||||
(_cprocedure
|
||||
(mlist->list (map type->native-type argument-types))
|
||||
(type->native-type return-type)))))))
|
||||
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(ctype-sizeof (type->native-type type))))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(if (and (not (null? options))
|
||||
(assoc 'additional-versions options))
|
||||
(ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions
|
||||
options))
|
||||
(list #f))))
|
||||
(ffi-lib path))))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(ptr-set! c-bytevector _uint8 'abs k byte)))
|
||||
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(ptr-ref c-bytevector _uint8 'abs k)))
|
||||
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(ptr-set! c-bytevector _pointer 'abs k pointer)))
|
||||
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(ptr-ref c-bytevector _pointer 'abs k)))
|
||||
|
||||
#;(define-syntax call-with-address-of-c-bytevector
|
||||
(syntax-rules ()
|
||||
((_ input-pointer thunk)
|
||||
(let ((address-pointer (make-c-bytevector (c-type-size 'pointer))))
|
||||
(c-bytevector-pointer-set! address-pointer 0 input-pointer)
|
||||
(apply thunk (list address-pointer))
|
||||
(set! input-pointer (c-bytevector-pointer-ref address-pointer 0))
|
||||
(c-free address-pointer)))))
|
||||
|
|
@ -1,124 +0,0 @@
|
|||
(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 'callback) size-of-void*)
|
||||
(else #f))))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(open-shared-library path)))
|
||||
|
||||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'callback)
|
||||
(else #f))))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(type->native-type return-type)
|
||||
c-name
|
||||
(map type->native-type argument-types))))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback (type->native-type return-type)
|
||||
(map type->native-type argument-types)
|
||||
procedure)))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
|
||||
(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
|
||||
(define c-bytevector-pointer-set! pointer-set-c-pointer!)
|
||||
(define c-bytevector-pointer-ref pointer-ref-c-pointer)
|
||||
|
||||
#;(define pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
|
||||
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
|
||||
((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 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)))))
|
||||
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 1))))
|
||||
|
|
@ -1,110 +0,0 @@
|
|||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) :char)
|
||||
((equal? type 'uint8) :char)
|
||||
((equal? type 'int16) :short)
|
||||
((equal? type 'uint16) :ushort)
|
||||
((equal? type 'int32) :int)
|
||||
((equal? type 'uint32) :uint)
|
||||
((equal? type 'int64) :long)
|
||||
((equal? type 'uint64) :ulong)
|
||||
((equal? type 'char) :char)
|
||||
((equal? type 'unsigned-char) :uchar)
|
||||
((equal? type 'short) :short)
|
||||
((equal? type 'unsigned-short) :ushort)
|
||||
((equal? type 'int) :int)
|
||||
((equal? type 'unsigned-int) :uint)
|
||||
((equal? type 'long) :long)
|
||||
((equal? type 'unsigned-long) :ulong)
|
||||
((equal? type 'float) :float)
|
||||
((equal? type 'double) :double)
|
||||
((equal? type 'pointer) :pointer)
|
||||
((equal? type 'void) :void)
|
||||
((equal? type 'callback) :pointer)
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(cpointer? object)))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(begin
|
||||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) :char)
|
||||
((equal? type 'uint8) :char)
|
||||
((equal? type 'int16) :short)
|
||||
((equal? type 'uint16) :ushort)
|
||||
((equal? type 'int32) :int)
|
||||
((equal? type 'uint32) :uint)
|
||||
((equal? type 'int64) :long)
|
||||
((equal? type 'uint64) :ulong)
|
||||
((equal? type 'char) :char)
|
||||
((equal? type 'unsigned-char) :char)
|
||||
((equal? type 'short) :short)
|
||||
((equal? type 'unsigned-short) :ushort)
|
||||
((equal? type 'int) :int)
|
||||
((equal? type 'unsigned-int) :uint)
|
||||
((equal? type 'long) :long)
|
||||
((equal? type 'unsigned-long) :ulong)
|
||||
((equal? type 'float) :float)
|
||||
((equal? type 'double) :double)
|
||||
((equal? type 'pointer) :pointer)
|
||||
((equal? type 'void) :void)
|
||||
((equal? type 'callback) :pointer)
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
(define scheme-name
|
||||
(make-external-function
|
||||
(symbol->string c-name)
|
||||
(map type->native-type argument-types)
|
||||
(type->native-type return-type)
|
||||
shared-object))))))
|
||||
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(%make-callback procedure
|
||||
(map type->native-type argument-types)
|
||||
(type->native-type return-type))))))
|
||||
|
||||
; FIXME
|
||||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 1)
|
||||
((equal? type 'uint8) 1)
|
||||
((equal? type 'int16) 2)
|
||||
((equal? type 'uint16) 2)
|
||||
((equal? type 'int32) 4)
|
||||
((equal? type 'uint32) 4)
|
||||
((equal? type 'int64) 8)
|
||||
((equal? type 'uint64) 8)
|
||||
((equal? type 'char) 1)
|
||||
((equal? type 'unsigned-char) 1)
|
||||
((equal? type 'short) 2)
|
||||
((equal? type 'unsigned-short) 2)
|
||||
((equal? type 'int) 4)
|
||||
((equal? type 'unsigned-int) 4)
|
||||
((equal? type 'long) 8)
|
||||
((equal? type 'unsigned-long) 8)
|
||||
((equal? type 'float) 4)
|
||||
((equal? type 'double) 8)
|
||||
((equal? type 'pointer) 8))))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (pointer offset value)
|
||||
(cpointer-set! pointer :uint8 value offset)))
|
||||
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (pointer offset)
|
||||
(cpointer-ref pointer :uint8 offset)))
|
||||
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (pointer offset value)
|
||||
(cpointer-set! pointer :pointer value offset)))
|
||||
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (pointer offset)
|
||||
(cpointer-ref pointer :pointer offset)))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 1))))
|
||||
|
|
@ -1,188 +0,0 @@
|
|||
(define size-of-type
|
||||
(lambda (type)
|
||||
(cond ((eq? type 'int8) (c-sizeof int8_t))
|
||||
((eq? type 'uint8) (c-sizeof uint8_t))
|
||||
((eq? type 'int16) (c-sizeof int16_t))
|
||||
((eq? type 'uint16) (c-sizeof uint16_t))
|
||||
((eq? type 'int32) (c-sizeof int32_t))
|
||||
((eq? type 'uint32) (c-sizeof uint32_t))
|
||||
((eq? type 'int64) (c-sizeof int64_t))
|
||||
((eq? type 'uint64) (c-sizeof uint64_t))
|
||||
((eq? type 'char) (c-sizeof char))
|
||||
((eq? type 'unsigned-char) (c-sizeof char))
|
||||
((eq? type 'short) (c-sizeof short))
|
||||
((eq? type 'unsigned-short) (c-sizeof unsigned-short))
|
||||
((eq? type 'int) (c-sizeof int))
|
||||
((eq? type 'unsigned-int) (c-sizeof unsigned-int))
|
||||
((eq? type 'long) (c-sizeof long))
|
||||
((eq? type 'unsigned-long) (c-sizeof unsigned-long))
|
||||
((eq? type 'float) (c-sizeof float))
|
||||
((eq? type 'double) (c-sizeof double))
|
||||
((eq? type 'pointer) (c-sizeof void*))
|
||||
((eq? type 'struct) (c-sizeof void*))
|
||||
((eq? type 'callback) (c-sizeof void*))
|
||||
((eq? type 'void) 0)
|
||||
(else #f))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
(number? object)))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k)
|
||||
(c-type-size 'uint8))
|
||||
0
|
||||
byte)))
|
||||
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(bytevector-c-int8-ref (make-bytevector-mapping (+ c-bytevector k)
|
||||
(c-type-size 'uint8))
|
||||
0)))
|
||||
(define c-bytevector-pointer-set!
|
||||
(lambda (c-bytevector k pointer)
|
||||
(let ((bv (make-bytevector-mapping (+ c-bytevector k) (c-type-size 'pointer))))
|
||||
(bytevector-c-void*-set! bv 0 pointer))))
|
||||
(define c-bytevector-pointer-ref
|
||||
(lambda (c-bytevector k)
|
||||
(let ((bv (make-bytevector-mapping (+ c-bytevector k) (c-type-size 'pointer))))
|
||||
(bytevector-c-void*-ref bv 0))))
|
||||
|
||||
#;(define pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((bv (make-bytevector-mapping (+ pointer offset) (c-type-size type))))
|
||||
(cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value))
|
||||
((equal? type 'uint8) (bytevector-c-int8-set! bv 0 value))
|
||||
((equal? type 'int16) (bytevector-c-int16-set! bv 0 value))
|
||||
((equal? type 'uint16) (bytevector-c-int16-set! bv 0 value))
|
||||
((equal? type 'int32) (bytevector-c-int32-set! bv 0 value))
|
||||
((equal? type 'uint32) (bytevector-c-int32-set! bv 0 value))
|
||||
((equal? type 'int64) (bytevector-c-int64-set! bv 0 value))
|
||||
((equal? type 'uint64) (bytevector-c-int64-set! bv 0 value))
|
||||
((equal? type 'char) (bytevector-c-int8-set! bv 0 (char->integer value)))
|
||||
((equal? type 'short) (bytevector-c-short-set! bv 0 value))
|
||||
((equal? type 'unsigned-short) (bytevector-c-short-set! bv 0 value))
|
||||
((equal? type 'int) (bytevector-c-int-set! bv 0 value))
|
||||
((equal? type 'unsigned-int) (bytevector-c-int-set! bv 0 value))
|
||||
((equal? type 'long) (bytevector-c-long-set! bv 0 value))
|
||||
((equal? type 'unsigned-long) (bytevector-c-long-set! bv 0 value))
|
||||
((equal? type 'float) (bytevector-c-float-set! bv 0 value))
|
||||
((equal? type 'double) (bytevector-c-double-set! bv 0 value))
|
||||
((equal? type 'void) (bytevector-c-void*-set! bv 0 value))
|
||||
((equal? type 'pointer) (bytevector-c-void*-set! bv 0 value))))))
|
||||
|
||||
#;(define pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(let ((bv (make-bytevector-mapping (+ pointer offset) (c-type-size type))))
|
||||
(cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0))
|
||||
((equal? type 'uint8) (bytevector-c-uint8-ref bv 0))
|
||||
((equal? type 'int16) (bytevector-c-int16-ref bv 0))
|
||||
((equal? type 'uint16) (bytevector-c-uint16-ref bv 0))
|
||||
((equal? type 'int32) (bytevector-c-int32-ref bv 0))
|
||||
((equal? type 'uint32) (bytevector-c-uint32-ref bv 0))
|
||||
((equal? type 'int64) (bytevector-c-int64-ref bv 0))
|
||||
((equal? type 'uint64) (bytevector-c-uint64-ref bv 0))
|
||||
((equal? type 'char) (integer->char (bytevector-c-uint8-ref bv 0)))
|
||||
((equal? type 'short) (bytevector-c-short-ref bv 0))
|
||||
((equal? type 'unsigned-short) (bytevector-c-unsigned-short-ref bv 0))
|
||||
((equal? type 'int) (bytevector-c-int-ref bv 0))
|
||||
((equal? type 'unsigned-int) (bytevector-c-unsigned-int-ref bv 0))
|
||||
((equal? type 'long) (bytevector-c-long-ref bv 0))
|
||||
((equal? type 'unsigned-long) (bytevector-c-unsigned-long-ref bv 0))
|
||||
((equal? type 'float) (bytevector-c-float-ref bv 0))
|
||||
((equal? type 'double) (bytevector-c-double-ref bv 0))
|
||||
((equal? type 'void) (bytevector-c-void*-ref bv 0))
|
||||
((equal? type 'pointer) (bytevector-c-void*-ref bv 0))))))
|
||||
|
||||
(define shared-object-load
|
||||
(lambda (path options)
|
||||
(load-shared-object path)))
|
||||
|
||||
#;(define-macro
|
||||
(type->native-type type)
|
||||
`(cond ((equal? ,type 'int8) 'int8_t)
|
||||
((equal? ,type 'uint8) 'uint8_t)
|
||||
;((equal? ,type 'int16) 'int16_t)
|
||||
;((equal? ,type 'uint16) 'uint16_t)
|
||||
;((equal? ,type 'int32) 'int32_t)
|
||||
;((equal? ,type 'uint32) 'uint32_t)
|
||||
;((equal? ,type 'int64) 'int64_t)
|
||||
;((equal? ,type 'uint64) 'uint64_t)
|
||||
;((equal? ,type 'char) 'char)
|
||||
;((equal? ,type 'unsigned-char) 'char)
|
||||
;((equal? ,type 'short) 'short)
|
||||
;((equal? ,type 'unsigned-short) 'unsigned-short)
|
||||
((equal? ,type 'int) 'int)
|
||||
;((equal? ,type 'unsigned-int) 'unsigned-int)
|
||||
;((equal? ,type 'long) 'long)
|
||||
;((equal? ,type 'unsigned-long) 'unsigned-long)
|
||||
;((equal? ,type 'float) 'float)
|
||||
;((equal? ,type 'double) 'double)
|
||||
((equal? ,type 'pointer) 'void*)
|
||||
((equal? ,type 'void) 'void)
|
||||
;((equal? ,type 'callback) 'void*)
|
||||
(else (error "type->native-type -- No such type" ,type))))
|
||||
|
||||
(define-macro
|
||||
(define-c-procedure scheme-name shared-object c-name return-type argument-types)
|
||||
(begin
|
||||
(let ((type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'void*)
|
||||
(else (error "type->native-type -- No such type" type))))))
|
||||
`(define ,scheme-name
|
||||
(c-function ,(type->native-type (cadr return-type))
|
||||
,(cadr c-name)
|
||||
,(map type->native-type (cadr argument-types)))))))
|
||||
|
||||
(define-macro
|
||||
(define-c-callback scheme-name return-type argument-types procedure)
|
||||
(let* ((type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'void*)
|
||||
(else (error "type->native-type -- No such type" type)))))
|
||||
(native-return-type (type->native-type (cadr return-type)))
|
||||
(native-argument-types (map type->native-type (cadr argument-types))))
|
||||
`(define ,scheme-name
|
||||
(c-callback ,native-return-type ,native-argument-types ,procedure))))
|
||||
|
|
@ -1,101 +0,0 @@
|
|||
(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))
|
||||
(c-bytevector? (car arguments)))
|
||||
(car arguments)
|
||||
(make-c-bytevector size)))
|
||||
(c-type-string (if (string? c-type) c-type (symbol->string c-type))))
|
||||
(struct-make c-type-string size pointer offsets)))))))
|
||||
|
||||
(define c-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 (= (modulo 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 (c-align-of type)))
|
||||
(when (> (size-of-type type) largest-member-size)
|
||||
(set! largest-member-size (size-of-type type)))
|
||||
(if (or (= size 0)
|
||||
(= (modulo 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) (make-c-bytevector size) (car pointer)))
|
||||
(c-type (if (string? c-type) c-type (symbol->string c-type))))
|
||||
(struct-make c-type size pointer offsets))))
|
||||
|
||||
(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)))))))
|
||||
(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)))
|
||||
|
|
@ -1,143 +0,0 @@
|
|||
(define slash (cond-expand (windows "\\") (else "/")))
|
||||
|
||||
(define-c-procedure c-perror libc 'perror 'void '(pointer))
|
||||
(define-c-procedure c-mkdir libc 'mkdir 'int '(pointer int))
|
||||
(define-c-procedure c-rmdir libc 'rmdir 'int '(pointer))
|
||||
(define-c-procedure c-stat libc 'stat 'int '(pointer pointer))
|
||||
(define-c-procedure c-opendir libc 'opendir 'pointer '(pointer))
|
||||
(define-c-procedure c-readdir libc 'readdir 'pointer '(pointer))
|
||||
(define-c-procedure c-closedir libc 'closedir 'int '(pointer))
|
||||
(define-c-procedure c-realpath libc 'realpath 'pointer '(pointer pointer))
|
||||
|
||||
(define-record-type file-info-record
|
||||
(file-info-record-make device inode mode nlinks uid gid rdev size blksize blocks atime mtime ctime fname/port follow?)
|
||||
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?)
|
||||
(when (port? fname/port)
|
||||
(error "file-info implementation does not support ports as arguments"))
|
||||
(let* ((fname-pointer (string->c-utf8 fname/port))
|
||||
(stat-pointer (make-c-bytevector 256))
|
||||
(result (c-stat fname-pointer stat-pointer))
|
||||
(error-message "file-info error")
|
||||
(error-pointer (string->c-utf8 error-message)))
|
||||
(when (< result 0)
|
||||
(c-perror error-pointer)
|
||||
(c-free fname-pointer)
|
||||
(c-free stat-pointer)
|
||||
(c-free error-pointer)
|
||||
(error error-message fname/port))
|
||||
(file-info-record-make (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 0) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 1) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 2) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 3) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 4) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 5) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 6) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 7) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 8) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 9) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 10) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 11) (native-endianness))
|
||||
(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 12) (native-endianness))
|
||||
fname/port
|
||||
follow?))))
|
||||
|
||||
(define create-directory
|
||||
(lambda (fname . permission-bits)
|
||||
(let* ((fname-pointer (string->c-utf8 fname))
|
||||
(mode (if (null? permission-bits)
|
||||
#o775
|
||||
(string->number (string-append "#o"
|
||||
(number->string (car permission-bits))))))
|
||||
(result (c-mkdir fname-pointer mode))
|
||||
(error-message "create-directory error")
|
||||
(error-pointer (string->c-utf8 error-message)))
|
||||
(c-free fname-pointer)
|
||||
(when (< result 0)
|
||||
(c-perror error-pointer)
|
||||
(c-free error-pointer)
|
||||
(error error-message)))))
|
||||
|
||||
(define delete-directory
|
||||
(lambda (fname)
|
||||
(let* ((fname-pointer (string->c-utf8 fname))
|
||||
(result (c-rmdir fname-pointer))
|
||||
(error-message "delete-directory error")
|
||||
(error-pointer (string->c-utf8 error-message)))
|
||||
(c-free fname-pointer)
|
||||
(when (< result 0)
|
||||
(c-perror error-pointer)
|
||||
(c-free error-pointer)
|
||||
(error error-message)))))
|
||||
|
||||
(define pointer-string-read
|
||||
(lambda (pointer offset)
|
||||
(letrec* ((looper (lambda (c index result)
|
||||
(if (char=? c #\null)
|
||||
(list->string (reverse result))
|
||||
(looper (c-bytevector-char-ref pointer
|
||||
(+ offset index))
|
||||
(+ index 1)
|
||||
(cons c result))))))
|
||||
(looper (c-bytevector-char-ref pointer offset) 1 (list)))))
|
||||
|
||||
(define directory-files
|
||||
(lambda (dir . dotfiles?)
|
||||
(letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?)))
|
||||
(path-pointer (string->c-utf8 dir))
|
||||
(directory-pointer (c-opendir path-pointer))
|
||||
(error-message "directory-files error")
|
||||
(error-pointer (string->c-utf8 error-message))
|
||||
(name-offset 19) ; struct dirent d_name offset on linux
|
||||
(looper (lambda (directory-entity files)
|
||||
(if (c-null? directory-entity)
|
||||
files
|
||||
(let ((name (pointer-string-read directory-entity
|
||||
name-offset)))
|
||||
(looper (c-readdir directory-pointer)
|
||||
(if (or (string=? name ".")
|
||||
(string=? name ".."))
|
||||
(if include-dotfiles?
|
||||
(cons name files)
|
||||
files)
|
||||
(cons name files))))))))
|
||||
(when (c-null? directory-pointer)
|
||||
(c-perror error-pointer)
|
||||
;(c-free error-pointer)
|
||||
;(c-free directory)
|
||||
;(c-free path-pointer)
|
||||
(error error-message))
|
||||
(let ((files (looper (c-readdir directory-pointer) (list))))
|
||||
;(c-free error-pointer)
|
||||
;(c-free directory-pointer)
|
||||
;(c-free path-pointer)
|
||||
(c-closedir directory-pointer)
|
||||
files))))
|
||||
|
||||
(define real-path
|
||||
(lambda (path)
|
||||
(let* ((path-pointer (string->c-utf8 path))
|
||||
(real-path-pointer (c-realpath path-pointer (make-c-null)))
|
||||
(real-path (c-utf8->string real-path-pointer)))
|
||||
(c-free path-pointer)
|
||||
(c-free real-path-pointer)
|
||||
real-path)))
|
||||
|
||||
|
|
@ -1,85 +0,0 @@
|
|||
(define-library
|
||||
(srfi 170)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(foreign c)
|
||||
(scheme process-context))
|
||||
(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"))
|
||||
|
|
@ -1,86 +0,0 @@
|
|||
;; This file exists for guile compability
|
||||
(define-library
|
||||
(srfi 170)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(foreign c)
|
||||
(scheme process-context))
|
||||
(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"))
|
||||
Loading…
Reference in New Issue