Updated the support table. Added cond-expand to export side in .sld file.

This commit is contained in:
retropikzel 2024-11-14 19:50:18 +02:00
parent 72b6251c70
commit 6bb46c09c0
8 changed files with 409 additions and 75 deletions

1
.gitignore vendored
View File

@ -21,6 +21,7 @@ pffi-define
test/pffi-define
size-of
test/*
test
!test/*.scm
retropikzel/pffi/*/*.c
retropikzel/pffi/*/*.o*

7
HACKING.md Normal file
View File

@ -0,0 +1,7 @@
To run tests on different architecture than you are using, install podman and add the docker
registry to it's configuration. Add the line
unqualified-search-registries = ["docker.io"]
to file: /etc/containers/registries.conf

View File

@ -115,7 +115,7 @@ test-ypsilon-podman-amd64:
podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/ypsilon bash -c "cd /workdir && ${YPSILON} test.scm"
test-ypsilon:
tr7i test.scm
${YPSILON} test.scm
documentation:
cat README.md > docs/index.md

View File

@ -38,25 +38,25 @@ guarantees are being made just yet.
## Implementation table
| | Chibi | Chicken | Cyclone | Gambit | Gauche | Gerbil | Guile | Kawa | Mosh | Racket | Sagittarius | Skint | STklos | tr7 |
| ------------------------------- | ----- | ------- | ------- | ------- | ------ | ------ | ----- | ---- | ---- | ------ | ----------- | ----- | ------ | --- |
| pffi-init | X | X | X | | | | X | X | X | X | X | | X | |
| pffi-size-of | X | X | X | | | | X | X | X | X | X | | X | |
| pffi-shared-object-auto-load | X | X | X | | | | X | X | X | X | X | | X | |
| pffi-shared-object-load | X | X | X | | | | X | X | X | X | X | | X | |
| pffi-pointer-null | X | X | X | | | | X | X | X | X | X | | X | |
| pffi-pointer-null? | X | X | X | | | | X | X | X | X | X | | X | |
| pffi-pointer-allocate | X | X | X | | | | X | X | X | X | X | | X | |
| pffi-pointer? | X | X | X | | | | X | X | X | X | X | | X | |
| pffi-pointer-free | X | X | X | | | | X | X | X | X | X | | X | |
| pffi-pointer-set! | X | X | X | | | | X | X | X | X | X | | | |
| pffi-pointer-get | X | X | X | | | | X | X | X | X | X | | | |
| pffi-string->pointer | X | X | X | | | | X | X | X | X | X | | | |
| pffi-pointer->string | X | X | X | | | | X | X | X | X | X | | | |
| pffi-define | X | X | X | | | | X | X | X | X | X | | | |
| pffi-define-callback | | X | | | | | X | | X | X | X | | | |
| pffi-pointer-address | | X | | | | | X | | | X | X | | | |
| pffi-pointer-dereference | | | | | | | X | | | X | X | | | |
| | Chibi | Chicken | Cyclone | Gambit | Gauche | Gerbil | Guile | Kawa | Larceny | Mosh | Racket | Sagittarius | Skint | STklos | tr7 | Ypsilon |
| ------------------------------- | ----- | ------- | ------- | ------- | ------ | ------ | ----- | ---- | ------- | ---- | ------ | ----------- | ----- | ------ | --- | ------- |
| pffi-init | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | |
| pffi-size-of | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-shared-object-auto-load | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-shared-object-load | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer-null | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer-null? | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer-allocate | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer? | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer-free | X | X | X | | | | X | X | | X | X | X | | X | | |
| pffi-pointer-set! | X | X | X | | | | X | X | | X | X | X | | | | |
| pffi-pointer-get | X | X | X | | | | X | X | | X | X | X | | | | |
| pffi-string->pointer | X | X | X | | | | X | X | | X | X | X | | | | |
| pffi-pointer->string | X | X | X | | | | X | X | | X | X | X | | | | |
| pffi-define | X | X | X | | | | X | X | | X | X | X | | | | |
| pffi-define-callback | | X | | | | | X | | | X | X | X | | | | |
| pffi-pointer-address | | X | | | | | X | | | | X | X | | | | |
| pffi-pointer-dereference | | | | | | | X | | | | X | X | | | | |
### Usage notes
@ -74,6 +74,10 @@ guarantees are being made just yet.
- --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED
- --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED
- --enable-native-access=ALL-UNNAMED
- Larceny
- Runs on 32 bit mode
- Mosh
- FFI only works on x86_64
- Racket
- Needs [racket-r7rs](https://github.com/lexi-lambda/racket-r7rs)
@ -87,12 +91,11 @@ guarantees are being made just yet.
- Javascript side needs design
- [MIT-Scheme](https://www.gnu.org/software/mit-scheme/)
- [s7](https://scheme.fail://ccrma.stanford.edu/software/snd/snd/s7.html)
- [Ypsilon](http://www.littlewingpinball.com/doc/en/ypsilon/)
- [Larceny](https://larcenists.org/)
- [Airship](https://gitlab.com/mbabich/airship-scheme)
- [Other gambit targets](https://gambitscheme.org/)
- Gambit compiles to different targets other than C too, for example Javascript. It would be cool
and interesting to see if this FFI could also support some of those
- When LIPS and Biwascheme Javascript side is done then Gambit should be done too
- [s48-r7rs](https://codeberg.org/prescheme/s48-r7rs)
- [prescheme](https://codeberg.org/prescheme/prescheme)

View File

@ -9,118 +9,6 @@
(scheme process-context)
(chibi ast)
(chibi))
(include-shared "r7rs-pffi/r7rs-pffi-chibi"))
(chicken
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(chicken foreign)
(chicken locative)
(chicken syntax)
(chicken memory)
(chicken random)))
(cyclone
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(cyclone foreign)
(scheme cyclone primitives)))
(gambit
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(only (gambit) c-declare c-lambda c-define)))
(gauche
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(gerbil
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(guile
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(rnrs bytevectors)
(system foreign)
(system foreign-library)))
(kawa
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(larceny
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(mosh
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(mosh ffi)))
(racket
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(only (racket base) system-type)
(ffi winapi)
(compatibility mlist)
(ffi unsafe)
(ffi vector)))
(sagittarius
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(sagittarius ffi)
(sagittarius)))
(skint
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(stklos
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(stklos)))
(tr7
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(ypsilon
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(else (error "Unsupported implementation")))
(export pffi-init
pffi-size-of
pffi-shared-object-auto-load
@ -137,8 +25,394 @@
pffi-define
;pffi-define-callback
;pffi-pointer-address
pffi-pointer-dereference
;pffi-pointer-dereference
)
(include-shared "r7rs-pffi/r7rs-pffi-chibi"))
(chicken
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(chicken foreign)
(chicken locative)
(chicken syntax)
(chicken memory)
(chicken random))
(export pffi-init
pffi-size-of
pffi-shared-object-auto-load
pffi-shared-object-load
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer?
pffi-pointer-free
pffi-pointer-set!
pffi-pointer-get
pffi-string->pointer
pffi-pointer->string
pffi-define
pffi-define-callback
pffi-pointer-address
;pffi-pointer-dereference
))
(cyclone
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(cyclone foreign)
(scheme cyclone primitives))
(export pffi-init
pffi-size-of
pffi-shared-object-auto-load
pffi-shared-object-load
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer?
pffi-pointer-free
pffi-pointer-set!
pffi-pointer-get
pffi-string->pointer
pffi-pointer->string
pffi-define
;pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
))
(gambit
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(only (gambit) c-declare c-lambda c-define))
(export pffi-init
;pffi-size-of
;pffi-shared-object-auto-load
;pffi-shared-object-load
;pffi-pointer-null
;pffi-pointer-null?
;pffi-pointer-allocate
;pffi-pointer?
;pffi-pointer-free
;pffi-pointer-set!
;pffi-pointer-get
;pffi-string->pointer
;pffi-pointer->string
;pffi-define
;pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
))
(gauche
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context))
(export pffi-init
;pffi-size-of
;pffi-shared-object-auto-load
;pffi-shared-object-load
;pffi-pointer-null
;pffi-pointer-null?
;pffi-pointer-allocate
;pffi-pointer?
;pffi-pointer-free
;pffi-pointer-set!
;pffi-pointer-get
;pffi-string->pointer
;pffi-pointer->string
;pffi-define
;pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
))
(gerbil
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context))
(export pffi-init
;pffi-size-of
;pffi-shared-object-auto-load
;pffi-shared-object-load
;pffi-pointer-null
;pffi-pointer-null?
;pffi-pointer-allocate
;pffi-pointer?
;pffi-pointer-free
;pffi-pointer-set!
;pffi-pointer-get
;pffi-string->pointer
;pffi-pointer->string
;pffi-define
;pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
))
(guile
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(rnrs bytevectors)
(system foreign)
(system foreign-library))
(export pffi-init
pffi-size-of
pffi-shared-object-auto-load
pffi-shared-object-load
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer?
pffi-pointer-free
pffi-pointer-set!
pffi-pointer-get
pffi-string->pointer
pffi-pointer->string
pffi-define
pffi-define-callback
pffi-pointer-address
pffi-pointer-dereference))
(kawa
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context))
(export pffi-init
pffi-size-of
pffi-shared-object-auto-load
pffi-shared-object-load
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer?
pffi-pointer-free
pffi-pointer-set!
pffi-pointer-get
pffi-string->pointer
pffi-pointer->string
pffi-define
;pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
))
(larceny
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(rename (primitives r5rs:require) (r5rs:require require))
(primitives std-ffi)
(primitives foreign-procedure)
(primitives foreign-file)
(primitives foreign-stdlib)
)
(export pffi-init
;pffi-size-of
;pffi-shared-object-auto-load
;pffi-shared-object-load
;pffi-pointer-null
;pffi-pointer-null?
;pffi-pointer-allocate
;pffi-pointer?
;pffi-pointer-free
;pffi-pointer-set!
;pffi-pointer-get
;pffi-string->pointer
;pffi-pointer->string
;pffi-define
;pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
)
)
(mosh
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(mosh ffi))
(export pffi-init
pffi-size-of
pffi-shared-object-auto-load
pffi-shared-object-load
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer?
pffi-pointer-free
pffi-pointer-set!
pffi-pointer-get
pffi-string->pointer
pffi-pointer->string
pffi-define
pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
))
(racket
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(only (racket base) system-type)
(ffi winapi)
(compatibility mlist)
(ffi unsafe)
(ffi vector))
(export pffi-init
pffi-size-of
pffi-shared-object-auto-load
pffi-shared-object-load
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer?
pffi-pointer-free
pffi-pointer-set!
pffi-pointer-get
pffi-string->pointer
pffi-pointer->string
pffi-define
pffi-define-callback
pffi-pointer-address
pffi-pointer-dereference))
(sagittarius
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(sagittarius ffi)
(sagittarius))
(export pffi-init
pffi-size-of
pffi-shared-object-auto-load
pffi-shared-object-load
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer?
pffi-pointer-free
pffi-pointer-set!
pffi-pointer-get
pffi-string->pointer
pffi-pointer->string
pffi-define
pffi-define-callback
pffi-pointer-address
pffi-pointer-dereference))
(skint
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context))
(export pffi-init
;pffi-size-of
;pffi-shared-object-auto-load
;pffi-shared-object-load
;pffi-pointer-null
;pffi-pointer-null?
;pffi-pointer-allocate
;pffi-pointer?
;pffi-pointer-free
;pffi-pointer-set!
;pffi-pointer-get
;pffi-string->pointer
;pffi-pointer->string
;pffi-define
;pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
))
(stklos
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(stklos))
(export pffi-init
pffi-size-of
pffi-shared-object-auto-load
pffi-shared-object-load
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer?
pffi-pointer-free
;pffi-pointer-set!
;pffi-pointer-get
;pffi-string->pointer
;pffi-pointer->string
;pffi-define
;pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
))
(tr7
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context))
(export pffi-init
;pffi-size-of
;pffi-shared-object-auto-load
;pffi-shared-object-load
;pffi-pointer-null
;pffi-pointer-null?
;pffi-pointer-allocate
;pffi-pointer?
;pffi-pointer-free
;pffi-pointer-set!
;pffi-pointer-get
;pffi-string->pointer
;pffi-pointer->string
;pffi-define
;pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
))
(ypsilon
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context))
(export ;pffi-init
;pffi-size-of
;pffi-shared-object-auto-load
;pffi-shared-object-load
;pffi-pointer-null
;pffi-pointer-null?
;pffi-pointer-allocate
;pffi-pointer?
;pffi-pointer-free
;pffi-pointer-set!
;pffi-pointer-get
;pffi-string->pointer
;pffi-pointer->string
;pffi-define
;pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
))
(else (error "Unsupported implementation")))
(cond-expand
(chibi (include "r7rs-pffi/chibi.scm"))
(chicken (include "r7rs-pffi/chicken.scm"))
@ -154,7 +428,7 @@
(sagittarius (include "r7rs-pffi/sagittarius.scm"))
(skint (include "r7rs-pffi/skint.scm"))
(stklos (include "retropikzel/r7rs-pffi/stklos.scm"))
(tr7 (include "retropikzel/r7rs-pffi/tr7.scm"))
(tr7 (include "r7rs-pffi/tr7.scm"))
(ypsilon (include "r7rs-pffi/ypsilon.scm"))
(else #t))
(cond-expand

View File

@ -234,7 +234,7 @@
*p = double_value(value);
return_closcall1(data, k, make_boolean(boolean_t));")
#;(define-c pffi-pointer-pointer-set!
(define-c pffi-pointer-pointer-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"char* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = &opaque_ptr(value);

View File

@ -1 +1,27 @@
(require 'std-ffi)
(define pffi-init (lambda () #t))
;; FIXME
(define pffi-size-of
(lambda (type)
(cond ((eq? type 'int8) 1)
((eq? type 'uint8) 1)
((eq? type 'int16) 2)
((eq? type 'uint16) 2)
((eq? type 'int32) 4)
((eq? type 'uint32) 4)
((eq? type 'int64) 8)
((eq? type 'uint64) 8)
((eq? type 'char) 1)
((eq? type 'unsigned-char) 1)
((eq? type 'short) 2)
((eq? type 'unsigned-short) 2)
((eq? type 'int) 4)
((eq? type 'unsigned-int) 4)
((eq? type 'long) 4)
((eq? type 'unsigned-long) 4)
((eq? type 'float) 4)
((eq? type 'double) 8)
((eq? type 'pointer) 4)
(else (error "Can not get size of unknown type" type)))))

View File

@ -53,6 +53,7 @@
(pffi-init)
#|
;; pffi-size-of
(print-header 'pffi-size-of)
@ -139,34 +140,57 @@
(assert equal? (number? size-unsigned-int) #t)
(assert = size-unsigned-int 4)
(assert equal? (number? (pffi-size-of 'unsigned-int)) #t)
(define size-long (pffi-size-of 'long))
(debug size-long)
(assert equal? (number? size-long) #t)
(assert = size-long 8)
(cond-expand
(larceny ;; Works on 32 bit mode
(assert equal? (number? (pffi-size-of 'long)) #t)
(define size-long (pffi-size-of 'long))
(debug size-long)
(assert equal? (number? size-long) #t)
(assert = size-long 4))
(else
(assert equal? (number? (pffi-size-of 'long)) #t)
(define size-long (pffi-size-of 'long))
(debug size-long)
(assert equal? (number? size-long) #t)
(assert = size-long 8)))
(assert equal? (number? (pffi-size-of 'long)) #t)
(define size-unsigned-long (pffi-size-of 'unsigned-long))
(debug size-unsigned-long)
(assert equal? (number? size-unsigned-long) #t)
(assert = size-unsigned-long 8)
(cond-expand
(larceny ;; Works on 32 bit mode
(assert equal? (number? (pffi-size-of 'unsigned-long)) #t)
(define size-unsigned-long (pffi-size-of 'unsigned-long))
(debug size-unsigned-long)
(assert equal? (number? size-unsigned-long) #t)
(assert = size-unsigned-long 4))
(else
(assert equal? (number? (pffi-size-of 'long)) #t)
(define size-unsigned-long (pffi-size-of 'unsigned-long))
(debug size-unsigned-long)
(assert equal? (number? size-unsigned-long) #t)
(assert = size-unsigned-long 8)))
(assert equal? (number? (pffi-size-of 'unsigned-long)) #t)
(assert equal? (number? (pffi-size-of 'float)) #t)
(define size-float (pffi-size-of 'float))
(debug size-float)
(assert equal? (number? size-float) #t)
(assert = size-float 4)
(assert equal? (number? (pffi-size-of 'float)) #t)
(assert equal? (number? (pffi-size-of 'double)) #t)
(define size-double (pffi-size-of 'double))
(debug size-double)
(assert equal? (number? size-double) #t)
(assert = size-double 8)
(define size-pointer (pffi-size-of 'pointer))
(debug size-pointer)
(assert equal? (number? size-pointer) #t)
(assert = size-pointer 8)
(cond-expand
(larceny ;; Works on 32 bit mode
(define size-pointer (pffi-size-of 'pointer))
(debug size-pointer)
(assert equal? (number? size-pointer) #t)
(assert = size-pointer 4))
(else
(define size-pointer (pffi-size-of 'pointer))
(debug size-pointer)
(assert equal? (number? size-pointer) #t)
(assert = size-pointer 8)))
;; pffi-shared-object-auto-load
@ -179,7 +203,6 @@
(debug libc-stdlib)
#|
;; pffi-pointer-null
(print-header 'pffi-pointer-null)