Started mocing towards Chicken 6
This commit is contained in:
parent
ded10bc0f1
commit
21027259f7
10
README.md
10
README.md
|
|
@ -36,7 +36,6 @@ conforming to some specification.
|
|||
- [Gauche](#compiling-the-library-gauche)
|
||||
- [Dependencies](#dependencies)
|
||||
- [Chibi](#dependencies-chibi)
|
||||
- [Chicken](#dependencies-chicken)
|
||||
- [Gauche](#dependencies-gauche)
|
||||
- [Racket](#dependencies-racket)
|
||||
- [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 |
|
||||
|--------------|:---------:|:------------:|:-------------------:|:-----------------:|:------------------:|:--------------------:|:-------------:|:-----------------:|:----------------:|:-----------:|:--------------------:|
|
||||
| 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 | |
|
||||
| Gambit | 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
|
||||
|
||||
#### Chicken
|
||||
<a name="dependencies-chicken"></a>
|
||||
|
||||
Needs [r7rs egg](https://wiki.call-cc.org/eggref/5/r7rs), install with:
|
||||
|
||||
chicken-install r7rs
|
||||
|
||||
#### Gauche
|
||||
<a name="dependencies-gauche"></a>
|
||||
|
||||
|
|
|
|||
|
|
@ -10,23 +10,13 @@
|
|||
(chibi ast)
|
||||
(chibi))
|
||||
(include-shared "pffi/chibi-pffi"))
|
||||
(chicken-5
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(chicken foreign)
|
||||
(chicken locative)
|
||||
(chicken syntax)
|
||||
(chicken memory)
|
||||
(chicken random)))
|
||||
(chicken6
|
||||
(chicken
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(chicken base)
|
||||
(chicken foreign)
|
||||
(chicken locative)
|
||||
(chicken syntax)
|
||||
|
|
@ -146,39 +136,38 @@
|
|||
(only (core) define-macro syntax-case)))
|
||||
(else (error "Unsupported implementation")))
|
||||
(export pffi-init
|
||||
pffi-size-of
|
||||
pffi-type?
|
||||
pffi-align-of
|
||||
pffi-define-library
|
||||
pffi-pointer-null
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-address
|
||||
pffi-pointer?
|
||||
pffi-pointer-free
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-define-struct
|
||||
pffi-struct-pointer
|
||||
pffi-struct-offset-get
|
||||
pffi-struct-get
|
||||
pffi-struct-set!
|
||||
pffi-struct-dereference
|
||||
pffi-array-allocate
|
||||
pffi-array?
|
||||
pffi-pointer->array
|
||||
pffi-array-get
|
||||
pffi-array-set!
|
||||
pffi-list->array
|
||||
pffi-array->list
|
||||
pffi-define
|
||||
pffi-define-callback)
|
||||
pffi-size-of
|
||||
pffi-type?
|
||||
pffi-align-of
|
||||
pffi-define-library
|
||||
pffi-pointer-null
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer-address
|
||||
pffi-pointer?
|
||||
pffi-pointer-free
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-define-struct
|
||||
pffi-struct-pointer
|
||||
pffi-struct-offset-get
|
||||
pffi-struct-get
|
||||
pffi-struct-set!
|
||||
pffi-struct-dereference
|
||||
pffi-array-allocate
|
||||
pffi-array?
|
||||
pffi-pointer->array
|
||||
pffi-array-get
|
||||
pffi-array-set!
|
||||
pffi-list->array
|
||||
pffi-array->list
|
||||
pffi-define
|
||||
pffi-define-callback)
|
||||
(cond-expand
|
||||
(chibi (include "pffi/chibi.scm"))
|
||||
(chicken-5 (include "pffi/chicken5.scm"))
|
||||
(chicken-6 (include "chicken6.scm"))
|
||||
(chicken (include-relative "pffi/chicken.scm"))
|
||||
(cyclone (include "pffi/cyclone.scm"))
|
||||
(gambit (include "pffi/gambit.scm"))
|
||||
(gauche (include "pffi/gauche.scm"))
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
||||
Loading…
Reference in New Issue