Renaming and moving to the new schubert format
This commit is contained in:
parent
26ad6f9506
commit
57c50014df
|
|
@ -26,3 +26,5 @@ retropikzel/pffi/*/compiled
|
|||
tmp
|
||||
dockerfiles/build
|
||||
.scheme_testrunner
|
||||
retropikzel/pffi/version/main.sld
|
||||
retropikzel/pffi/version/main.rkt
|
||||
|
|
|
|||
47
Makefile
47
Makefile
|
|
@ -1,26 +1,15 @@
|
|||
VERSION=$(shell cat VERSION)
|
||||
|
||||
build:
|
||||
cp retropikzel/pffi/${VERSION}/main.sld retropikzel/pffi/${VERSION}/main.scm
|
||||
cp retropikzel/r7rs-pffi/version/main.scm retropikzel/r7rs-pffi/version/main.sld
|
||||
echo "#lang r7rs" > retropikzel/r7rs-pffi/version/main.rkt
|
||||
cat retropikzel/r7rs-pffi/version/main.scm >> retropikzel/r7rs-pffi/version/main.rkt
|
||||
|
||||
install:
|
||||
schubert install
|
||||
|
||||
update-documentation:
|
||||
schubert document
|
||||
mkdir -p docutmp
|
||||
cd docutmp && git clone git@codeberg.org:r7rs-pffi/pffi.wiki.git
|
||||
cp retropikzel/pffi/${VERSION}/schubert-doc.md docutmp/pffi.wiki/Documentation.md
|
||||
cd docutmp/pffi.wiki && git add Documentation.md ; git commit -m "Update documentation" ; git push
|
||||
rm -rf docutmp
|
||||
|
||||
documentation:
|
||||
schubert document
|
||||
VERSION=${VERSION} bash doc/generate.sh > documentation.md
|
||||
|
||||
test-arm64:
|
||||
#scheme_testrunner alpine:3.20 arm64 guile "bash test-guile.sh"
|
||||
scheme_testrunner alpine:3.20 arm64 sagittarius "bash test-sagittarius.sh"
|
||||
#scheme_testrunner alpine:3.20 arm64 sagittarius "bash test-sagittarius.sh"
|
||||
scheme_testrunner alpine:3.20 arm64 chicken "bash test-chicken.sh"
|
||||
#
|
||||
#scheme_testrunner debian:trixie arm64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner debian:trixie arm64 sagittarius "bash test-sagittarius.sh"
|
||||
|
|
@ -32,17 +21,17 @@ test-arm64:
|
|||
#scheme_testrunner opensuse/tumbleweed arm64 sagittarius "bash test-sagittarius.sh"
|
||||
|
||||
test-amd64:
|
||||
scheme_testrunner alpine:3.20 amd64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner alpine:3.20 amd64 guile "bash test-guile.sh"
|
||||
scheme_testrunner alpine:3.20 amd64 sagittarius "bash test-sagittarius.sh"
|
||||
#
|
||||
scheme_testrunner debian:trixie amd64 guile "bash test-guile.sh"
|
||||
scheme_testrunner debian:trixie amd64 sagittarius "bash test-sagittarius.sh"
|
||||
#scheme_testrunner debian:trixie amd64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner debian:trixie amd64 sagittarius "bash test-sagittarius.sh"
|
||||
#
|
||||
scheme_testrunner fedora:40 amd64 guile "bash test-guile.sh"
|
||||
scheme_testrunner fedora:40 amd64 sagittarius "bash test-sagittarius.sh"
|
||||
#scheme_testrunner fedora:40 amd64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner fedora:40 amd64 sagittarius "bash test-sagittarius.sh"
|
||||
#
|
||||
scheme_testrunner opensuse/tumbleweed amd64 guile "bash test-guile.sh"
|
||||
scheme_testrunner opensuse/tumbleweed amd64 sagittarius "bash test-sagittarius.sh"
|
||||
#scheme_testrunner opensuse/tumbleweed amd64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner opensuse/tumbleweed amd64 sagittarius "bash test-sagittarius.sh"
|
||||
|
||||
test-amd64-wine:
|
||||
scheme_testrunner alpine:3.20 amd64 sagittarius_wine "bash test-sagittarius-wine.sh"
|
||||
|
|
@ -53,12 +42,12 @@ tmp:
|
|||
|
||||
clean:
|
||||
rm -rf docutmp
|
||||
rm -rf retropikzel/pffi/${VERSION}/*.c
|
||||
rm -rf retropikzel/pffi/${VERSION}/*.o*
|
||||
rm -rf retropikzel/pffi/${VERSION}/*.so
|
||||
rm -rf retropikzel/pffi/${VERSION}/*.meta
|
||||
rm -rf retropikzel/pffi/${VERSION}/retropikzel.*
|
||||
rm -rf retropikzel/pffi/${VERSION}/compiled
|
||||
rm -rf retropikzel/r7rs-pffi/version/*.c
|
||||
rm -rf retropikzel/r7rs-pffi/version/*.o*
|
||||
rm -rf retropikzel/r7rs-pffi/version/*.so
|
||||
rm -rf retropikzel/r7rs-pffi/version/*.meta
|
||||
rm -rf retropikzel/r7rs-pffi/version/retropikzel.*
|
||||
rm -rf retropikzel/r7rs-pffi/version/compiled
|
||||
rm -rf retropikzel.*
|
||||
rm -rf test/*.c
|
||||
rm -rf test/*.o*
|
||||
|
|
|
|||
|
|
@ -82,7 +82,6 @@ Got a [question](https://codeberg.org/r7rs-pffi/pffi/projects/9575)?
|
|||
|
||||
## Hacking
|
||||
|
||||
- main.sld is the real main which is copied to main.scm
|
||||
- You will need to have [scheme_testrunner](https://git.sr.ht/~retropikzel/scheme-testrunner)
|
||||
installed to run tests on large scale
|
||||
- You can also run them on your machine
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi v0-4-0 chicken)
|
||||
(retropikzel r7rs-pffi version chicken)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi v0-4-0 cyclone)
|
||||
(retropikzel r7rs-pffi version cyclone)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi v0-4-0 empty)
|
||||
(retropikzel r7rs-pffi version empty)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi v0-4-0 gambit)
|
||||
(retropikzel r7rs-pffi version gambit)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version gerbil)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(error "Not defined")))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(error "Not defined"))))
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(error "Not defined"))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))))
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi v0-4-0 guile)
|
||||
(retropikzel r7rs-pffi version guile)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
|
|
@ -1,32 +1,32 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi v0-4-0 main)
|
||||
(retropikzel r7rs-pffi version main)
|
||||
(cond-expand
|
||||
(sagittarius
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 sagittarius)))
|
||||
(retropikzel r7rs-pffi version sagittarius)))
|
||||
(guile
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 guile)))
|
||||
(retropikzel r7rs-pffi version guile)))
|
||||
(racket
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(only (racket base) system-type)
|
||||
(retropikzel r7rs-pffi v0-4-0 racket)))
|
||||
(retropikzel r7rs-pffi version racket)))
|
||||
(stklos
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(stklos)
|
||||
(retropikzel r7rs-pffi v0-4-0 stklos)))
|
||||
(retropikzel r7rs-pffi version stklos)))
|
||||
(kawa
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
|
|
@ -37,31 +37,31 @@
|
|||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 cyclone)))
|
||||
(retropikzel r7rs-pffi version cyclone)))
|
||||
(gambit
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 gambit)))
|
||||
(retropikzel r7rs-pffi version gambit)))
|
||||
(chicken
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 chicken)))
|
||||
(retropikzel r7rs-pffi version chicken)))
|
||||
(chibi
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 chibi)))
|
||||
(retropikzel r7rs-pffi version chibi)))
|
||||
(mit-scheme
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 mit-scheme))))
|
||||
(retropikzel r7rs-pffi version mit-scheme))))
|
||||
(export pffi-shared-object-auto-load
|
||||
pffi-shared-object-load
|
||||
pffi-define
|
||||
|
|
@ -1,7 +1,5 @@
|
|||
#lang r7rs
|
||||
|
||||
(define-library
|
||||
(retropikzel r7rs-pffi v0-4-0 racket)
|
||||
(retropikzel r7rs-pffi version racket)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi v0-4-0 sagittarius)
|
||||
(retropikzel r7rs-pffi version sagittarius)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi v0-4-0 stklos)
|
||||
(retropikzel r7rs-pffi version stklos)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang r7rs
|
||||
(import (scheme base))
|
||||
(include "main.sld")
|
||||
Binary file not shown.
|
|
@ -0,0 +1,259 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version chicken)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(chicken foreign)
|
||||
(chicken syntax)
|
||||
(chicken memory)
|
||||
(chicken random))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'string) 'c-string)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))) )
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'string) 'c-string)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (car (cdr expr)))
|
||||
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
|
||||
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(argument-types
|
||||
(let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(if (null? types)
|
||||
'()
|
||||
(map pffi-type->native-type (map car (map cdr types)))))))
|
||||
(if (null? argument-types)
|
||||
`(define ,scheme-name
|
||||
(foreign-safe-lambda ,return-type ,c-name))
|
||||
`(define ,scheme-name
|
||||
(foreign-safe-lambda ,return-type ,c-name ,@ argument-types)))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'string) 'c-string)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (car (cdr expr)))
|
||||
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr expr)))))))
|
||||
(argument-types
|
||||
(let ((types (cdr (car (cdr (cdr (cdr expr)))))))
|
||||
(if (null? types)
|
||||
'()
|
||||
(map pffi-type->native-type (map car (map cdr types))))))
|
||||
(argument-names (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))
|
||||
(arguments (map
|
||||
(lambda (name type)
|
||||
`(,name ,type))
|
||||
argument-types argument-names))
|
||||
(procedure-body (cdr (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
|
||||
`(begin (define-external ,(cons 'external_123456789 arguments)
|
||||
,return-type
|
||||
(begin ,@ procedure-body))
|
||||
(define ,scheme-name (location external_123456789)))
|
||||
))))
|
||||
|
||||
(define-syntax pffi-size-of
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((type (car (cdr (car (cdr expr))))))
|
||||
(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(int)" int))
|
||||
(else `(error "pffi-size-of -- No such pffi type" type)))))))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(allocate size)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(address->pointer 0)))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(location string-content)))
|
||||
|
||||
(pffi-define strlen #f 'strlen 'int (list 'pointer))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(if (string? pointer)
|
||||
pointer
|
||||
(let* ((size (strlen pointer))
|
||||
(string-content (make-string size)))
|
||||
(move-memory! pointer string-content size 0)
|
||||
string-content))))
|
||||
|
||||
(define-syntax pffi-shared-object-load
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((headers (cdr (car (cdr expr)))))
|
||||
`(begin
|
||||
,@ (map
|
||||
(lambda (header)
|
||||
`(foreign-declare ,(string-append "#include <" header ">")))
|
||||
headers))))))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(free pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(and (pffi-pointer? pointer)
|
||||
(= (pointer->address pointer) 0))))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond
|
||||
((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) 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-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'double) (pointer-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'pointer) (pointer-u32-set! (pointer+ pointer offset) 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) (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-s32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'double) (pointer-s32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'pointer) (pointer-u32-ref (pointer+ pointer offset))))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
pointer))))
|
||||
|
|
@ -0,0 +1,145 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version cyclone)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme eval)
|
||||
(scheme process-context)
|
||||
(scheme eval)
|
||||
(cyclone foreign)
|
||||
(scheme cyclone primitives))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) int)
|
||||
((equal? type 'uint8) int)
|
||||
((equal? type 'int16) int)
|
||||
((equal? type 'uint16) int)
|
||||
((equal? type 'int32) int)
|
||||
((equal? type 'uint32) int)
|
||||
((equal? type 'int64) int)
|
||||
((equal? type 'uint64) int)
|
||||
((equal? type 'char) char)
|
||||
((equal? type 'unsigned-char) char)
|
||||
((equal? type 'short) int)
|
||||
((equal? type 'unsigned-short) int)
|
||||
((equal? type 'int) int)
|
||||
((equal? type 'unsigned-int) int)
|
||||
((equal? type 'long) int)
|
||||
((equal? type 'unsigned-long) int)
|
||||
((equal? type 'float) float)
|
||||
((equal? type 'double) double)
|
||||
((equal? type 'pointer) opaque)
|
||||
((equal? type 'string) string)
|
||||
((equal? type 'void) c-void)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(error "Not defined")))
|
||||
|
||||
|
||||
(define-syntax pffi-define
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'string) 'c-string)
|
||||
((equal? type 'void) 'void)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (car (cdr expr)))
|
||||
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
|
||||
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(argument-types
|
||||
(let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(if (null? types)
|
||||
'()
|
||||
(map pffi-type->native-type (map car (map cdr types)))))))
|
||||
(if (null? argument-types)
|
||||
`(c-define ,scheme-name ,return-type ,c-name)
|
||||
`(c-define ,scheme-name
|
||||
,return-type ,c-name ,@ argument-types))))))
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define-syntax pffi-shared-object-load
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
`(begin
|
||||
,@ (map
|
||||
(lambda (header)
|
||||
`(include-c-header ,(string-append "<" header ">")))
|
||||
(cdr (car (cdr expr))))))))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(error "Not defined"))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))))
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi v0-4-0 gerbil)
|
||||
(retropikzel r7rs-pffi version empty)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
|
|
@ -0,0 +1,77 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version gambit)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-define
|
||||
(lambda (scheme-name shared-object c-name return-type argument-types)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (headers)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(error "Not defined"))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))))
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version gerbil)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(error "Not defined")))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(error "Not defined"))))
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(error "Not defined"))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))))
|
||||
|
|
@ -0,0 +1,154 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version guile)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(rnrs bytevectors)
|
||||
(system foreign)
|
||||
(system foreign-library))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) int8)
|
||||
((equal? type 'uint8) uint8)
|
||||
((equal? type 'int16) int16)
|
||||
((equal? type 'uint16) uint16)
|
||||
((equal? type 'int32) int32)
|
||||
((equal? type 'uint32) uint32)
|
||||
((equal? type 'int64) int64)
|
||||
((equal? type 'uint64) uint64)
|
||||
((equal? type 'char) int)
|
||||
((equal? type 'unsigned-char) int)
|
||||
((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 'string) '*)
|
||||
((equal? type 'void) void)
|
||||
((equal? type 'callback) '*)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(foreign-library-function shared-object
|
||||
(symbol->string c-name)
|
||||
#:return-type (pffi-type->native-type return-type)
|
||||
#:arg-types (map pffi-type->native-type argument-types))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(procedure->pointer (pffi-type->native-type return-type)
|
||||
procedure
|
||||
(map pffi-type->native-type argument-types))))))
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(sizeof (pffi-type->native-type type))))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(bytevector->pointer (make-bytevector size 0))))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(make-pointer 0)))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(string->pointer string-content)))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(pointer->string pointer)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(load-foreign-library path)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
#t))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(and (pffi-pointer? pointer)
|
||||
(null-pointer? pointer))))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p (pointer->bytevector pointer (+ offset 100)))
|
||||
(native-type (pffi-type->native-type type)))
|
||||
(cond ((equal? native-type int8) (bytevector-s8-set! p offset value))
|
||||
((equal? native-type uint8) (bytevector-u8-set! p offset value))
|
||||
((equal? native-type int16) (bytevector-s16-set! p offset value (native-endianness)))
|
||||
((equal? native-type uint16) (bytevector-u16-set! p offset value (native-endianness)))
|
||||
((equal? native-type int32) (bytevector-s32-set! p offset value (native-endianness)))
|
||||
((equal? native-type uint32) (bytevector-u32-set! p offset value (native-endianness)))
|
||||
((equal? native-type int64) (bytevector-s64-set! p offset value (native-endianness)))
|
||||
((equal? native-type uint64) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? native-type short) (bytevector-s8-set! p offset value (native-endianness)))
|
||||
((equal? native-type unsigned-short) (bytevector-u8-set! p offset value))
|
||||
((equal? native-type int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type)))
|
||||
((equal? native-type unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (pffi-size-of type)))
|
||||
((equal? native-type long) (bytevector-s64-set! p offset value (native-endianness)))
|
||||
((equal? native-type unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? native-type float) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? native-type double) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? native-type '*) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (pffi-size-of type))))
|
||||
)))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(let ((p (pointer->bytevector pointer (+ offset 100)))
|
||||
(native-type (pffi-type->native-type type)))
|
||||
(cond ((equal? native-type int8) (bytevector-s8-ref p offset))
|
||||
((equal? native-type uint8) (bytevector-u8-ref p offset))
|
||||
((equal? native-type int16) (bytevector-s16-ref p offset (native-endianness)))
|
||||
((equal? native-type uint16) (bytevector-u16-ref p offset (native-endianness)))
|
||||
((equal? native-type int32) (bytevector-s32-ref p offset (native-endianness)))
|
||||
((equal? native-type uint32) (bytevector-u32-ref p offset (native-endianness)))
|
||||
((equal? native-type int64) (bytevector-s64-ref p offset (native-endianness)))
|
||||
((equal? native-type uint64) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? native-type short) (bytevector-s8-ref p offset))
|
||||
((equal? native-type unsigned-short) (bytevector-u8-ref p offset))
|
||||
((equal? native-type int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))
|
||||
((equal? native-type unsigned-int) (bytevector-uint-ref p offset (native-endianness) (pffi-size-of type)))
|
||||
((equal? native-type long) (bytevector-s64-ref p offset (native-endianness)))
|
||||
((equal? native-type unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? native-type float) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? native-type double) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? native-type '*) (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type))))))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(dereference-pointer pointer)))))
|
||||
|
|
@ -0,0 +1,132 @@
|
|||
|
||||
(define arena (invoke-static java.lang.foreign.Arena 'global))
|
||||
|
||||
(define value->object
|
||||
(lambda (value type)
|
||||
(cond ((equal? type 'byte)
|
||||
(java.lang.Byte value))
|
||||
((equal? type 'short)
|
||||
(java.lang.Short value))
|
||||
((equal? type 'int)
|
||||
(java.lang.Integer value))
|
||||
((equal? type 'long)
|
||||
(java.lang.Long value))
|
||||
((equal? type 'float)
|
||||
(java.lang.Float value))
|
||||
((equal? type 'double)
|
||||
(java.lang.Double value))
|
||||
((equal? type 'char)
|
||||
(java.lang.Char value))
|
||||
(else value))))
|
||||
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 1))
|
||||
((equal? type 'uint8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) '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) (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR))
|
||||
((equal? type 'unsigned-char) (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR))
|
||||
((equal? type 'short) (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT))
|
||||
((equal? type 'unsigned-short) (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT))
|
||||
((equal? type 'int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
|
||||
((equal? type 'unsigned-int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
|
||||
((equal? type 'long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG))
|
||||
((equal? type 'unsigned-long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG))
|
||||
((equal? type 'float) (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT))
|
||||
((equal? type 'double) (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE))
|
||||
((equal? type 'pointer) (static-field java.lang.foreign.ValueLayout 'ADDRESS))
|
||||
((equal? type 'string) (static-field java.lang.foreign.ValueLayout 'ADDRESS))
|
||||
((equal? type 'void) (static-field java.lang.foreign.ValueLayout 'ADDRESS))
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(string=? (invoke (invoke object 'getClass) 'getName)
|
||||
"jdk.internal.foreign.NativeMemorySegmentImpl")))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(let* ((of-void (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid))
|
||||
(of (class-methods java.lang.foreign.FunctionDescriptor 'of))
|
||||
(function-descriptor (if (equal? return-type 'void)
|
||||
(apply of-void (map pffi-type->native-type argument-types))
|
||||
(apply of (append (list (pffi-type->native-type return-type)) (map pffi-type->native-type argument-types)))))
|
||||
(method-handle (invoke (cdr (assoc 'linker shared-object))
|
||||
'downcallHandle
|
||||
(invoke (invoke (cdr (assoc 'lookup shared-object))
|
||||
'find
|
||||
(symbol->string c-name))
|
||||
'orElseThrow)
|
||||
function-descriptor)))
|
||||
|
||||
(lambda vals
|
||||
(invoke method-handle 'invokeWithArguments (map value->object vals argument-types))))))))
|
||||
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(invoke (pffi-type->native-type type) 'byteAlignment)))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(invoke arena 'allocate size 1)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(static-field java.lang.foreign.MemorySegment 'NULL)))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(invoke arena 'allocateUtf8String string-content)))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getUtf8String 0)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(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))
|
||||
;(set! arena (invoke-static java.lang.foreign.Arena 'ofConfined))
|
||||
|
||||
(linker (invoke-static java.lang.foreign.Linker 'nativeLinker))
|
||||
(lookup (invoke-static java.lang.foreign.SymbolLookup
|
||||
'libraryLookup
|
||||
absolute-path
|
||||
arena)))
|
||||
(list (cons 'linker linker)
|
||||
(cons 'lookup lookup)))))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
#t))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(invoke pointer 'equals (pffi-pointer-null))))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(invoke pointer 'set (pffi-type->native-type type) offset value)))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(invoke pointer 'get (pffi-type->native-type type) offset)))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0)))
|
||||
|
|
@ -0,0 +1,234 @@
|
|||
#lang r7rs
|
||||
(define-library
|
||||
(retropikzel r7rs-pffi version main)
|
||||
(cond-expand
|
||||
(sagittarius
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version sagittarius)))
|
||||
(guile
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version guile)))
|
||||
(racket
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(only (racket base) system-type)
|
||||
(retropikzel r7rs-pffi version racket)))
|
||||
(stklos
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(stklos)
|
||||
(retropikzel r7rs-pffi version stklos)))
|
||||
(kawa
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)))
|
||||
(cyclone
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version cyclone)))
|
||||
(gambit
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version gambit)))
|
||||
(chicken
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version chicken)))
|
||||
(chibi
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version chibi)))
|
||||
(mit-scheme
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version mit-scheme))))
|
||||
(export pffi-shared-object-auto-load
|
||||
pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
|
||||
#|doc Testing multiline comment |#
|
||||
|
||||
|
||||
|
||||
(define library-version "v0-3-0")
|
||||
(define slash (cond-expand (windows (string #\\)) (else "/")))
|
||||
|
||||
(define platform-file-extension
|
||||
(cond-expand
|
||||
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
|
||||
(windows ".dll")
|
||||
(else ".so")))
|
||||
|
||||
(define platform-lib-prefix
|
||||
(cond-expand
|
||||
(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
|
||||
(windows "")
|
||||
(else "lib")))
|
||||
|
||||
(define pffi-types
|
||||
'(int8
|
||||
uint8
|
||||
int16
|
||||
uint16
|
||||
int32
|
||||
uint32
|
||||
int64
|
||||
uint64
|
||||
char
|
||||
unsigned-char
|
||||
short
|
||||
unsigned-short
|
||||
int
|
||||
unsigned-int
|
||||
long
|
||||
unsigned-long
|
||||
float
|
||||
double
|
||||
string
|
||||
pointer
|
||||
void))
|
||||
|
||||
(define string-split
|
||||
(lambda (str mark)
|
||||
(let* ((str-l (string->list str))
|
||||
(res (list))
|
||||
(last-index 0)
|
||||
(index 0)
|
||||
(splitter (lambda (c)
|
||||
(cond ((char=? c mark)
|
||||
(begin
|
||||
(set! res (append res (list (string-copy str last-index index))))
|
||||
(set! last-index (+ index 1))))
|
||||
((equal? (length str-l) (+ index 1))
|
||||
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
|
||||
(set! index (+ index 1)))))
|
||||
(for-each splitter str-l)
|
||||
res)))
|
||||
|
||||
(define auto-load-paths
|
||||
(append
|
||||
(cond-expand
|
||||
(windows
|
||||
(append
|
||||
(if (get-environment-variable "SYSTEM")
|
||||
(list (get-environment-variable "SYSTEM"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINDIR")
|
||||
(list (get-environment-variable "WINDIR"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINEDLLDIR0")
|
||||
(list (get-environment-variable "WINEDLLDIR0"))
|
||||
(list))
|
||||
(if (get-environment-variable "SystemRoot")
|
||||
(list (string-append
|
||||
(get-environment-variable "SystemRoot")
|
||||
slash
|
||||
"system32"))
|
||||
(list))
|
||||
(list ".")
|
||||
(if (get-environment-variable "PATH")
|
||||
(string-split (get-environment-variable "PATH") #\;)
|
||||
(list))))
|
||||
(else
|
||||
(append
|
||||
; Guix
|
||||
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
|
||||
(string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib")
|
||||
"")
|
||||
"/run/current-system/profile/lib")
|
||||
; Debian
|
||||
(if (get-environment-variable "LD_LIBRARY_PATH")
|
||||
(list (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"
|
||||
))))))
|
||||
|
||||
(define auto-load-versions (list ""))
|
||||
|
||||
(define-syntax pffi-shared-object-auto-load
|
||||
(syntax-rules ()
|
||||
((pffi-shared-object-auto-load headers additional-paths object-name additional-versions)
|
||||
(cond-expand
|
||||
(cyclone (pffi-shared-object-load headers))
|
||||
(chicken (pffi-shared-object-load headers))
|
||||
(gambit (pffi-shared-object-load headers))
|
||||
(else
|
||||
(let* ((paths (append auto-load-paths additional-paths))
|
||||
(versions (append auto-load-versions additional-versions))
|
||||
(shared-object #f))
|
||||
(for-each
|
||||
(lambda (path)
|
||||
(for-each
|
||||
(lambda (version)
|
||||
(let ((library-path (string-append path
|
||||
slash
|
||||
platform-lib-prefix
|
||||
object-name
|
||||
platform-file-extension
|
||||
version)))
|
||||
(if (file-exists? library-path)
|
||||
(set! shared-object library-path))))
|
||||
versions))
|
||||
paths)
|
||||
(if (not shared-object)
|
||||
(error "Could not load shared object"
|
||||
(list (cons 'object object-name)
|
||||
(cons 'paths paths)
|
||||
(cons 'platform-file-extension platform-file-extension)
|
||||
(cons 'versions versions)))
|
||||
(pffi-shared-object-load headers shared-object))))))))
|
||||
|
||||
(cond-expand
|
||||
(kawa (include "kawa.scm"))
|
||||
(else #t))))
|
||||
|
|
@ -0,0 +1,233 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version main)
|
||||
(cond-expand
|
||||
(sagittarius
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version sagittarius)))
|
||||
(guile
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version guile)))
|
||||
(racket
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(only (racket base) system-type)
|
||||
(retropikzel r7rs-pffi version racket)))
|
||||
(stklos
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(stklos)
|
||||
(retropikzel r7rs-pffi version stklos)))
|
||||
(kawa
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)))
|
||||
(cyclone
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version cyclone)))
|
||||
(gambit
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version gambit)))
|
||||
(chicken
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version chicken)))
|
||||
(chibi
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version chibi)))
|
||||
(mit-scheme
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version mit-scheme))))
|
||||
(export pffi-shared-object-auto-load
|
||||
pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
|
||||
#|doc Testing multiline comment |#
|
||||
|
||||
|
||||
|
||||
(define library-version "v0-3-0")
|
||||
(define slash (cond-expand (windows (string #\\)) (else "/")))
|
||||
|
||||
(define platform-file-extension
|
||||
(cond-expand
|
||||
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
|
||||
(windows ".dll")
|
||||
(else ".so")))
|
||||
|
||||
(define platform-lib-prefix
|
||||
(cond-expand
|
||||
(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
|
||||
(windows "")
|
||||
(else "lib")))
|
||||
|
||||
(define pffi-types
|
||||
'(int8
|
||||
uint8
|
||||
int16
|
||||
uint16
|
||||
int32
|
||||
uint32
|
||||
int64
|
||||
uint64
|
||||
char
|
||||
unsigned-char
|
||||
short
|
||||
unsigned-short
|
||||
int
|
||||
unsigned-int
|
||||
long
|
||||
unsigned-long
|
||||
float
|
||||
double
|
||||
string
|
||||
pointer
|
||||
void))
|
||||
|
||||
(define string-split
|
||||
(lambda (str mark)
|
||||
(let* ((str-l (string->list str))
|
||||
(res (list))
|
||||
(last-index 0)
|
||||
(index 0)
|
||||
(splitter (lambda (c)
|
||||
(cond ((char=? c mark)
|
||||
(begin
|
||||
(set! res (append res (list (string-copy str last-index index))))
|
||||
(set! last-index (+ index 1))))
|
||||
((equal? (length str-l) (+ index 1))
|
||||
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
|
||||
(set! index (+ index 1)))))
|
||||
(for-each splitter str-l)
|
||||
res)))
|
||||
|
||||
(define auto-load-paths
|
||||
(append
|
||||
(cond-expand
|
||||
(windows
|
||||
(append
|
||||
(if (get-environment-variable "SYSTEM")
|
||||
(list (get-environment-variable "SYSTEM"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINDIR")
|
||||
(list (get-environment-variable "WINDIR"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINEDLLDIR0")
|
||||
(list (get-environment-variable "WINEDLLDIR0"))
|
||||
(list))
|
||||
(if (get-environment-variable "SystemRoot")
|
||||
(list (string-append
|
||||
(get-environment-variable "SystemRoot")
|
||||
slash
|
||||
"system32"))
|
||||
(list))
|
||||
(list ".")
|
||||
(if (get-environment-variable "PATH")
|
||||
(string-split (get-environment-variable "PATH") #\;)
|
||||
(list))))
|
||||
(else
|
||||
(append
|
||||
; Guix
|
||||
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
|
||||
(string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib")
|
||||
"")
|
||||
"/run/current-system/profile/lib")
|
||||
; Debian
|
||||
(if (get-environment-variable "LD_LIBRARY_PATH")
|
||||
(list (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"
|
||||
))))))
|
||||
|
||||
(define auto-load-versions (list ""))
|
||||
|
||||
(define-syntax pffi-shared-object-auto-load
|
||||
(syntax-rules ()
|
||||
((pffi-shared-object-auto-load headers additional-paths object-name additional-versions)
|
||||
(cond-expand
|
||||
(cyclone (pffi-shared-object-load headers))
|
||||
(chicken (pffi-shared-object-load headers))
|
||||
(gambit (pffi-shared-object-load headers))
|
||||
(else
|
||||
(let* ((paths (append auto-load-paths additional-paths))
|
||||
(versions (append auto-load-versions additional-versions))
|
||||
(shared-object #f))
|
||||
(for-each
|
||||
(lambda (path)
|
||||
(for-each
|
||||
(lambda (version)
|
||||
(let ((library-path (string-append path
|
||||
slash
|
||||
platform-lib-prefix
|
||||
object-name
|
||||
platform-file-extension
|
||||
version)))
|
||||
(if (file-exists? library-path)
|
||||
(set! shared-object library-path))))
|
||||
versions))
|
||||
paths)
|
||||
(if (not shared-object)
|
||||
(error "Could not load shared object"
|
||||
(list (cons 'object object-name)
|
||||
(cons 'paths paths)
|
||||
(cons 'platform-file-extension platform-file-extension)
|
||||
(cons 'versions versions)))
|
||||
(pffi-shared-object-load headers shared-object))))))))
|
||||
|
||||
(cond-expand
|
||||
(kawa (include "kawa.scm"))
|
||||
(else #t))))
|
||||
|
|
@ -1,32 +1,32 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi v0-4-0 main)
|
||||
(retropikzel r7rs-pffi version main)
|
||||
(cond-expand
|
||||
(sagittarius
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 sagittarius)))
|
||||
(retropikzel r7rs-pffi version sagittarius)))
|
||||
(guile
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 guile)))
|
||||
(retropikzel r7rs-pffi version guile)))
|
||||
(racket
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(only (racket base) system-type)
|
||||
(retropikzel r7rs-pffi v0-4-0 racket)))
|
||||
(retropikzel r7rs-pffi version racket)))
|
||||
(stklos
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(stklos)
|
||||
(retropikzel r7rs-pffi v0-4-0 stklos)))
|
||||
(retropikzel r7rs-pffi version stklos)))
|
||||
(kawa
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
|
|
@ -37,31 +37,31 @@
|
|||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 cyclone)))
|
||||
(retropikzel r7rs-pffi version cyclone)))
|
||||
(gambit
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 gambit)))
|
||||
(retropikzel r7rs-pffi version gambit)))
|
||||
(chicken
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 chicken)))
|
||||
(retropikzel r7rs-pffi version chicken)))
|
||||
(chibi
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 chibi)))
|
||||
(retropikzel r7rs-pffi version chibi)))
|
||||
(mit-scheme
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 mit-scheme))))
|
||||
(retropikzel r7rs-pffi version mit-scheme))))
|
||||
(export pffi-shared-object-auto-load
|
||||
pffi-shared-object-load
|
||||
pffi-define
|
||||
|
|
@ -0,0 +1,118 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version racket)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(compatibility mlist)
|
||||
(ffi unsafe)
|
||||
(ffi vector))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) _int8)
|
||||
((equal? type 'uint8) _uint8)
|
||||
((equal? type 'int16) _int16)
|
||||
((equal? type 'uint16) _uint16)
|
||||
((equal? type 'int32) _int32)
|
||||
((equal? type 'uint32) _uint32)
|
||||
((equal? type 'int64) _int64)
|
||||
((equal? type 'uint64) _uint64)
|
||||
((equal? type 'char) _int)
|
||||
((equal? type 'unsigned-char) _int)
|
||||
((equal? type 'short) _short)
|
||||
((equal? type 'unsigned-short) _ushort)
|
||||
((equal? type 'int) _int)
|
||||
((equal? type 'unsigned-int) _uint)
|
||||
((equal? type 'long) _long)
|
||||
((equal? type 'unsigned-long) _ulong)
|
||||
((equal? type 'float) _float)
|
||||
((equal? type 'double) _double)
|
||||
((equal? type 'pointer) _pointer)
|
||||
((equal? type 'string) _pointer)
|
||||
((equal? type 'void) _void)
|
||||
((equal? type 'callback) _pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(cpointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(get-ffi-obj c-name
|
||||
shared-object
|
||||
(_cprocedure (mlist->list (map pffi-type->native-type argument-types))
|
||||
(pffi-type->native-type return-type)))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define-callback scheme-name return-type argument-types procedure)
|
||||
(define scheme-name (function-ptr procedure
|
||||
(_cprocedure
|
||||
(mlist->list (map pffi-type->native-type argument-types))
|
||||
(pffi-type->native-type return-type)))
|
||||
))))
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(ctype-sizeof (pffi-type->native-type type))))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(malloc size 'raw)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
#f ; In racket #f is null pointer
|
||||
))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(cast string-content _string _pointer)))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(cast pointer _pointer _string)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(ffi-lib path)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(free pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(not pointer) ; #f is the null pointer on racket
|
||||
))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(ptr-set! pointer (pffi-type->native-type type) offset value)))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(ptr-ref pointer (pffi-type->native-type type) offset)))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
pointer))))
|
||||
|
|
@ -0,0 +1,171 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version sagittarius)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(sagittarius ffi)
|
||||
(sagittarius))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'string) 'char*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'callback)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer? (lambda (object) (pointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(pffi-type->native-type return-type)
|
||||
c-name
|
||||
(map pffi-type->native-type argument-types))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define-callback scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback (pffi-type->native-type return-type)
|
||||
(map pffi-type->native-type argument-types)
|
||||
procedure)))))
|
||||
|
||||
(define pffi-size-of
|
||||
(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 'string) size-of-void*)
|
||||
((eq? type 'pointer) size-of-void*)
|
||||
(else (error "Can not get size of unknown type" type)))))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(c-malloc size)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(integer->pointer 0)))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
string-content))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(if (string? pointer)
|
||||
pointer
|
||||
(pointer->string pointer))))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(open-shared-library path)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(c-free pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(null-pointer? pointer)))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(cond ((equal? type 'int8) (pointer-set-c-int8_t! p offset value))
|
||||
((equal? type 'uint8) (pointer-set-c-uint8_t! p offset value))
|
||||
((equal? type 'int16) (pointer-set-c-int16_t! p offset value))
|
||||
((equal? type 'uint16) (pointer-set-c-uint16_t! p offset value))
|
||||
((equal? type 'int32) (pointer-set-c-int32_t! p offset value))
|
||||
((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value))
|
||||
((equal? type 'int64) (pointer-set-c-int64_t! p offset value))
|
||||
((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value))
|
||||
((equal? type 'char) (pointer-set-c-char! p offset value))
|
||||
((equal? type 'short) (pointer-set-c-short! p offset value))
|
||||
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value))
|
||||
((equal? type 'int) (pointer-set-c-int! p offset value))
|
||||
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! p offset value))
|
||||
((equal? type 'long) (pointer-set-c-long! p offset value))
|
||||
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value))
|
||||
((equal? type 'float) (pointer-set-c-float! p offset value))
|
||||
((equal? type 'double) (pointer-set-c-double! p offset value))
|
||||
((equal? type 'void*) (pointer-set-c-pointer p offset value))))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(let ((p pointer)
|
||||
(native-type (pffi-type->native-type type)))
|
||||
(cond ((equal? native-type 'int8_t) (pointer-ref-c-int8_t p offset))
|
||||
((equal? native-type 'uint8_t) (pointer-ref-c-uint8_t p offset))
|
||||
((equal? native-type 'int16_t) (pointer-ref-c-int16_t p offset))
|
||||
((equal? native-type 'uint16_t) (pointer-ref-c-uint16_t p offset))
|
||||
((equal? native-type 'int32_t) (pointer-ref-c-int32_t p offset))
|
||||
((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset))
|
||||
((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset))
|
||||
((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset))
|
||||
((equal? native-type 'char) (pointer-ref-c-char p offset))
|
||||
((equal? native-type 'short) (pointer-set-c-short p offset value))
|
||||
((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
|
||||
((equal? native-type 'int) (pointer-ref-c-int p offset))
|
||||
((equal? native-type 'unsigned-int) (pointer-ref-c-unsigned-int p offset))
|
||||
((equal? native-type 'long) (pointer-ref-c-long p offset))
|
||||
((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset))
|
||||
((equal? native-type 'float) (pointer-ref-c-float p offset))
|
||||
((equal? native-type 'double) (pointer-ref-c-double p offset))
|
||||
((equal? native-type 'void*) (pointer-ref-c-pointer p offset))))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(deref pointer 0)))))
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version stklos)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(stklos))
|
||||
(export pffi-define
|
||||
pffi-pointer->string
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-deref
|
||||
pffi-pointer-free
|
||||
pffi-pointer-get
|
||||
pffi-pointer-null
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer?
|
||||
pffi-shared-object-load
|
||||
pffi-size-of
|
||||
pffi-string->pointer)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) :int)
|
||||
((equal? type 'uint8) :uint)
|
||||
((equal? type 'int16) :int)
|
||||
((equal? type 'uint16) :uint)
|
||||
((equal? type 'int32) :int)
|
||||
((equal? type 'uint32) :uint)
|
||||
((equal? type 'int64) :int)
|
||||
((equal? type 'uint64) :uint)
|
||||
((equal? type 'char) :char)
|
||||
((equal? type 'unsigned-char) :uchar)
|
||||
((equal? type 'short) :short)
|
||||
((equal? type 'unsigned-short) :ushort)
|
||||
((equal? type 'int) :int)
|
||||
((equal? type 'unsigned-int) :uint)
|
||||
((equal? type 'long) :long)
|
||||
((equal? type 'unsigned-long) :ulong)
|
||||
((equal? type 'float) :float)
|
||||
((equal? type 'double) :double)
|
||||
((equal? type 'pointer) :pointer)
|
||||
((equal? type 'string) :string)
|
||||
((equal? type 'void) :void)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(cpointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-external-function
|
||||
(symbol->string c-name)
|
||||
(map pffi-type->native-type argument-types)
|
||||
(pffi-type->native-type return-type)
|
||||
shared-object)))))
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(error "Not implemented")))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(allocate-bytes size)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(let ((p (allocate-bytes 0))) (cpointer-data-set! p 0) p)))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
string-content))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
path))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(free-bytes pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(cpointer-null? pointer)))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(error "Not implemented")))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not implemented")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not implemented")))))
|
||||
Binary file not shown.
|
|
@ -0,0 +1,259 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version chicken)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(chicken foreign)
|
||||
(chicken syntax)
|
||||
(chicken memory)
|
||||
(chicken random))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'string) 'c-string)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))) )
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'string) 'c-string)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (car (cdr expr)))
|
||||
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
|
||||
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(argument-types
|
||||
(let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(if (null? types)
|
||||
'()
|
||||
(map pffi-type->native-type (map car (map cdr types)))))))
|
||||
(if (null? argument-types)
|
||||
`(define ,scheme-name
|
||||
(foreign-safe-lambda ,return-type ,c-name))
|
||||
`(define ,scheme-name
|
||||
(foreign-safe-lambda ,return-type ,c-name ,@ argument-types)))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'string) 'c-string)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (car (cdr expr)))
|
||||
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr expr)))))))
|
||||
(argument-types
|
||||
(let ((types (cdr (car (cdr (cdr (cdr expr)))))))
|
||||
(if (null? types)
|
||||
'()
|
||||
(map pffi-type->native-type (map car (map cdr types))))))
|
||||
(argument-names (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))
|
||||
(arguments (map
|
||||
(lambda (name type)
|
||||
`(,name ,type))
|
||||
argument-types argument-names))
|
||||
(procedure-body (cdr (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
|
||||
`(begin (define-external ,(cons 'external_123456789 arguments)
|
||||
,return-type
|
||||
(begin ,@ procedure-body))
|
||||
(define ,scheme-name (location external_123456789)))
|
||||
))))
|
||||
|
||||
(define-syntax pffi-size-of
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((type (car (cdr (car (cdr expr))))))
|
||||
(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(int)" int))
|
||||
(else `(error "pffi-size-of -- No such pffi type" type)))))))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(allocate size)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(address->pointer 0)))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(location string-content)))
|
||||
|
||||
(pffi-define strlen #f 'strlen 'int (list 'pointer))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(if (string? pointer)
|
||||
pointer
|
||||
(let* ((size (strlen pointer))
|
||||
(string-content (make-string size)))
|
||||
(move-memory! pointer string-content size 0)
|
||||
string-content))))
|
||||
|
||||
(define-syntax pffi-shared-object-load
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((headers (cdr (car (cdr expr)))))
|
||||
`(begin
|
||||
,@ (map
|
||||
(lambda (header)
|
||||
`(foreign-declare ,(string-append "#include <" header ">")))
|
||||
headers))))))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(free pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(and (pffi-pointer? pointer)
|
||||
(= (pointer->address pointer) 0))))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond
|
||||
((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) 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-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'double) (pointer-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'pointer) (pointer-u32-set! (pointer+ pointer offset) 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) (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-s32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'double) (pointer-s32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'pointer) (pointer-u32-ref (pointer+ pointer offset))))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
pointer))))
|
||||
|
|
@ -0,0 +1,145 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version cyclone)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme eval)
|
||||
(scheme process-context)
|
||||
(scheme eval)
|
||||
(cyclone foreign)
|
||||
(scheme cyclone primitives))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) int)
|
||||
((equal? type 'uint8) int)
|
||||
((equal? type 'int16) int)
|
||||
((equal? type 'uint16) int)
|
||||
((equal? type 'int32) int)
|
||||
((equal? type 'uint32) int)
|
||||
((equal? type 'int64) int)
|
||||
((equal? type 'uint64) int)
|
||||
((equal? type 'char) char)
|
||||
((equal? type 'unsigned-char) char)
|
||||
((equal? type 'short) int)
|
||||
((equal? type 'unsigned-short) int)
|
||||
((equal? type 'int) int)
|
||||
((equal? type 'unsigned-int) int)
|
||||
((equal? type 'long) int)
|
||||
((equal? type 'unsigned-long) int)
|
||||
((equal? type 'float) float)
|
||||
((equal? type 'double) double)
|
||||
((equal? type 'pointer) opaque)
|
||||
((equal? type 'string) string)
|
||||
((equal? type 'void) c-void)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(error "Not defined")))
|
||||
|
||||
|
||||
(define-syntax pffi-define
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'c-pointer)
|
||||
((equal? type 'string) 'c-string)
|
||||
((equal? type 'void) 'void)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (car (cdr expr)))
|
||||
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
|
||||
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(argument-types
|
||||
(let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
|
||||
(if (null? types)
|
||||
'()
|
||||
(map pffi-type->native-type (map car (map cdr types)))))))
|
||||
(if (null? argument-types)
|
||||
`(c-define ,scheme-name ,return-type ,c-name)
|
||||
`(c-define ,scheme-name
|
||||
,return-type ,c-name ,@ argument-types))))))
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define-syntax pffi-shared-object-load
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
`(begin
|
||||
,@ (map
|
||||
(lambda (header)
|
||||
`(include-c-header ,(string-append "<" header ">")))
|
||||
(cdr (car (cdr expr))))))))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(error "Not defined"))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))))
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version empty)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(error "Not defined")))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(error "Not defined"))))
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(error "Not defined"))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))))
|
||||
|
|
@ -0,0 +1,77 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version gambit)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-define
|
||||
(lambda (scheme-name shared-object c-name return-type argument-types)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (headers)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(error "Not defined"))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))))
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version gerbil)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(error "Not defined")))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(error "Not defined"))))
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(error "Not defined"))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))))
|
||||
|
|
@ -0,0 +1,154 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version guile)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(rnrs bytevectors)
|
||||
(system foreign)
|
||||
(system foreign-library))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) int8)
|
||||
((equal? type 'uint8) uint8)
|
||||
((equal? type 'int16) int16)
|
||||
((equal? type 'uint16) uint16)
|
||||
((equal? type 'int32) int32)
|
||||
((equal? type 'uint32) uint32)
|
||||
((equal? type 'int64) int64)
|
||||
((equal? type 'uint64) uint64)
|
||||
((equal? type 'char) int)
|
||||
((equal? type 'unsigned-char) int)
|
||||
((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 'string) '*)
|
||||
((equal? type 'void) void)
|
||||
((equal? type 'callback) '*)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(foreign-library-function shared-object
|
||||
(symbol->string c-name)
|
||||
#:return-type (pffi-type->native-type return-type)
|
||||
#:arg-types (map pffi-type->native-type argument-types))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(procedure->pointer (pffi-type->native-type return-type)
|
||||
procedure
|
||||
(map pffi-type->native-type argument-types))))))
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(sizeof (pffi-type->native-type type))))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(bytevector->pointer (make-bytevector size 0))))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(make-pointer 0)))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(string->pointer string-content)))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(pointer->string pointer)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(load-foreign-library path)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
#t))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(and (pffi-pointer? pointer)
|
||||
(null-pointer? pointer))))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p (pointer->bytevector pointer (+ offset 100)))
|
||||
(native-type (pffi-type->native-type type)))
|
||||
(cond ((equal? native-type int8) (bytevector-s8-set! p offset value))
|
||||
((equal? native-type uint8) (bytevector-u8-set! p offset value))
|
||||
((equal? native-type int16) (bytevector-s16-set! p offset value (native-endianness)))
|
||||
((equal? native-type uint16) (bytevector-u16-set! p offset value (native-endianness)))
|
||||
((equal? native-type int32) (bytevector-s32-set! p offset value (native-endianness)))
|
||||
((equal? native-type uint32) (bytevector-u32-set! p offset value (native-endianness)))
|
||||
((equal? native-type int64) (bytevector-s64-set! p offset value (native-endianness)))
|
||||
((equal? native-type uint64) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? native-type short) (bytevector-s8-set! p offset value (native-endianness)))
|
||||
((equal? native-type unsigned-short) (bytevector-u8-set! p offset value))
|
||||
((equal? native-type int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type)))
|
||||
((equal? native-type unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (pffi-size-of type)))
|
||||
((equal? native-type long) (bytevector-s64-set! p offset value (native-endianness)))
|
||||
((equal? native-type unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? native-type float) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? native-type double) (bytevector-u64-set! p offset value (native-endianness)))
|
||||
((equal? native-type '*) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (pffi-size-of type))))
|
||||
)))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(let ((p (pointer->bytevector pointer (+ offset 100)))
|
||||
(native-type (pffi-type->native-type type)))
|
||||
(cond ((equal? native-type int8) (bytevector-s8-ref p offset))
|
||||
((equal? native-type uint8) (bytevector-u8-ref p offset))
|
||||
((equal? native-type int16) (bytevector-s16-ref p offset (native-endianness)))
|
||||
((equal? native-type uint16) (bytevector-u16-ref p offset (native-endianness)))
|
||||
((equal? native-type int32) (bytevector-s32-ref p offset (native-endianness)))
|
||||
((equal? native-type uint32) (bytevector-u32-ref p offset (native-endianness)))
|
||||
((equal? native-type int64) (bytevector-s64-ref p offset (native-endianness)))
|
||||
((equal? native-type uint64) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? native-type short) (bytevector-s8-ref p offset))
|
||||
((equal? native-type unsigned-short) (bytevector-u8-ref p offset))
|
||||
((equal? native-type int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))
|
||||
((equal? native-type unsigned-int) (bytevector-uint-ref p offset (native-endianness) (pffi-size-of type)))
|
||||
((equal? native-type long) (bytevector-s64-ref p offset (native-endianness)))
|
||||
((equal? native-type unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? native-type float) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? native-type double) (bytevector-u64-ref p offset (native-endianness)))
|
||||
((equal? native-type '*) (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type))))))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(dereference-pointer pointer)))))
|
||||
|
|
@ -0,0 +1,132 @@
|
|||
|
||||
(define arena (invoke-static java.lang.foreign.Arena 'global))
|
||||
|
||||
(define value->object
|
||||
(lambda (value type)
|
||||
(cond ((equal? type 'byte)
|
||||
(java.lang.Byte value))
|
||||
((equal? type 'short)
|
||||
(java.lang.Short value))
|
||||
((equal? type 'int)
|
||||
(java.lang.Integer value))
|
||||
((equal? type 'long)
|
||||
(java.lang.Long value))
|
||||
((equal? type 'float)
|
||||
(java.lang.Float value))
|
||||
((equal? type 'double)
|
||||
(java.lang.Double value))
|
||||
((equal? type 'char)
|
||||
(java.lang.Char value))
|
||||
(else value))))
|
||||
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond
|
||||
((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 1))
|
||||
((equal? type 'uint8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) '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) (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR))
|
||||
((equal? type 'unsigned-char) (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR))
|
||||
((equal? type 'short) (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT))
|
||||
((equal? type 'unsigned-short) (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT))
|
||||
((equal? type 'int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
|
||||
((equal? type 'unsigned-int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT))
|
||||
((equal? type 'long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG))
|
||||
((equal? type 'unsigned-long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG))
|
||||
((equal? type 'float) (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT))
|
||||
((equal? type 'double) (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE))
|
||||
((equal? type 'pointer) (static-field java.lang.foreign.ValueLayout 'ADDRESS))
|
||||
((equal? type 'string) (static-field java.lang.foreign.ValueLayout 'ADDRESS))
|
||||
((equal? type 'void) (static-field java.lang.foreign.ValueLayout 'ADDRESS))
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(string=? (invoke (invoke object 'getClass) 'getName)
|
||||
"jdk.internal.foreign.NativeMemorySegmentImpl")))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(let* ((of-void (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid))
|
||||
(of (class-methods java.lang.foreign.FunctionDescriptor 'of))
|
||||
(function-descriptor (if (equal? return-type 'void)
|
||||
(apply of-void (map pffi-type->native-type argument-types))
|
||||
(apply of (append (list (pffi-type->native-type return-type)) (map pffi-type->native-type argument-types)))))
|
||||
(method-handle (invoke (cdr (assoc 'linker shared-object))
|
||||
'downcallHandle
|
||||
(invoke (invoke (cdr (assoc 'lookup shared-object))
|
||||
'find
|
||||
(symbol->string c-name))
|
||||
'orElseThrow)
|
||||
function-descriptor)))
|
||||
|
||||
(lambda vals
|
||||
(invoke method-handle 'invokeWithArguments (map value->object vals argument-types))))))))
|
||||
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(invoke (pffi-type->native-type type) 'byteAlignment)))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(invoke arena 'allocate size 1)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(static-field java.lang.foreign.MemorySegment 'NULL)))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(invoke arena 'allocateUtf8String string-content)))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getUtf8String 0)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(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))
|
||||
;(set! arena (invoke-static java.lang.foreign.Arena 'ofConfined))
|
||||
|
||||
(linker (invoke-static java.lang.foreign.Linker 'nativeLinker))
|
||||
(lookup (invoke-static java.lang.foreign.SymbolLookup
|
||||
'libraryLookup
|
||||
absolute-path
|
||||
arena)))
|
||||
(list (cons 'linker linker)
|
||||
(cons 'lookup lookup)))))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
#t))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(invoke pointer 'equals (pffi-pointer-null))))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(invoke pointer 'set (pffi-type->native-type type) offset value)))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(invoke pointer 'get (pffi-type->native-type type) offset)))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0)))
|
||||
|
|
@ -0,0 +1,234 @@
|
|||
#lang r7rs
|
||||
(define-library
|
||||
(retropikzel r7rs-pffi version main)
|
||||
(cond-expand
|
||||
(sagittarius
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version sagittarius)))
|
||||
(guile
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version guile)))
|
||||
(racket
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(only (racket base) system-type)
|
||||
(retropikzel r7rs-pffi version racket)))
|
||||
(stklos
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(stklos)
|
||||
(retropikzel r7rs-pffi version stklos)))
|
||||
(kawa
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)))
|
||||
(cyclone
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version cyclone)))
|
||||
(gambit
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version gambit)))
|
||||
(chicken
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version chicken)))
|
||||
(chibi
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version chibi)))
|
||||
(mit-scheme
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version mit-scheme))))
|
||||
(export pffi-shared-object-auto-load
|
||||
pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
|
||||
#|doc Testing multiline comment |#
|
||||
|
||||
|
||||
|
||||
(define library-version "v0-3-0")
|
||||
(define slash (cond-expand (windows (string #\\)) (else "/")))
|
||||
|
||||
(define platform-file-extension
|
||||
(cond-expand
|
||||
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
|
||||
(windows ".dll")
|
||||
(else ".so")))
|
||||
|
||||
(define platform-lib-prefix
|
||||
(cond-expand
|
||||
(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
|
||||
(windows "")
|
||||
(else "lib")))
|
||||
|
||||
(define pffi-types
|
||||
'(int8
|
||||
uint8
|
||||
int16
|
||||
uint16
|
||||
int32
|
||||
uint32
|
||||
int64
|
||||
uint64
|
||||
char
|
||||
unsigned-char
|
||||
short
|
||||
unsigned-short
|
||||
int
|
||||
unsigned-int
|
||||
long
|
||||
unsigned-long
|
||||
float
|
||||
double
|
||||
string
|
||||
pointer
|
||||
void))
|
||||
|
||||
(define string-split
|
||||
(lambda (str mark)
|
||||
(let* ((str-l (string->list str))
|
||||
(res (list))
|
||||
(last-index 0)
|
||||
(index 0)
|
||||
(splitter (lambda (c)
|
||||
(cond ((char=? c mark)
|
||||
(begin
|
||||
(set! res (append res (list (string-copy str last-index index))))
|
||||
(set! last-index (+ index 1))))
|
||||
((equal? (length str-l) (+ index 1))
|
||||
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
|
||||
(set! index (+ index 1)))))
|
||||
(for-each splitter str-l)
|
||||
res)))
|
||||
|
||||
(define auto-load-paths
|
||||
(append
|
||||
(cond-expand
|
||||
(windows
|
||||
(append
|
||||
(if (get-environment-variable "SYSTEM")
|
||||
(list (get-environment-variable "SYSTEM"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINDIR")
|
||||
(list (get-environment-variable "WINDIR"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINEDLLDIR0")
|
||||
(list (get-environment-variable "WINEDLLDIR0"))
|
||||
(list))
|
||||
(if (get-environment-variable "SystemRoot")
|
||||
(list (string-append
|
||||
(get-environment-variable "SystemRoot")
|
||||
slash
|
||||
"system32"))
|
||||
(list))
|
||||
(list ".")
|
||||
(if (get-environment-variable "PATH")
|
||||
(string-split (get-environment-variable "PATH") #\;)
|
||||
(list))))
|
||||
(else
|
||||
(append
|
||||
; Guix
|
||||
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
|
||||
(string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib")
|
||||
"")
|
||||
"/run/current-system/profile/lib")
|
||||
; Debian
|
||||
(if (get-environment-variable "LD_LIBRARY_PATH")
|
||||
(list (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"
|
||||
))))))
|
||||
|
||||
(define auto-load-versions (list ""))
|
||||
|
||||
(define-syntax pffi-shared-object-auto-load
|
||||
(syntax-rules ()
|
||||
((pffi-shared-object-auto-load headers additional-paths object-name additional-versions)
|
||||
(cond-expand
|
||||
(cyclone (pffi-shared-object-load headers))
|
||||
(chicken (pffi-shared-object-load headers))
|
||||
(gambit (pffi-shared-object-load headers))
|
||||
(else
|
||||
(let* ((paths (append auto-load-paths additional-paths))
|
||||
(versions (append auto-load-versions additional-versions))
|
||||
(shared-object #f))
|
||||
(for-each
|
||||
(lambda (path)
|
||||
(for-each
|
||||
(lambda (version)
|
||||
(let ((library-path (string-append path
|
||||
slash
|
||||
platform-lib-prefix
|
||||
object-name
|
||||
platform-file-extension
|
||||
version)))
|
||||
(if (file-exists? library-path)
|
||||
(set! shared-object library-path))))
|
||||
versions))
|
||||
paths)
|
||||
(if (not shared-object)
|
||||
(error "Could not load shared object"
|
||||
(list (cons 'object object-name)
|
||||
(cons 'paths paths)
|
||||
(cons 'platform-file-extension platform-file-extension)
|
||||
(cons 'versions versions)))
|
||||
(pffi-shared-object-load headers shared-object))))))))
|
||||
|
||||
(cond-expand
|
||||
(kawa (include "kawa.scm"))
|
||||
(else #t))))
|
||||
|
|
@ -0,0 +1,233 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version main)
|
||||
(cond-expand
|
||||
(sagittarius
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version sagittarius)))
|
||||
(guile
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version guile)))
|
||||
(racket
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(only (racket base) system-type)
|
||||
(retropikzel r7rs-pffi version racket)))
|
||||
(stklos
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(stklos)
|
||||
(retropikzel r7rs-pffi version stklos)))
|
||||
(kawa
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)))
|
||||
(cyclone
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version cyclone)))
|
||||
(gambit
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version gambit)))
|
||||
(chicken
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version chicken)))
|
||||
(chibi
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version chibi)))
|
||||
(mit-scheme
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version mit-scheme))))
|
||||
(export pffi-shared-object-auto-load
|
||||
pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
|
||||
#|doc Testing multiline comment |#
|
||||
|
||||
|
||||
|
||||
(define library-version "v0-3-0")
|
||||
(define slash (cond-expand (windows (string #\\)) (else "/")))
|
||||
|
||||
(define platform-file-extension
|
||||
(cond-expand
|
||||
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
|
||||
(windows ".dll")
|
||||
(else ".so")))
|
||||
|
||||
(define platform-lib-prefix
|
||||
(cond-expand
|
||||
(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
|
||||
(windows "")
|
||||
(else "lib")))
|
||||
|
||||
(define pffi-types
|
||||
'(int8
|
||||
uint8
|
||||
int16
|
||||
uint16
|
||||
int32
|
||||
uint32
|
||||
int64
|
||||
uint64
|
||||
char
|
||||
unsigned-char
|
||||
short
|
||||
unsigned-short
|
||||
int
|
||||
unsigned-int
|
||||
long
|
||||
unsigned-long
|
||||
float
|
||||
double
|
||||
string
|
||||
pointer
|
||||
void))
|
||||
|
||||
(define string-split
|
||||
(lambda (str mark)
|
||||
(let* ((str-l (string->list str))
|
||||
(res (list))
|
||||
(last-index 0)
|
||||
(index 0)
|
||||
(splitter (lambda (c)
|
||||
(cond ((char=? c mark)
|
||||
(begin
|
||||
(set! res (append res (list (string-copy str last-index index))))
|
||||
(set! last-index (+ index 1))))
|
||||
((equal? (length str-l) (+ index 1))
|
||||
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
|
||||
(set! index (+ index 1)))))
|
||||
(for-each splitter str-l)
|
||||
res)))
|
||||
|
||||
(define auto-load-paths
|
||||
(append
|
||||
(cond-expand
|
||||
(windows
|
||||
(append
|
||||
(if (get-environment-variable "SYSTEM")
|
||||
(list (get-environment-variable "SYSTEM"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINDIR")
|
||||
(list (get-environment-variable "WINDIR"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINEDLLDIR0")
|
||||
(list (get-environment-variable "WINEDLLDIR0"))
|
||||
(list))
|
||||
(if (get-environment-variable "SystemRoot")
|
||||
(list (string-append
|
||||
(get-environment-variable "SystemRoot")
|
||||
slash
|
||||
"system32"))
|
||||
(list))
|
||||
(list ".")
|
||||
(if (get-environment-variable "PATH")
|
||||
(string-split (get-environment-variable "PATH") #\;)
|
||||
(list))))
|
||||
(else
|
||||
(append
|
||||
; Guix
|
||||
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
|
||||
(string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib")
|
||||
"")
|
||||
"/run/current-system/profile/lib")
|
||||
; Debian
|
||||
(if (get-environment-variable "LD_LIBRARY_PATH")
|
||||
(list (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"
|
||||
))))))
|
||||
|
||||
(define auto-load-versions (list ""))
|
||||
|
||||
(define-syntax pffi-shared-object-auto-load
|
||||
(syntax-rules ()
|
||||
((pffi-shared-object-auto-load headers additional-paths object-name additional-versions)
|
||||
(cond-expand
|
||||
(cyclone (pffi-shared-object-load headers))
|
||||
(chicken (pffi-shared-object-load headers))
|
||||
(gambit (pffi-shared-object-load headers))
|
||||
(else
|
||||
(let* ((paths (append auto-load-paths additional-paths))
|
||||
(versions (append auto-load-versions additional-versions))
|
||||
(shared-object #f))
|
||||
(for-each
|
||||
(lambda (path)
|
||||
(for-each
|
||||
(lambda (version)
|
||||
(let ((library-path (string-append path
|
||||
slash
|
||||
platform-lib-prefix
|
||||
object-name
|
||||
platform-file-extension
|
||||
version)))
|
||||
(if (file-exists? library-path)
|
||||
(set! shared-object library-path))))
|
||||
versions))
|
||||
paths)
|
||||
(if (not shared-object)
|
||||
(error "Could not load shared object"
|
||||
(list (cons 'object object-name)
|
||||
(cons 'paths paths)
|
||||
(cons 'platform-file-extension platform-file-extension)
|
||||
(cons 'versions versions)))
|
||||
(pffi-shared-object-load headers shared-object))))))))
|
||||
|
||||
(cond-expand
|
||||
(kawa (include "kawa.scm"))
|
||||
(else #t))))
|
||||
|
|
@ -0,0 +1,233 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version main)
|
||||
(cond-expand
|
||||
(sagittarius
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version sagittarius)))
|
||||
(guile
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version guile)))
|
||||
(racket
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(only (racket base) system-type)
|
||||
(retropikzel r7rs-pffi version racket)))
|
||||
(stklos
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(stklos)
|
||||
(retropikzel r7rs-pffi version stklos)))
|
||||
(kawa
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)))
|
||||
(cyclone
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version cyclone)))
|
||||
(gambit
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version gambit)))
|
||||
(chicken
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version chicken)))
|
||||
(chibi
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version chibi)))
|
||||
(mit-scheme
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version mit-scheme))))
|
||||
(export pffi-shared-object-auto-load
|
||||
pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
|
||||
#|doc Testing multiline comment |#
|
||||
|
||||
|
||||
|
||||
(define library-version "v0-3-0")
|
||||
(define slash (cond-expand (windows (string #\\)) (else "/")))
|
||||
|
||||
(define platform-file-extension
|
||||
(cond-expand
|
||||
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
|
||||
(windows ".dll")
|
||||
(else ".so")))
|
||||
|
||||
(define platform-lib-prefix
|
||||
(cond-expand
|
||||
(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
|
||||
(windows "")
|
||||
(else "lib")))
|
||||
|
||||
(define pffi-types
|
||||
'(int8
|
||||
uint8
|
||||
int16
|
||||
uint16
|
||||
int32
|
||||
uint32
|
||||
int64
|
||||
uint64
|
||||
char
|
||||
unsigned-char
|
||||
short
|
||||
unsigned-short
|
||||
int
|
||||
unsigned-int
|
||||
long
|
||||
unsigned-long
|
||||
float
|
||||
double
|
||||
string
|
||||
pointer
|
||||
void))
|
||||
|
||||
(define string-split
|
||||
(lambda (str mark)
|
||||
(let* ((str-l (string->list str))
|
||||
(res (list))
|
||||
(last-index 0)
|
||||
(index 0)
|
||||
(splitter (lambda (c)
|
||||
(cond ((char=? c mark)
|
||||
(begin
|
||||
(set! res (append res (list (string-copy str last-index index))))
|
||||
(set! last-index (+ index 1))))
|
||||
((equal? (length str-l) (+ index 1))
|
||||
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
|
||||
(set! index (+ index 1)))))
|
||||
(for-each splitter str-l)
|
||||
res)))
|
||||
|
||||
(define auto-load-paths
|
||||
(append
|
||||
(cond-expand
|
||||
(windows
|
||||
(append
|
||||
(if (get-environment-variable "SYSTEM")
|
||||
(list (get-environment-variable "SYSTEM"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINDIR")
|
||||
(list (get-environment-variable "WINDIR"))
|
||||
(list))
|
||||
(if (get-environment-variable "WINEDLLDIR0")
|
||||
(list (get-environment-variable "WINEDLLDIR0"))
|
||||
(list))
|
||||
(if (get-environment-variable "SystemRoot")
|
||||
(list (string-append
|
||||
(get-environment-variable "SystemRoot")
|
||||
slash
|
||||
"system32"))
|
||||
(list))
|
||||
(list ".")
|
||||
(if (get-environment-variable "PATH")
|
||||
(string-split (get-environment-variable "PATH") #\;)
|
||||
(list))))
|
||||
(else
|
||||
(append
|
||||
; Guix
|
||||
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
|
||||
(string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib")
|
||||
"")
|
||||
"/run/current-system/profile/lib")
|
||||
; Debian
|
||||
(if (get-environment-variable "LD_LIBRARY_PATH")
|
||||
(list (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"
|
||||
))))))
|
||||
|
||||
(define auto-load-versions (list ""))
|
||||
|
||||
(define-syntax pffi-shared-object-auto-load
|
||||
(syntax-rules ()
|
||||
((pffi-shared-object-auto-load headers additional-paths object-name additional-versions)
|
||||
(cond-expand
|
||||
(cyclone (pffi-shared-object-load headers))
|
||||
(chicken (pffi-shared-object-load headers))
|
||||
(gambit (pffi-shared-object-load headers))
|
||||
(else
|
||||
(let* ((paths (append auto-load-paths additional-paths))
|
||||
(versions (append auto-load-versions additional-versions))
|
||||
(shared-object #f))
|
||||
(for-each
|
||||
(lambda (path)
|
||||
(for-each
|
||||
(lambda (version)
|
||||
(let ((library-path (string-append path
|
||||
slash
|
||||
platform-lib-prefix
|
||||
object-name
|
||||
platform-file-extension
|
||||
version)))
|
||||
(if (file-exists? library-path)
|
||||
(set! shared-object library-path))))
|
||||
versions))
|
||||
paths)
|
||||
(if (not shared-object)
|
||||
(error "Could not load shared object"
|
||||
(list (cons 'object object-name)
|
||||
(cons 'paths paths)
|
||||
(cons 'platform-file-extension platform-file-extension)
|
||||
(cons 'versions versions)))
|
||||
(pffi-shared-object-load headers shared-object))))))))
|
||||
|
||||
(cond-expand
|
||||
(kawa (include "kawa.scm"))
|
||||
(else #t))))
|
||||
|
|
@ -0,0 +1,118 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version racket)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(compatibility mlist)
|
||||
(ffi unsafe)
|
||||
(ffi vector))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) _int8)
|
||||
((equal? type 'uint8) _uint8)
|
||||
((equal? type 'int16) _int16)
|
||||
((equal? type 'uint16) _uint16)
|
||||
((equal? type 'int32) _int32)
|
||||
((equal? type 'uint32) _uint32)
|
||||
((equal? type 'int64) _int64)
|
||||
((equal? type 'uint64) _uint64)
|
||||
((equal? type 'char) _int)
|
||||
((equal? type 'unsigned-char) _int)
|
||||
((equal? type 'short) _short)
|
||||
((equal? type 'unsigned-short) _ushort)
|
||||
((equal? type 'int) _int)
|
||||
((equal? type 'unsigned-int) _uint)
|
||||
((equal? type 'long) _long)
|
||||
((equal? type 'unsigned-long) _ulong)
|
||||
((equal? type 'float) _float)
|
||||
((equal? type 'double) _double)
|
||||
((equal? type 'pointer) _pointer)
|
||||
((equal? type 'string) _pointer)
|
||||
((equal? type 'void) _void)
|
||||
((equal? type 'callback) _pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(cpointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(get-ffi-obj c-name
|
||||
shared-object
|
||||
(_cprocedure (mlist->list (map pffi-type->native-type argument-types))
|
||||
(pffi-type->native-type return-type)))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define-callback scheme-name return-type argument-types procedure)
|
||||
(define scheme-name (function-ptr procedure
|
||||
(_cprocedure
|
||||
(mlist->list (map pffi-type->native-type argument-types))
|
||||
(pffi-type->native-type return-type)))
|
||||
))))
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(ctype-sizeof (pffi-type->native-type type))))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(malloc size 'raw)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
#f ; In racket #f is null pointer
|
||||
))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(cast string-content _string _pointer)))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(cast pointer _pointer _string)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(ffi-lib path)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(free pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(not pointer) ; #f is the null pointer on racket
|
||||
))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(ptr-set! pointer (pffi-type->native-type type) offset value)))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(ptr-ref pointer (pffi-type->native-type type) offset)))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
pointer))))
|
||||
|
|
@ -0,0 +1,171 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version sagittarius)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(sagittarius ffi)
|
||||
(sagittarius))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
pffi-size-of
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-null
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-pointer-free
|
||||
pffi-pointer?
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'string) 'char*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'callback)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer? (lambda (object) (pointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-c-function shared-object
|
||||
(pffi-type->native-type return-type)
|
||||
c-name
|
||||
(map pffi-type->native-type argument-types))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define-callback scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
(make-c-callback (pffi-type->native-type return-type)
|
||||
(map pffi-type->native-type argument-types)
|
||||
procedure)))))
|
||||
|
||||
(define pffi-size-of
|
||||
(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 'string) size-of-void*)
|
||||
((eq? type 'pointer) size-of-void*)
|
||||
(else (error "Can not get size of unknown type" type)))))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(c-malloc size)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(integer->pointer 0)))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
string-content))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(if (string? pointer)
|
||||
pointer
|
||||
(pointer->string pointer))))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(open-shared-library path)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(c-free pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(null-pointer? pointer)))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(cond ((equal? type 'int8) (pointer-set-c-int8_t! p offset value))
|
||||
((equal? type 'uint8) (pointer-set-c-uint8_t! p offset value))
|
||||
((equal? type 'int16) (pointer-set-c-int16_t! p offset value))
|
||||
((equal? type 'uint16) (pointer-set-c-uint16_t! p offset value))
|
||||
((equal? type 'int32) (pointer-set-c-int32_t! p offset value))
|
||||
((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value))
|
||||
((equal? type 'int64) (pointer-set-c-int64_t! p offset value))
|
||||
((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value))
|
||||
((equal? type 'char) (pointer-set-c-char! p offset value))
|
||||
((equal? type 'short) (pointer-set-c-short! p offset value))
|
||||
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value))
|
||||
((equal? type 'int) (pointer-set-c-int! p offset value))
|
||||
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! p offset value))
|
||||
((equal? type 'long) (pointer-set-c-long! p offset value))
|
||||
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value))
|
||||
((equal? type 'float) (pointer-set-c-float! p offset value))
|
||||
((equal? type 'double) (pointer-set-c-double! p offset value))
|
||||
((equal? type 'void*) (pointer-set-c-pointer p offset value))))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(let ((p pointer)
|
||||
(native-type (pffi-type->native-type type)))
|
||||
(cond ((equal? native-type 'int8_t) (pointer-ref-c-int8_t p offset))
|
||||
((equal? native-type 'uint8_t) (pointer-ref-c-uint8_t p offset))
|
||||
((equal? native-type 'int16_t) (pointer-ref-c-int16_t p offset))
|
||||
((equal? native-type 'uint16_t) (pointer-ref-c-uint16_t p offset))
|
||||
((equal? native-type 'int32_t) (pointer-ref-c-int32_t p offset))
|
||||
((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset))
|
||||
((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset))
|
||||
((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset))
|
||||
((equal? native-type 'char) (pointer-ref-c-char p offset))
|
||||
((equal? native-type 'short) (pointer-set-c-short p offset value))
|
||||
((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
|
||||
((equal? native-type 'int) (pointer-ref-c-int p offset))
|
||||
((equal? native-type 'unsigned-int) (pointer-ref-c-unsigned-int p offset))
|
||||
((equal? native-type 'long) (pointer-ref-c-long p offset))
|
||||
((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset))
|
||||
((equal? native-type 'float) (pointer-ref-c-float p offset))
|
||||
((equal? native-type 'double) (pointer-ref-c-double p offset))
|
||||
((equal? native-type 'void*) (pointer-ref-c-pointer p offset))))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(deref pointer 0)))))
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version stklos)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(stklos))
|
||||
(export pffi-define
|
||||
pffi-pointer->string
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-deref
|
||||
pffi-pointer-free
|
||||
pffi-pointer-get
|
||||
pffi-pointer-null
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer?
|
||||
pffi-shared-object-load
|
||||
pffi-size-of
|
||||
pffi-string->pointer)
|
||||
(begin
|
||||
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) :int)
|
||||
((equal? type 'uint8) :uint)
|
||||
((equal? type 'int16) :int)
|
||||
((equal? type 'uint16) :uint)
|
||||
((equal? type 'int32) :int)
|
||||
((equal? type 'uint32) :uint)
|
||||
((equal? type 'int64) :int)
|
||||
((equal? type 'uint64) :uint)
|
||||
((equal? type 'char) :char)
|
||||
((equal? type 'unsigned-char) :uchar)
|
||||
((equal? type 'short) :short)
|
||||
((equal? type 'unsigned-short) :ushort)
|
||||
((equal? type 'int) :int)
|
||||
((equal? type 'unsigned-int) :uint)
|
||||
((equal? type 'long) :long)
|
||||
((equal? type 'unsigned-long) :ulong)
|
||||
((equal? type 'float) :float)
|
||||
((equal? type 'double) :double)
|
||||
((equal? type 'pointer) :pointer)
|
||||
((equal? type 'string) :string)
|
||||
((equal? type 'void) :void)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(cpointer? object)))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
(make-external-function
|
||||
(symbol->string c-name)
|
||||
(map pffi-type->native-type argument-types)
|
||||
(pffi-type->native-type return-type)
|
||||
shared-object)))))
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(error "Not implemented")))
|
||||
|
||||
(define pffi-pointer-allocate
|
||||
(lambda (size)
|
||||
(allocate-bytes size)))
|
||||
|
||||
(define pffi-pointer-null
|
||||
(lambda ()
|
||||
(let ((p (allocate-bytes 0))) (cpointer-data-set! p 0) p)))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
string-content))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
path))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(free-bytes pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(cpointer-null? pointer)))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(error "Not implemented")))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not implemented")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not implemented")))))
|
||||
|
|
@ -5,5 +5,3 @@ set -o pipefail
|
|||
make clean
|
||||
make build
|
||||
make tmp
|
||||
|
||||
VERSION=$(cat VERSION)
|
||||
|
|
|
|||
|
|
@ -2,15 +2,14 @@
|
|||
|
||||
source scripts/init-test.sh
|
||||
|
||||
CHICKEN_REPOSITORY_PATH=${PWD}/retropikzel/r7rs-pffi/version
|
||||
SCHEME="csc -X r7rs -R r7rs -L -lcurl"
|
||||
SCHEME_LIB="csc -X r7rs -R r7rs -sJ"
|
||||
SCHEME_LIB="csc -X r7rs -R r7rs -s -J"
|
||||
SCHEME_I="csi -R r7rs"
|
||||
|
||||
cp retropikzel/pffi/${VERSION}/main.sld retropikzel/pffi/${VERSION}/retropikzel.pffi.${VERSION}.main.scm
|
||||
cp retropikzel/pffi/${VERSION}/chicken.scm retropikzel/pffi/${VERSION}/retropikzel.pffi.${VERSION}.chicken.scm
|
||||
cp retropikzel/pffi/${VERSION}/main.sld retropikzel.pffi.${VERSION}.main.scm
|
||||
cp retropikzel/pffi/${VERSION}/chicken.scm retropikzel.pffi.${VERSION}.chicken.scm
|
||||
${SCHEME_LIB} retropikzel.pffi.${VERSION}.chicken.scm
|
||||
${SCHEME_LIB} retropikzel.pffi.${VERSION}.main.scm
|
||||
cp retropikzel/r7rs-pffi/version/chicken.scm retropikzel.r7rs-pffi.version.chicken.scm
|
||||
cp retropikzel/r7rs-pffi/version/main.scm retropikzel.r7rs-pffi.version.main.scm
|
||||
${SCHEME_LIB} retropikzel.r7rs-pffi.version.chicken.scm
|
||||
${SCHEME_LIB} retropikzel.r7rs-pffi.version.main.scm
|
||||
|
||||
source scripts/test-runs-compilers.sh
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(retropikzel r7rs-pffi v0-4-0 main))
|
||||
(retropikzel r7rs-pffi version main))
|
||||
|
||||
(display "Hello from import.scm")
|
||||
(newline)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(retropikzel r7rs-pffi v0-4-0 main))
|
||||
(retropikzel r7rs-pffi version main))
|
||||
|
||||
(display 'int8)
|
||||
(display " ")
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(retropikzel r7rs-pffi v0-4-0 main))
|
||||
(retropikzel r7rs-pffi version main))
|
||||
|
||||
(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3)
|
||||
(* (pffi-size-of 'uint8) 4)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(retropikzel r7rs-pffi v0-4-0 main))
|
||||
(retropikzel r7rs-pffi version main))
|
||||
|
||||
(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3)
|
||||
(* (pffi-size-of 'uint8) 4)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(retropikzel r7rs-pffi v0-4-0 main))
|
||||
(retropikzel r7rs-pffi version main))
|
||||
|
||||
(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3)
|
||||
(* (pffi-size-of 'uint8) 4)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(retropikzel r7rs-pffi v0-4-0 main))
|
||||
(retropikzel r7rs-pffi version main))
|
||||
|
||||
(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3)
|
||||
(* (pffi-size-of 'uint8) 4)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(retropikzel r7rs-pffi v0-4-0 main))
|
||||
(retropikzel r7rs-pffi version main))
|
||||
|
||||
(define original "Hello world")
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
(scheme write)
|
||||
(scheme process-context)
|
||||
(scheme eval)
|
||||
(retropikzel r7rs-pffi v0-4-0 main))
|
||||
(retropikzel r7rs-pffi version main))
|
||||
|
||||
(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h")
|
||||
(list)
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
(scheme write)
|
||||
(scheme process-context)
|
||||
(scheme eval)
|
||||
(retropikzel r7rs-pffi v0-4-0 main))
|
||||
(retropikzel r7rs-pffi version main))
|
||||
|
||||
(define libc (pffi-shared-object-auto-load (list "curl/curl.h")
|
||||
(list)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi v0-4-0 main))
|
||||
(retropikzel r7rs-pffi version main))
|
||||
|
||||
(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h") ; Headers
|
||||
(list ".") ; Additional search paths
|
||||
|
|
|
|||
Loading…
Reference in New Issue