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

Started mocing towards Chicken 6

This commit is contained in:
retropikzel 2025-04-13 08:08:26 +03:00
parent ded10bc0f1
commit 21027259f7
4 changed files with 33 additions and 301 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
README.md
View File

@ -36,7 +36,6 @@ conforming to some specification.
- [Gauche](#compiling-the-library-gauche) - [Gauche](#compiling-the-library-gauche)
- [Dependencies](#dependencies) - [Dependencies](#dependencies)
- [Chibi](#dependencies-chibi) - [Chibi](#dependencies-chibi)
- [Chicken](#dependencies-chicken)
- [Gauche](#dependencies-gauche) - [Gauche](#dependencies-gauche)
- [Racket](#dependencies-racket) - [Racket](#dependencies-racket)
- [Kawa](#dependencies-kawa) - [Kawa](#dependencies-kawa)
@ -123,7 +122,7 @@ For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?sear
| | pffi-init | pffi-size-of | pffi-define-library | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-address | pffi-pointer? | pffi-pointer-set! | pffi-pointer-get | pffi-define | pffi-define-callback | | | pffi-init | pffi-size-of | pffi-define-library | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-address | pffi-pointer? | pffi-pointer-set! | pffi-pointer-get | pffi-define | pffi-define-callback |
|--------------|:---------:|:------------:|:-------------------:|:-----------------:|:------------------:|:--------------------:|:-------------:|:-----------------:|:----------------:|:-----------:|:--------------------:| |--------------|:---------:|:------------:|:-------------------:|:-----------------:|:------------------:|:--------------------:|:-------------:|:-----------------:|:----------------:|:-----------:|:--------------------:|
| Chibi | X | X | X | X | X | X | X | X | X | X | | | Chibi | X | X | X | X | X | X | X | X | X | X | |
| Chicken-5 | X | X | X | X | X | X | X | X | X | X | X | | Chicken | X | X | X | X | X | X | X | X | X | X | X |
| Cyclone | X | X | X | X | X | | X | X | X | X | | | Cyclone | X | X | X | X | X | | X | X | X | X | |
| Gambit | X | X | | | | X | | | | | | | Gambit | X | X | | | | X | | | | | |
| Gauche | X | X | X | X | X | X | X | X | X | X | | | Gauche | X | X | X | X | X | X | X | X | X | X | |
@ -234,13 +233,6 @@ Debian/Ubuntu/Mint install with:
apt install libffi-dev apt install libffi-dev
#### Chicken
<a name="dependencies-chicken"></a>
Needs [r7rs egg](https://wiki.call-cc.org/eggref/5/r7rs), install with:
chicken-install r7rs
#### Gauche #### Gauche
<a name="dependencies-gauche"></a> <a name="dependencies-gauche"></a>

75
retropikzel/pffi.sld
View File

@ -10,23 +10,13 @@
(chibi ast) (chibi ast)
(chibi)) (chibi))
(include-shared "pffi/chibi-pffi")) (include-shared "pffi/chibi-pffi"))
(chicken-5 (chicken
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(chicken foreign)
(chicken locative)
(chicken syntax)
(chicken memory)
(chicken random)))
(chicken6
(import (scheme base) (import (scheme base)
(scheme write) (scheme write)
(scheme char) (scheme char)
(scheme file) (scheme file)
(scheme process-context) (scheme process-context)
(chicken base)
(chicken foreign) (chicken foreign)
(chicken locative) (chicken locative)
(chicken syntax) (chicken syntax)
@ -146,39 +136,38 @@
(only (core) define-macro syntax-case))) (only (core) define-macro syntax-case)))
(else (error "Unsupported implementation"))) (else (error "Unsupported implementation")))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type? pffi-type?
pffi-align-of pffi-align-of
pffi-define-library pffi-define-library
pffi-pointer-null pffi-pointer-null
pffi-pointer-null? pffi-pointer-null?
pffi-pointer-allocate pffi-pointer-allocate
pffi-pointer-address pffi-pointer-address
pffi-pointer? pffi-pointer?
pffi-pointer-free pffi-pointer-free
pffi-pointer-set! pffi-pointer-set!
pffi-pointer-get pffi-pointer-get
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-define-struct pffi-define-struct
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-struct-dereference pffi-struct-dereference
pffi-array-allocate pffi-array-allocate
pffi-array? pffi-array?
pffi-pointer->array pffi-pointer->array
pffi-array-get pffi-array-get
pffi-array-set! pffi-array-set!
pffi-list->array pffi-list->array
pffi-array->list pffi-array->list
pffi-define pffi-define
pffi-define-callback) pffi-define-callback)
(cond-expand (cond-expand
(chibi (include "pffi/chibi.scm")) (chibi (include "pffi/chibi.scm"))
(chicken-5 (include "pffi/chicken5.scm")) (chicken (include-relative "pffi/chicken.scm"))
(chicken-6 (include "chicken6.scm"))
(cyclone (include "pffi/cyclone.scm")) (cyclone (include "pffi/cyclone.scm"))
(gambit (include "pffi/gambit.scm")) (gambit (include "pffi/gambit.scm"))
(gauche (include "pffi/gauche.scm")) (gauche (include "pffi/gauche.scm"))

0
retropikzel/pffi/chicken5.scm → retropikzel/pffi/chicken.scm
View File

249
retropikzel/pffi/chicken6.scm
View File

@ -1,249 +0,0 @@
(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 '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 '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 '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 size-of-type
(lambda (type)
(cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int))
((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int))
((equal? type 'int16) (foreign-value "sizeof(int16_t)" int))
((equal? type 'uint16) (foreign-value "sizeof(uint16_t)" int))
((equal? type 'int32) (foreign-value "sizeof(int32_t)" int))
((equal? type 'uint32) (foreign-value "sizeof(uint32_t)" int))
((equal? type 'int64) (foreign-value "sizeof(int64_t)" int))
((equal? type 'uint64) (foreign-value "sizeof(uint64_t)" int))
((equal? type 'char) (foreign-value "sizeof(char)" int))
((equal? type 'unsigned-char) (foreign-value "sizeof(unsigned char)" int))
((equal? type 'short) (foreign-value "sizeof(short)" int))
((equal? type 'unsigned-short) (foreign-value "sizeof(unsigned short)" int))
((equal? type 'int) (foreign-value "sizeof(int)" int))
((equal? type 'unsigned-int) (foreign-value "sizeof(unsigned int)" int))
((equal? type 'long) (foreign-value "sizeof(long)" int))
((equal? type 'unsigned-long) (foreign-value "sizeof(unsigned long)" int))
((equal? type 'float) (foreign-value "sizeof(float)" int))
((equal? type 'double) (foreign-value "sizeof(double)" int))
((equal? type 'pointer) (foreign-value "sizeof(void*)" int))
(else #f)))))
(define pffi-pointer-allocate
(lambda (size)
(allocate size)))
(define pffi-pointer-address
(lambda (pointer)
(pointer->address pointer)))
(define pffi-pointer-dereference
(lambda (pointer)
(pointer->address pointer)))
(define pffi-pointer-null
(lambda ()
(address->pointer 0)))
;(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
;(pffi-define puts #f 'puts 'int (list 'pointer))
;(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
#;(define pffi-string->pointer
(lambda (string-content)
(let* ((size (string-length string-content))
(pointer (pffi-pointer-allocate (+ size 1))))
(memset pointer 0 (+ size 1))
(strncpy-ps pointer (location string-content) size)
;(puts pointer)
pointer)))
#;(define pffi-string->pointer
(foreign-lambda* c-pointer
((c-string str))
"C_return((void*)str);"))
;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
;(pffi-define strlen #f 'strlen 'int (list 'pointer))
#;(define pffi-pointer->string
(foreign-lambda* c-string
((c-pointer p))
"C_return((char*)p);"))
(define-syntax pffi-shared-object-load
(er-macro-transformer
(lambda (expr rename compare)
(let* ((headers (cdr (car (cdr expr)))))
`(begin
,@ (map
(lambda (header)
`(foreign-declare ,(string-append "#include <" header ">")))
headers))))))
(define pffi-pointer-free
(lambda (pointer)
(if (not (pointer? pointer))
(error "pffi-pointer-free -- Argument is not pointer" pointer))
(free pointer)))
(define pffi-pointer-null?
(lambda (pointer)
(if (and (not (pointer? pointer))
pointer)
#f
(or (not pointer) ; #f counts as null pointer on Chicken
(= (pointer->address pointer) 0)))))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond
((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value))
((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value))
((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value))
((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value))
((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value))
((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value))
((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value))
((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) (char->integer value)))
((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value))
((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value))
((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value))
((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value))
((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value))
((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value))
((equal? type 'float) (pointer-f32-set! (pointer+ pointer offset) value))
((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value))
((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value))))))
(define pffi-pointer-get
(lambda (pointer type offset)
(cond
((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset)))
((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset)))
((equal? type 'int16) (pointer-s16-ref (pointer+ pointer offset)))
((equal? type 'uint16) (pointer-u16-ref (pointer+ pointer offset)))
((equal? type 'int32) (pointer-s32-ref (pointer+ pointer offset)))
((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset)))
((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset)))
((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset)))
((equal? type 'char) (integer->char (pointer-s8-ref (pointer+ pointer offset))))
((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset)))
((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset)))
((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset)))
((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset)))
((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset)))
((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset)))
((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset)))
((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))))))