Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Backup

This commit is contained in:
retropikzel 2024-08-15 21:21:54 +03:00
parent bcc0c9293c
commit d6a86144e8
5 changed files with 50 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
README.md
View File

@ -21,20 +21,30 @@ Any help in form of constructive advice, bug reports, feature suggestions are ap
- Compiling of C code at any point
- That is no stubs, no C code generated by the library and so on
## All tests (there is not that many yet) pass
## Supported implementations
- [Sagittarius](https://bitbucket.org/ktakashi/sagittarius-scheme/wiki/Home)
- [Guile](https://www.gnu.org/software/guile/)
- [Racket](https://racket-lang.org/)
- [Chicken](https://www.call-cc.org/)
- [Gambit](https://gambitscheme.org)
## Supported excepts callbacks
### Callbacks not in FFI
These implementations do not have callback support on their FFI. If I'm wrong please let me know!
- [STKlos](https://stklos.net/)
- [Cyclone](https://justinethier.github.io/cyclone/)
### Callbacks not implemented yet
- [Kawa](https://www.gnu.org/software/kawa/index.html)
- Needs atleast java 21
- Needs jvm flags
- java --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED --enable-native-access=ALL-UNNAMED --enable-preview -jar kawa.jar FILENAME.scm
- [Racket](https://racket-lang.org/)
- [Chicken](https://www.call-cc.org/)
## Not all tests pass
- [Gambit](https://gambitscheme.org)
## Support waiting for the implementation
@ -50,6 +60,8 @@ Any help in form of constructive advice, bug reports, feature suggestions are ap
- [Gerbil](https://cons.io/)
- [Ypsilon](http://www.littlewingpinball.com/doc/en/ypsilon/)
- [Larceny](https://larcenists.org/)
- [Mosh](https://mosh.monaos.org)
- [Skint](https://github.com/false-schemers/skint)
## Support maybe possible/dreaming about
@ -57,10 +69,6 @@ Any help in form of constructive advice, bug reports, feature suggestions are ap
## Not supported
- [STKlos](https://stklos.net/)
- No callbacks in FFI
- [Cyclone](https://justinethier.github.io/cyclone/)
- No callbacks in FFI
- [Chibi](https://synthcode.com/scheme/chibi)
- FFI requires C code
- [MIT-Scheme](https://www.gnu.org/software/mit-scheme/)

28
retropikzel/r7rs-pffi/version/chicken.scm
View File

@ -202,18 +202,25 @@
(lambda ()
(address->pointer 0)))
(define pffi-string->pointer
(define pffi-string->pointer-old
(lambda (string-content)
(let* ((size (+ (string-length string-content) 1))
(pointer (pffi-pointer-allocate size)))
(move-memory! string-content pointer (- size 1) 0)
pointer)))
(define pffi-string->pointer
(lambda (string-content)
(location string-content)))
(pffi-define strlen #f 'strlen 'int (list 'pointer))
(define pffi-pointer->string
(lambda (pointer)
(write pointer)
(newline)
(cond ((string? pointer) pointer)
((locative? pointer) (locative->object pointer))
((pffi-pointer? pointer)
(let* ((size (strlen pointer))
(string-content (make-string size)))
@ -233,13 +240,15 @@
(define pffi-pointer-free
(lambda (pointer)
(when (pffi-pointer? pointer)
(free pointer))))
(if (not (pointer? pointer))
(error "pffi-pointer-free -- Argument is not pointer" pointer))
(free pointer)))
(define pffi-pointer-null?
(lambda (pointer)
(and (pffi-pointer? pointer)
(= (pointer->address pointer) 0))))
(if (not (pointer? pointer))
(error "pffi-pointer-null? -- Argument is not pointer" pointer))
(= (pointer->address pointer) 0)))
(define pffi-pointer-set!
(lambda (pointer type offset value)
@ -261,7 +270,8 @@
((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-s32-set! (pointer+ pointer offset) value)))))
((equal? type 'pointer) (pointer-s8-set! (pointer+ pointer offset) value))
((equal? type 'string) (pffi-pointer-set! pointer type offset (pffi-string->pointer value))))))
(define pffi-pointer-get
(lambda (pointer type offset)
@ -282,9 +292,9 @@
((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-s32-ref (pointer+ pointer offset)))
((equal? type 'string) (pffi-pointer->string (address->pointer (pffi-pointer-get pointer 'pointer offset)))))))
((equal? type 'double) (pointer-s8-ref (pointer+ pointer offset)))
((equal? type 'pointer) (pointer->address (pointer+ pointer offset)))
((equal? type 'string) (pffi-pointer->string (pffi-pointer-get pointer 'pointer offset))))))
(define pffi-pointer-deref
(lambda (pointer)

9
retropikzel/r7rs-pffi/version/cyclone.scm
View File

@ -20,7 +20,8 @@
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
pffi-pointer-deref
pffi-define-callback)
(begin
(define pffi-type->native-type
@ -142,4 +143,8 @@
(define pffi-pointer-deref
(lambda (pointer)
(error "Not defined")))))
(error "Not defined")))
(define pffi-define-callback
(lambda (scheme-name return-type argument-types procedure)
(error "pffi-define-callback not yet implemented on Cyclone")))))

5
retropikzel/r7rs-pffi/version/guile.scm
View File

@ -64,7 +64,7 @@
(define-syntax pffi-define-callback
(syntax-rules ()
((pffi-define scheme-name return-type argument-types procedure)
((pffi-define-callback scheme-name return-type argument-types procedure)
(define scheme-name
(procedure->pointer (pffi-type->native-type return-type)
procedure
@ -124,7 +124,8 @@
((equal? native-type unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
((equal? native-type float) (bytevector-ieee-single-set! p offset value (native-endianness)))
((equal? native-type double) (bytevector-ieee-double-set! p offset value (native-endianness)))
((equal? native-type '*) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (pffi-size-of type)))))))
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (pffi-size-of type)))
((equal? type 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer value)) (native-endianness) (pffi-size-of type)))))))
(define pffi-pointer-get
(lambda (pointer type offset)

3
retropikzel/r7rs-pffi/version/sagittarius.scm
View File

@ -142,7 +142,8 @@
((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))))))
((equal? type 'void*) (pointer-set-c-pointer! p offset value))
((equal? type 'pointer) (pointer-set-c-pointer! p offset value))))))
(define pffi-pointer-get
(lambda (pointer type offset)