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

Much more passing tests

This commit is contained in:
retropikzel 2025-04-30 20:32:04 +03:00
parent 872ce5d897
commit bbb652eda5
22 changed files with 723 additions and 708 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

213
'
View File

@ -1,213 +0,0 @@
(define size-of-type
(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 'pointer) (size-of-pointer))
((eq? type 'string) (size-of-pointer))
((eq? type 'struct) (size-of-pointer))
((eq? type 'callback) (size-of-pointer))
((eq? type 'void) 0)
(else #f))))
(define pffi-shared-object-load
(lambda (path options)
(let ((shared-object (dlopen path RTLD-NOW))
(maybe-error (dlerror)))
(when (not (pffi-pointer-null? maybe-error))
(error (pffi-pointer->string maybe-error)))
shared-object)))
#;(define pffi-pointer-null
(lambda ()
(pointer-null)))
#;(define pffi-pointer-null?
(lambda (pointer)
(not pointer))) ; #f is null on Chibi
(define pffi-pointer?
(lambda (object)
(or (equal? object #f) ; False can be null pointer
(pointer? object))))
(define pffi-pointer-allocate
(lambda (size)
(pointer-allocate size)))
(define pffi-pointer-address
(lambda (pointer)
(pointer-address pointer)))
(define pffi-pointer-free
(lambda (pointer)
(pointer-free pointer)))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value)))
((equal? type 'short) (pointer-set-c-short! pointer offset value))
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
((equal? type 'int) (pointer-set-c-int! pointer offset value))
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
((equal? type 'long) (pointer-set-c-long! pointer offset value))
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
((equal? type 'float) (pointer-set-c-float! pointer offset value))
((equal? type 'double) (pointer-set-c-double! pointer offset value))
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
(define pffi-pointer-get
(lambda (pointer type offset)
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset)))
((equal? type 'short) (pointer-ref-c-short pointer offset))
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
((equal? type 'int) (pointer-ref-c-int pointer offset))
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
((equal? type 'long) (pointer-ref-c-long pointer offset))
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
((equal? type 'float) (pointer-ref-c-float pointer offset))
((equal? type 'double) (pointer-ref-c-double pointer offset))
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
#;(define pffi-string->pointer
(lambda (string-content)
(string-to-pointer string-content)))
#;(define pffi-pointer->string
(lambda (pointer)
(pointer-to-string pointer)))
(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) '(maybe-null void*))
((equal? type 'string) 'string)
((equal? type 'void) 'void)
((equal? type 'callback) '(maybe-null void*))
(else (error "pffi-type->native-type -- No such pffi type" type)))))
;; pffi-define-function
(define pffi-type->libffi-type
(lambda (type)
(cond ((equal? type 'int8) (get-ffi-type-int8))
((equal? type 'uint8) (get-ffi-type-uint8))
((equal? type 'int16) (get-ffi-type-int16))
((equal? type 'uint16) (get-ffi-type-uint16))
((equal? type 'int32) (get-ffi-type-int32))
((equal? type 'uint32) (get-ffi-type-uint32))
((equal? type 'int64) (get-ffi-type-int64))
((equal? type 'uint64) (get-ffi-type-uint64))
((equal? type 'char) (get-ffi-type-char))
((equal? type 'unsigned-char) (get-ffi-type-uchar))
((equal? type 'bool) (get-ffi-type-int8))
((equal? type 'short) (get-ffi-type-short))
((equal? type 'unsigned-short) (get-ffi-type-ushort))
((equal? type 'int) (get-ffi-type-int))
((equal? type 'unsigned-int) (get-ffi-type-uint))
((equal? type 'long) (get-ffi-type-long))
((equal? type 'unsigned-long) (get-ffi-type-ulong))
((equal? type 'float) (get-ffi-type-float))
((equal? type 'double) (get-ffi-type-double))
((equal? type 'void) (get-ffi-type-void))
((equal? type 'pointer) (get-ffi-type-pointer))
((equal? type 'callback) (get-ffi-type-pointer)))))
(define argument->pointer
(lambda (value type)
(cond ((procedure? value) (scheme-procedure-to-pointer value))
(else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
(pffi-pointer-set! pointer type 0 value)
pointer)))))
(define make-c-function
(lambda (shared-object c-name return-type argument-types)
(dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror)))
(when (not (pffi-pointer-null? maybe-dlerror))
(error (pffi-pointer->string maybe-dlerror)))
(lambda arguments
(let ((return-value (pffi-pointer-allocate
(if (equal? return-type 'void)
0
(size-of-type return-type)))))
(internal-ffi-call (length argument-types)
(pffi-type->libffi-type return-type)
(map pffi-type->libffi-type argument-types)
c-function
return-value
(map argument->pointer
arguments
argument-types))
(cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0))))))))
(define-syntax pffi-define-function
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-c-function shared-object
(symbol->string c-name)
return-type
argument-types)))))
(define make-c-callback
(lambda (return-type argument-types procedure)
(scheme-procedure-to-pointer procedure)))
(define-syntax pffi-define-callback
(syntax-rules ()
((_ scheme-name return-type argument-types procedure)
(define scheme-name
(make-c-callback return-type 'argument-types procedure)))))

0
ODL_README.md → OLD_README.md
View File

65
README.md
View File

@ -13,33 +13,48 @@ The new readme is a work in progress.
## Implementation table ## Implementation table
## Primitives ## Primitives 1
| | c-size-of | c-bytevector-u8-set! |c-bytevector-u8-ref | define-c-library | c-bytevector? | define-c-procedure | define-c-callback | | | c-size-of | c-bytevector-u8-set! |c-bytevector-u8-ref | define-c-library | c-bytevector? | define-c-procedure |
|------------------|:------------:|:------------------- :|-------------------:|:-------------------:|:-------------:|:-------------------:|:-----------------:| |------------------|:------------:|:------------------- :|-------------------:|:-------------------:|:-------------:|:-------------------:|
| Chibi | X | X |X | X | X | X | | | **Chibi** | X | X |X | X | X | X |
| **Chicken** | X | X |X | X | X | X | X | | **Chicken** | X | X |X | X | X | X |
| Gauche | X | X |X | X | X | X | | | **Gauche** | X | X |X | X | X | X |
| **Guile** | X | X |X | X | X | X | X | | **Guile** | X | X |X | X | X | X |
| Kawa | X | X |X | X | X | X | | | **Kawa** | X | X |X | X | X | X |
| **Mosh** | X | X |X | X | X | X | X | | **Mosh** | X | X |X | X | X | X |
| **Racket** | X | X |X | X | X | X | X | | **Racket** | X | X |X | X | X | X |
| **Saggittarius** | X | X |X | X | X | X | X | | **Saggittarius** | X | X |X | X | X | X |
| Stklos | X | X |X | X | X | X | | | **Stklos** | X | X |X | X | X | X |
| **Ypsilon** | X | X |X | X | X | X | X | | **Ypsilon** | X | X |X | X | X | X |
## Primitives 2
| | define-c-callback |
|------------------|:-----------------:|
| Chibi | |
| **Chicken** | X |
| Gauche | |
| **Guile** | X |
| Kawa | |
| **Mosh** | X |
| **Racket** | X |
| **Saggittarius** | X |
| Stklos | |
| **Ypsilon** | X |
## Test files pass ## Test files pass
| | primitives.scm | addressof.scm | | | primitives.scm | addressof.scm | callback.scm |
|------------------|:--------------:|:-------------:| |------------------|:--------------:|:-------------:|-------------:|
| Chibi | | | | Chibi | X | X | |
| **Chicken** | X | X | | **Chicken** | X | X | X |
| Gauche | | | | Gauche | X | X | |
| **Guile** | X | X | | **Guile** | X | X | X |
| Kawa | | | | Kawa | X | X | |
| Mosh | X | | | Mosh | X | X | |
| Racket | X | | | Racket | X | | |
| **Saggittarius** | X | X | | **Saggittarius** | X | X | X |
| Stklos | | X | | Stklos | X | X | |
| Ypsilon | X | | | Ypsilon | X | X | |

43
foreign/c.sld
View File

@ -66,7 +66,10 @@
(scheme process-context) (scheme process-context)
(system foreign) (system foreign)
(system foreign-library) (system foreign-library)
(only (guile) include-from-path))) (only (guile) include-from-path)
(only (rnrs bytevectors)
bytevector-uint-set!
bytevector-uint-ref)))
(kawa (kawa
(import (scheme base) (import (scheme base)
(scheme write) (scheme write)
@ -133,12 +136,15 @@
(scheme process-context) (scheme process-context)
(only (stklos) (only (stklos)
%make-callback %make-callback
make-external-function
allocate-bytes allocate-bytes
free-bytes free-bytes
cpointer? cpointer?
cpointer-null? cpointer-null?
cpointer-data cpointer-data
cpointer-data-set! cpointer-data-set!
;c-bytevector-s8-set!
;c-bytevector-s8-set!
pointer-set-c-int8_t! pointer-set-c-int8_t!
pointer-ref-c-int8_t pointer-ref-c-int8_t
pointer-set-c-uint8_t! pointer-set-c-uint8_t!
@ -178,6 +184,9 @@
void?)) void?))
(export ; calculate-struct-size-and-offsets (export ; calculate-struct-size-and-offsets
;struct-make ;struct-make
get-environment-variable
file-exists?
make-external-function
foreign-c:string-split foreign-c:string-split
c-bytevector-pointer-set! c-bytevector-pointer-set!
c-bytevector-pointer-ref)) c-bytevector-pointer-ref))
@ -204,39 +213,41 @@
define-c-procedure define-c-procedure
define-c-callback define-c-callback
c-bytevector? c-bytevector?
c-bytevector-u8-set!
c-bytevector-u8-ref c-bytevector-u8-ref
c-bytevector-pointer-set!
c-bytevector-pointer-ref
;; c-bytevector ;; c-bytevector
native-endianness native-endianness
;; TODO Docs for all of these ;; TODO Docs for all of these
c-bytevector->address ;c-bytevector->address
address->c-bytevector ;address->c-bytevector
c-bytevector-s8-set! ;c-bytevector-s8-set!
c-bytevector-s8-ref ;c-bytevector-s8-ref
c-bytevector-u8-set!
c-bytevector-s16-set! c-bytevector-s16-set!
c-bytevector-s16-native-set!
c-bytevector-s16-ref c-bytevector-s16-ref
c-bytevector-s16-native-set!
c-bytevector-s16-native-ref c-bytevector-s16-native-ref
c-bytevector-u16-set! c-bytevector-u16-set!
c-bytevector-u16-native-set!
c-bytevector-u16-ref c-bytevector-u16-ref
c-bytevector-u16-native-set!
c-bytevector-u16-native-ref c-bytevector-u16-native-ref
c-bytevector-s32-set! c-bytevector-s32-set!
c-bytevector-s32-native-set!
c-bytevector-s32-ref c-bytevector-s32-ref
c-bytevector-s32-native-set!
c-bytevector-s32-native-ref c-bytevector-s32-native-ref
c-bytevector-u32-set! c-bytevector-u32-set!
c-bytevector-u32-native-set!
c-bytevector-u32-ref c-bytevector-u32-ref
c-bytevector-u32-native-set!
c-bytevector-u32-native-ref c-bytevector-u32-native-ref
c-bytevector-s64-set! c-bytevector-s64-set!
c-bytevector-s64-native-set!
c-bytevector-s64-ref c-bytevector-s64-ref
c-bytevector-s64-native-set!
c-bytevector-s64-native-ref c-bytevector-s64-native-ref
c-bytevector-u64-set! c-bytevector-u64-set!
c-bytevector-u64-native-set!
c-bytevector-u64-ref c-bytevector-u64-ref
c-bytevector-u64-native-set!
c-bytevector-u64-native-ref c-bytevector-u64-native-ref
c-bytevector-sint-set! c-bytevector-sint-set!
c-bytevector-sint-ref c-bytevector-sint-ref
@ -290,8 +301,10 @@
;define-c-variable (?) ;define-c-variable (?)
) )
(cond-expand (cond-expand
(chicken-6 (include-relative "c/types.scm")) (chicken-6 (include-relative "c/types.scm")
(else (include "c/types.scm"))) (include-relative "c/c-bytevector-get.scm"))
(else (include "c/types.scm")
(include "c/c-bytevector-get.scm")))
(cond-expand (cond-expand
(chibi (include "c/primitives/chibi.scm")) (chibi (include "c/primitives/chibi.scm"))
(chicken-5 (export foreign-declare (chicken-5 (export foreign-declare
@ -301,7 +314,7 @@
(chicken-6 (include-relative "c/primitives/chicken.scm")) (chicken-6 (include-relative "c/primitives/chicken.scm"))
;(cyclone (include "c/primitives/cyclone.scm")) ;(cyclone (include "c/primitives/cyclone.scm"))
;(gambit (include "c/primitives/gambit.scm")) ;(gambit (include "c/primitives/gambit.scm"))
(gauche (include "c/primitives/gauche.scm")) (gauche (include "c/primitives/gauche/define-c-procedure.scm"))
;(gerbil (include "c/primitives/gerbil.scm")) ;(gerbil (include "c/primitives/gerbil.scm"))
(guile (include "c/primitives/guile.scm")) (guile (include "c/primitives/guile.scm"))
(kawa (include "c/primitives/kawa.scm")) (kawa (include "c/primitives/kawa.scm"))

24
foreign/c/c-bytevector-get.scm Normal file
View File

@ -0,0 +1,24 @@
(define c-bytevector-get
(lambda (pointer type offset)
(cond ((equal? type 'int8) (c-bytevector-s8-ref pointer offset))
((equal? type 'uint8) (c-bytevector-u8-ref pointer offset))
((equal? type 'int16) (c-bytevector-s16-ref pointer offset))
((equal? type 'uint16) (c-bytevector-u16-ref pointer offset))
((equal? type 'int32) (c-bytevector-s32-ref pointer offset))
((equal? type 'uint32) (c-bytevector-u32-ref pointer offset))
((equal? type 'int64) (c-bytevector-s64-ref pointer offset))
((equal? type 'uint64) (c-bytevector-u64-ref pointer offset))
((equal? type 'char) (integer->char (c-bytevector-s8-ref pointer offset)))
((equal? type 'unsigned-char) (integer->char (c-bytevector-u8-ref pointer offset)))
((equal? type 'short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-size-of 'short)))
((equal? type 'unsigned-short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-size-of 'unsigned-short)))
((equal? type 'int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-size-of 'int)))
((equal? type 'unsigned-int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-size-of 'unsigned-int)))
((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-size-of 'long)))
((equal? type 'unsigned-long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-size-of 'unsigned-long)))
((equal? type 'float) (c-bytevector-ieee-single-native-ref pointer offset))
((equal? type 'double) (c-bytevector-ieee-double-native-ref pointer offset))
((equal? type 'pointer) (c-bytevector-pointer-ref pointer offset))
((not (equal? type 'void)) (error "No such foreign type" type))
;; Return unspecified on purpose if type is void
)))

19
foreign/c/pointer.scm
View File

@ -11,8 +11,8 @@
(define-c-procedure c-calloc libc 'calloc 'pointer '(int int)) (define-c-procedure c-calloc libc 'calloc 'pointer '(int int))
(define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int)) (define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int))
(define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int)) (define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int))
(define-c-procedure c-memset-address libc 'memset 'pointer '(uint64 uint8 int)) ;(define-c-procedure c-memset-address libc 'memset 'pointer '(uint64 uint8 int))
(define-c-procedure c-printf libc 'printf 'int '(pointer pointer)) ;(define-c-procedure c-printf libc 'printf 'int '(pointer pointer))
(define-c-procedure c-malloc libc 'malloc 'pointer '(int)) (define-c-procedure c-malloc libc 'malloc 'pointer '(int))
(define-c-procedure c-strlen libc 'strlen 'int '(pointer)) (define-c-procedure c-strlen libc 'strlen 'int '(pointer))
@ -86,15 +86,15 @@
(= (c-memset-pointer->address pointer 0 0) 0) (= (c-memset-pointer->address pointer 0 0) 0)
#f))))) #f)))))
(define c-bytevector->address #;(define c-bytevector->address
(lambda (c-bytevector) (lambda (c-bytevector)
(c-memset-pointer->address c-bytevector 0 0))) (c-memset-pointer->address c-bytevector 0 0)))
(define address->c-bytevector #;(define address->c-bytevector
(lambda (address) (lambda (address)
(c-memset-address->pointer address 0 0))) (c-memset-address->pointer address 0 0)))
(define c-bytevector-pointer-set! #;(define c-bytevector-pointer-set!
(lambda (c-bytevector k pointer) (lambda (c-bytevector k pointer)
(c-bytevector-uint-set! c-bytevector (c-bytevector-uint-set! c-bytevector
0 0
@ -102,7 +102,7 @@
(native-endianness) (native-endianness)
(c-size-of 'pointer)))) (c-size-of 'pointer))))
(define c-bytevector-pointer-ref #;(define c-bytevector-pointer-ref
(lambda (c-bytevector k) (lambda (c-bytevector k)
(address->c-bytevector (c-bytevector-uint-ref c-bytevector (address->c-bytevector (c-bytevector-uint-ref c-bytevector
0 0
@ -116,6 +116,7 @@
((_ input-pointer thunk) ((_ input-pointer thunk)
(let ((address-pointer (make-c-bytevector (c-size-of 'pointer)))) (let ((address-pointer (make-c-bytevector (c-size-of 'pointer))))
(c-bytevector-pointer-set! address-pointer 0 input-pointer) (c-bytevector-pointer-set! address-pointer 0 input-pointer)
(apply thunk (list address-pointer)) (let ((result (apply thunk (list address-pointer))))
(set! input-pointer (c-bytevector-pointer-ref address-pointer 0)) (set! input-pointer (c-bytevector-pointer-ref address-pointer 0))
(c-free address-pointer))))))) (c-free address-pointer)
result)))))))

11
foreign/c/primitives/chibi.scm
View File

@ -39,10 +39,10 @@
(lambda (pointer) (lambda (pointer)
(pointer-free pointer))) (pointer-free pointer)))
(define c-bytevector-u8-set! pointer-set-c-uint8_t!) ;(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
(define c-bytevector-u8-ref pointer-ref-c-uint8_t) ;(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
(define pointer-set! #;(define pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value)) (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value)) ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
@ -64,7 +64,7 @@
((equal? type 'void) (pointer-set-c-pointer! pointer offset value)) ((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
(define pointer-get #;(define pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset)) (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset)) ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
@ -186,8 +186,7 @@
c-function c-function
(c-size-of return-type) (c-size-of return-type)
arguments))) arguments)))
(when (not (equal? return-type 'void)) (c-bytevector-get return-pointer return-type 0))))))
(pointer-get return-pointer return-type 0)))))))
(define-syntax define-c-procedure (define-syntax define-c-procedure
(syntax-rules () (syntax-rules ()

469
foreign/c/primitives/chibi/foreign-c.stub
View File

@ -53,189 +53,195 @@
(define-c (maybe-null pointer void*) dlopen (string int)) (define-c (maybe-null pointer void*) dlopen (string int))
(define-c (maybe-null pointer void*) dlerror ()) (define-c (maybe-null pointer void*) dlerror ())
(c-declare "void* pointer_null() { return NULL; }") ;(c-declare "void* pointer_null() { return NULL; }")
(define-c (pointer void*) (pointer-null pointer_null) ()) ;(define-c (pointer void*) (pointer-null pointer_null) ())
(c-declare "int is_pointer_null(void* pointer) { if(pointer == NULL) { return 1; } else { return 0; }; }") ;(c-declare "int is_pointer_null(void* pointer) { if(pointer == NULL) { return 1; } else { return 0; }; }")
(define-c bool (is-pointer-null is_pointer_null) ((maybe-null pointer void*))) ;(define-c bool (is-pointer-null is_pointer_null) ((maybe-null pointer void*)))
(c-declare "void* pointer_allocate(int size) { return malloc(size); }") ;(c-declare "void* pointer_allocate(int size) { return malloc(size); }")
(define-c (maybe-null pointer void*) (pointer-allocate pointer_allocate) (int)) ;(define-c (maybe-null pointer void*) (pointer-allocate pointer_allocate) (int))
(c-declare "sexp is_pointer(struct sexp_struct* object) { (c-declare "sexp is_pointer(struct sexp_struct* object) { if(sexp_cpointerp(object)) { return SEXP_TRUE; } else { return SEXP_FALSE; } }")
if(sexp_cpointerp(object)) {
return SEXP_TRUE;
} else {
return SEXP_FALSE;
}
}")
(define-c sexp (pointer? is_pointer) (sexp)) (define-c sexp (pointer? is_pointer) (sexp))
(c-declare "void* pointer_address(struct sexp_struct* pointer) { (c-declare "void c_bytevector_u8_set(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }")
(define-c void (c-bytevector-u8-set! c_bytevector_u8_set) ((pointer void*) int uint8_t))
(c-declare "int8_t c_bytevector_u8_ref (void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }")
(define-c int8_t (c-bytevector-u8-ref c_bytevector_u8_ref) ((pointer void*) int))
(c-declare "void c_bytevector_pointer_set (void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }")
(define-c void (c-bytevector-pointer-set! c_bytevector_pointer_set) ((pointer void*) int (maybe-null pointer void*)))
(c-declare "void* c_bytevector_pointer_ref (void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }")
(define-c (maybe-null pointer void*) (c-bytevector-pointer-ref c_bytevector_pointer_ref) ((pointer void*) int))
#;(c-declare "void* pointer_address(struct sexp_struct* pointer) {
return &sexp_cpointer_value(pointer); return &sexp_cpointer_value(pointer);
}") }")
(define-c (maybe-null pointer void*) (pointer-address pointer_address) (sexp)) ;(define-c (maybe-null pointer void*) (pointer-address pointer_address) (sexp))
(c-declare "void pointer_free(void* pointer) { free(pointer); }") ;(c-declare "void pointer_free(void* pointer) { free(pointer); }")
(define-c void (pointer-free pointer_free) ((maybe-null pointer void*))) ;(define-c void (pointer-free pointer_free) ((maybe-null pointer void*)))
;; pointer-set! ;; pointer-set!
(c-declare "void pointer_set_c_int8_t(void* pointer, int offset, int8_t value) { *(int8_t*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_int8_t(void* pointer, int offset, int8_t value) { *(int8_t*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-int8_t! pointer_set_c_int8_t) ((pointer void*) int int8_t)) ;(define-c void (pointer-set-c-int8_t! pointer_set_c_int8_t) ((pointer void*) int int8_t))
(c-declare "void pointer_set_c_uint8_t(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_uint8_t(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-uint8_t! pointer_set_c_uint8_t) ((pointer void*) int uint8_t)) ;(define-c void (pointer-set-c-uint8_t! pointer_set_c_uint8_t) ((pointer void*) int uint8_t))
;
(c-declare "void pointer_set_c_int16_t(void* pointer, int offset, int16_t value) { *(int16_t*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_int16_t(void* pointer, int offset, int16_t value) { *(int16_t*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-int16_t! pointer_set_c_int16_t) ((pointer void*) int int16_t)) ;(define-c void (pointer-set-c-int16_t! pointer_set_c_int16_t) ((pointer void*) int int16_t))
(c-declare "void pointer_set_c_uint16_t(void* pointer, int offset, uint16_t value) { *(uint16_t*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_uint16_t(void* pointer, int offset, uint16_t value) { *(uint16_t*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-uint16_t! pointer_set_c_uint16_t) ((pointer void*) int uint16_t)) ;(define-c void (pointer-set-c-uint16_t! pointer_set_c_uint16_t) ((pointer void*) int uint16_t))
;
(c-declare "void pointer_set_c_int32_t(void* pointer, int offset, int32_t value) { *(int32_t*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_int32_t(void* pointer, int offset, int32_t value) { *(int32_t*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-int32_t! pointer_set_c_int32_t) ((pointer void*) int int32_t)) ;(define-c void (pointer-set-c-int32_t! pointer_set_c_int32_t) ((pointer void*) int int32_t))
(c-declare "void pointer_set_c_uint32_t(void* pointer, int offset, uint32_t value) { *(uint32_t*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_uint32_t(void* pointer, int offset, uint32_t value) { *(uint32_t*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-uint32_t! pointer_set_c_uint32_t) ((pointer void*) int uint32_t)) ;(define-c void (pointer-set-c-uint32_t! pointer_set_c_uint32_t) ((pointer void*) int uint32_t))
;
(c-declare "void pointer_set_c_int64_t(void* pointer, int offset, int64_t value) { *(int64_t*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_int64_t(void* pointer, int offset, int64_t value) { *(int64_t*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-int64_t! pointer_set_c_int64_t) ((pointer void*) int int64_t)) ;(define-c void (pointer-set-c-int64_t! pointer_set_c_int64_t) ((pointer void*) int int64_t))
(c-declare "void pointer_set_c_uint64_t(void* pointer, int offset, uint64_t value) { *(uint64_t*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_uint64_t(void* pointer, int offset, uint64_t value) { *(uint64_t*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-uint64_t! pointer_set_c_uint64_t) ((pointer void*) int uint64_t)) ;(define-c void (pointer-set-c-uint64_t! pointer_set_c_uint64_t) ((pointer void*) int uint64_t))
;
(c-declare "void pointer_set_c_char(void* pointer, int offset, int8_t value) { *((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_char(void* pointer, int offset, int8_t value) { *((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int int8_t)) ;(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int int8_t))
(c-declare "void pointer_set_c_unsigned_char(void* pointer, int offset, unsigned char value) { *(unsigned char*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_unsigned_char(void* pointer, int offset, unsigned char value) { *(unsigned char*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-unsigned-char! pointer_set_c_unsigned_char) ((pointer void*) int unsigned-char)) ;(define-c void (pointer-set-c-unsigned-char! pointer_set_c_unsigned_char) ((pointer void*) int unsigned-char))
;
(c-declare "void pointer_set_c_short(void* pointer, int offset, short value) { *(short*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_short(void* pointer, int offset, short value) { *(short*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-short! pointer_set_c_short) ((pointer void*) int short)) ;(define-c void (pointer-set-c-short! pointer_set_c_short) ((pointer void*) int short))
(c-declare "void pointer_set_c_unsigned_short(void* pointer, int offset, unsigned short value) { *(unsigned short*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_unsigned_short(void* pointer, int offset, unsigned short value) { *(unsigned short*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-unsigned-short! pointer_set_c_unsigned_short) ((pointer void*) int unsigned-short)) ;(define-c void (pointer-set-c-unsigned-short! pointer_set_c_unsigned_short) ((pointer void*) int unsigned-short))
;
(c-declare "void pointer_set_c_int(void* pointer, int offset, int value) { *(int*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_int(void* pointer, int offset, int value) { *(int*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-int! pointer_set_c_int) ((pointer void*) int int)) ;(define-c void (pointer-set-c-int! pointer_set_c_int) ((pointer void*) int int))
(c-declare "void pointer_set_c_unsigned_int(void* pointer, int offset, unsigned int value) { *(unsigned int*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_unsigned_int(void* pointer, int offset, unsigned int value) { *(unsigned int*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-unsigned-int! pointer_set_c_unsigned_int) ((pointer void*) int unsigned-int)) ;(define-c void (pointer-set-c-unsigned-int! pointer_set_c_unsigned_int) ((pointer void*) int unsigned-int))
;
(c-declare "void pointer_set_c_long(void* pointer, int offset, long value) { *(long*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_long(void* pointer, int offset, long value) { *(long*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-long! pointer_set_c_long) ((pointer void*) int long)) ;(define-c void (pointer-set-c-long! pointer_set_c_long) ((pointer void*) int long))
(c-declare "void pointer_set_c_unsigned_long(void* pointer, int offset, unsigned long value) { *(unsigned long*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_unsigned_long(void* pointer, int offset, unsigned long value) { *(unsigned long*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-unsigned-long! pointer_set_c_unsigned_long) ((pointer void*) int unsigned-long)) ;(define-c void (pointer-set-c-unsigned-long! pointer_set_c_unsigned_long) ((pointer void*) int unsigned-long))
;
(c-declare "void pointer_set_c_float(void* pointer, int offset, float value) { *(float*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_float(void* pointer, int offset, float value) { *(float*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-float! pointer_set_c_float) ((pointer void*) int float)) ;(define-c void (pointer-set-c-float! pointer_set_c_float) ((pointer void*) int float))
;
(c-declare "void pointer_set_c_double(void* pointer, int offset, double value) { *(double*)((char*)pointer + offset) = value; }") ;(c-declare "void pointer_set_c_double(void* pointer, int offset, double value) { *(double*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-double! pointer_set_c_double) ((pointer void*) int double)) ;(define-c void (pointer-set-c-double! pointer_set_c_double) ((pointer void*) int double))
;
(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }") ;(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }")
(define-c void (pointer-set-c-pointer! pointer_set_c_pointer) ((pointer void*) int (maybe-null pointer void*))) ;(define-c void (pointer-set-c-pointer! pointer_set_c_pointer) ((pointer void*) int (maybe-null pointer void*)))
;
;; pointer-get ;;; pointer-get
(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }") ;(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }")
(define-c int8_t (pointer-ref-c-int8_t pointer_ref_c_int8_t) ((pointer void*) int)) ;(define-c int8_t (pointer-ref-c-int8_t pointer_ref_c_int8_t) ((pointer void*) int))
(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { return *(uint8_t*)((char*)pointer + offset); }") ;(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { return *(uint8_t*)((char*)pointer + offset); }")
(define-c uint8_t (pointer-ref-c-uint8_t pointer_ref_c_uint8_t) ((pointer void*) int)) ;(define-c uint8_t (pointer-ref-c-uint8_t pointer_ref_c_uint8_t) ((pointer void*) int))
;
(c-declare "int16_t pointer_ref_c_int16_t(void* pointer, int offset) { return *(int16_t*)((char*)pointer + offset); }") ;(c-declare "int16_t pointer_ref_c_int16_t(void* pointer, int offset) { return *(int16_t*)((char*)pointer + offset); }")
(define-c int16_t (pointer-ref-c-int16_t pointer_ref_c_int16_t) ((pointer void*) int)) ;(define-c int16_t (pointer-ref-c-int16_t pointer_ref_c_int16_t) ((pointer void*) int))
(c-declare "uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { return *(uint16_t*)((char*)pointer + offset); }") ;(c-declare "uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { return *(uint16_t*)((char*)pointer + offset); }")
(define-c uint16_t (pointer-ref-c-uint16_t pointer_ref_c_uint16_t) ((pointer void*) int)) ;(define-c uint16_t (pointer-ref-c-uint16_t pointer_ref_c_uint16_t) ((pointer void*) int))
;
(c-declare "int32_t pointer_ref_c_int32_t(void* pointer, int offset) { return *(int32_t*)((char*)pointer + offset); }") ;(c-declare "int32_t pointer_ref_c_int32_t(void* pointer, int offset) { return *(int32_t*)((char*)pointer + offset); }")
(define-c int32_t (pointer-ref-c-int32_t pointer_ref_c_int32_t) ((pointer void*) int)) ;(define-c int32_t (pointer-ref-c-int32_t pointer_ref_c_int32_t) ((pointer void*) int))
(c-declare "uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { return *(uint32_t*)((char*)pointer + offset); }") ;(c-declare "uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { return *(uint32_t*)((char*)pointer + offset); }")
(define-c uint32_t (pointer-ref-c-uint32_t pointer_ref_c_uint32_t) ((pointer void*) int)) ;(define-c uint32_t (pointer-ref-c-uint32_t pointer_ref_c_uint32_t) ((pointer void*) int))
;
(c-declare "int64_t pointer_ref_c_int64_t(void* pointer, int offset) { return *(int64_t*)((char*)pointer + offset); }") ;(c-declare "int64_t pointer_ref_c_int64_t(void* pointer, int offset) { return *(int64_t*)((char*)pointer + offset); }")
(define-c int64_t (pointer-ref-c-int64_t pointer_ref_c_int64_t) ((pointer void*) int)) ;(define-c int64_t (pointer-ref-c-int64_t pointer_ref_c_int64_t) ((pointer void*) int))
(c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { return *(uint64_t*)((char*)pointer + offset); }") ;(c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { return *(uint64_t*)((char*)pointer + offset); }")
(define-c uint64_t (pointer-ref-c-uint64_t pointer_ref_c_uint64_t) ((pointer void*) int)) ;(define-c uint64_t (pointer-ref-c-uint64_t pointer_ref_c_uint64_t) ((pointer void*) int))
;
(c-declare "int8_t pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); }") ;(c-declare "int8_t pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); }")
(define-c int8_t (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int)) ;(define-c int8_t (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int))
(c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { return *(unsigned char*)((char*)pointer + offset); }") ;(c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { return *(unsigned char*)((char*)pointer + offset); }")
(define-c unsigned-char (pointer-ref-c-unsigned-char pointer_ref_c_unsigned_char) ((pointer void*) int)) ;(define-c unsigned-char (pointer-ref-c-unsigned-char pointer_ref_c_unsigned_char) ((pointer void*) int))
;
(c-declare "short pointer_ref_c_short(void* pointer, int offset) { return *(short*)((char*)pointer + offset); }") ;(c-declare "short pointer_ref_c_short(void* pointer, int offset) { return *(short*)((char*)pointer + offset); }")
(define-c short (pointer-ref-c-short pointer_ref_c_short) ((pointer void*) int)) ;(define-c short (pointer-ref-c-short pointer_ref_c_short) ((pointer void*) int))
(c-declare "unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { return *(unsigned short*)((char*)pointer + offset); }") ;(c-declare "unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { return *(unsigned short*)((char*)pointer + offset); }")
(define-c unsigned-short (pointer-ref-c-unsigned-short pointer_ref_c_unsigned_short) ((pointer void*) int)) ;(define-c unsigned-short (pointer-ref-c-unsigned-short pointer_ref_c_unsigned_short) ((pointer void*) int))
;
(c-declare "int pointer_ref_c_int(void* pointer, int offset) { return *(int*)((char*)pointer + offset); }") ;(c-declare "int pointer_ref_c_int(void* pointer, int offset) { return *(int*)((char*)pointer + offset); }")
(define-c int (pointer-ref-c-int pointer_ref_c_int) ((pointer void*) int)) ;(define-c int (pointer-ref-c-int pointer_ref_c_int) ((pointer void*) int))
(c-declare "unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { return *(unsigned int*)((char*)pointer + offset); }") ;(c-declare "unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { return *(unsigned int*)((char*)pointer + offset); }")
(define-c unsigned-int (pointer-ref-c-unsigned-int pointer_ref_c_unsigned_int) ((pointer void*) int)) ;(define-c unsigned-int (pointer-ref-c-unsigned-int pointer_ref_c_unsigned_int) ((pointer void*) int))
;
(c-declare "long pointer_ref_c_long(void* pointer, int offset) { return *(long*)((char*)pointer + offset); }") ;(c-declare "long pointer_ref_c_long(void* pointer, int offset) { return *(long*)((char*)pointer + offset); }")
(define-c long (pointer-ref-c-long pointer_ref_c_long) ((pointer void*) long)) ;(define-c long (pointer-ref-c-long pointer_ref_c_long) ((pointer void*) long))
(c-declare "unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { return *(unsigned long*)((char*)pointer + offset); }") ;(c-declare "unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { return *(unsigned long*)((char*)pointer + offset); }")
(define-c unsigned-long (pointer-ref-c-unsigned-long pointer_ref_c_unsigned_long) ((pointer void*) int)) ;(define-c unsigned-long (pointer-ref-c-unsigned-long pointer_ref_c_unsigned_long) ((pointer void*) int))
;
(c-declare "float pointer_ref_c_float(void* pointer, int offset) { return *(float*)((char*)pointer + offset); }") ;(c-declare "float pointer_ref_c_float(void* pointer, int offset) { return *(float*)((char*)pointer + offset); }")
(define-c float (pointer-ref-c-float pointer_ref_c_float) ((pointer void*) int)) ;(define-c float (pointer-ref-c-float pointer_ref_c_float) ((pointer void*) int))
;
(c-declare "double pointer_ref_c_double(void* pointer, int offset) { return *(double*)((char*)pointer + offset); }") ;(c-declare "double pointer_ref_c_double(void* pointer, int offset) { return *(double*)((char*)pointer + offset); }")
(define-c double (pointer-ref-c-double pointer_ref_c_double) ((pointer void*) int)) ;(define-c double (pointer-ref-c-double pointer_ref_c_double) ((pointer void*) int))
;
(c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }") ;(c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }")
(define-c (maybe-null pointer void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int)) ;(define-c (maybe-null pointer void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int))
;; define-c-procedure ;; define-c-procedure
(c-declare "ffi_cif cif;") (c-declare "ffi_cif cif;")
(define-c (pointer void*) dlsym ((maybe-null pointer void*) string)) (define-c (pointer void*) dlsym ((maybe-null pointer void*) string))
(c-declare "void* get_ffi_type_int8() { return &ffi_type_sint8; }") ;(c-declare "void* get_ffi_type_int8() { return &ffi_type_sint8; }")
(define-c (pointer void*) (get-ffi-type-int8 get_ffi_type_int8) ()) ;(define-c (pointer void*) (get-ffi-type-int8 get_ffi_type_int8) ())
(c-declare "void* get_ffi_type_uint8() { return &ffi_type_uint8; }") ;(c-declare "void* get_ffi_type_uint8() { return &ffi_type_uint8; }")
(define-c (pointer void*) (get-ffi-type-uint8 get_ffi_type_uint8) ()) ;(define-c (pointer void*) (get-ffi-type-uint8 get_ffi_type_uint8) ())
;
(c-declare "void* get_ffi_type_int16() { return &ffi_type_sint16; }") ;(c-declare "void* get_ffi_type_int16() { return &ffi_type_sint16; }")
(define-c (pointer void*) (get-ffi-type-int16 get_ffi_type_int16) ()) ;(define-c (pointer void*) (get-ffi-type-int16 get_ffi_type_int16) ())
(c-declare "void* get_ffi_type_uint16() { return &ffi_type_uint16; }") ;(c-declare "void* get_ffi_type_uint16() { return &ffi_type_uint16; }")
(define-c (pointer void*) (get-ffi-type-uint16 get_ffi_type_uint16) ()) ;(define-c (pointer void*) (get-ffi-type-uint16 get_ffi_type_uint16) ())
;
(c-declare "void* get_ffi_type_int32() { return &ffi_type_sint32; }") ;(c-declare "void* get_ffi_type_int32() { return &ffi_type_sint32; }")
(define-c (pointer void*) (get-ffi-type-int32 get_ffi_type_int32) ()) ;(define-c (pointer void*) (get-ffi-type-int32 get_ffi_type_int32) ())
(c-declare "void* get_ffi_type_uint32() { return &ffi_type_uint32; }") ;(c-declare "void* get_ffi_type_uint32() { return &ffi_type_uint32; }")
(define-c (pointer void*) (get-ffi-type-uint32 get_ffi_type_uint32) ()) ;(define-c (pointer void*) (get-ffi-type-uint32 get_ffi_type_uint32) ())
;
(c-declare "void* get_ffi_type_int64() { return &ffi_type_sint64; }") ;(c-declare "void* get_ffi_type_int64() { return &ffi_type_sint64; }")
(define-c (pointer void*) (get-ffi-type-int64 get_ffi_type_int64) ()) ;(define-c (pointer void*) (get-ffi-type-int64 get_ffi_type_int64) ())
(c-declare "void* get_ffi_type_uint64() { return &ffi_type_uint64; }") ;(c-declare "void* get_ffi_type_uint64() { return &ffi_type_uint64; }")
(define-c (pointer void*) (get-ffi-type-uint64 get_ffi_type_uint64) ()) ;(define-c (pointer void*) (get-ffi-type-uint64 get_ffi_type_uint64) ())
;
(c-declare "void* get_ffi_type_char() { return &ffi_type_schar; }") ;(c-declare "void* get_ffi_type_char() { return &ffi_type_schar; }")
(define-c (pointer void*) (get-ffi-type-char get_ffi_type_char) ()) ;(define-c (pointer void*) (get-ffi-type-char get_ffi_type_char) ())
(c-declare "void* get_ffi_type_uchar() { return &ffi_type_uchar; }") ;(c-declare "void* get_ffi_type_uchar() { return &ffi_type_uchar; }")
(define-c (pointer void*) (get-ffi-type-uchar get_ffi_type_uchar) ()) ;(define-c (pointer void*) (get-ffi-type-uchar get_ffi_type_uchar) ())
;
(c-declare "void* get_ffi_type_short() { return &ffi_type_sshort; }") ;(c-declare "void* get_ffi_type_short() { return &ffi_type_sshort; }")
(define-c (pointer void*) (get-ffi-type-short get_ffi_type_short) ()) ;(define-c (pointer void*) (get-ffi-type-short get_ffi_type_short) ())
(c-declare "void* get_ffi_type_ushort() { return &ffi_type_ushort; }") ;(c-declare "void* get_ffi_type_ushort() { return &ffi_type_ushort; }")
(define-c (pointer void*) (get-ffi-type-ushort get_ffi_type_ushort) ()) ;(define-c (pointer void*) (get-ffi-type-ushort get_ffi_type_ushort) ())
;
(c-declare "void* get_ffi_type_int() { return &ffi_type_sint; }") ;(c-declare "void* get_ffi_type_int() { return &ffi_type_sint; }")
(define-c (pointer void*) (get-ffi-type-int get_ffi_type_int) ()) ;(define-c (pointer void*) (get-ffi-type-int get_ffi_type_int) ())
(c-declare "void* get_ffi_type_uint() { return &ffi_type_uint; }") ;(c-declare "void* get_ffi_type_uint() { return &ffi_type_uint; }")
(define-c (pointer void*) (get-ffi-type-uint get_ffi_type_uint) ()) ;(define-c (pointer void*) (get-ffi-type-uint get_ffi_type_uint) ())
;
(c-declare "void* get_ffi_type_long() { return &ffi_type_slong; }") ;(c-declare "void* get_ffi_type_long() { return &ffi_type_slong; }")
(define-c (pointer void*) (get-ffi-type-long get_ffi_type_long) ()) ;(define-c (pointer void*) (get-ffi-type-long get_ffi_type_long) ())
;
(c-declare "void* get_ffi_type_ulong() { return &ffi_type_ulong; }") ;(c-declare "void* get_ffi_type_ulong() { return &ffi_type_ulong; }")
(define-c (pointer void*) (get-ffi-type-ulong get_ffi_type_ulong) ()) ;(define-c (pointer void*) (get-ffi-type-ulong get_ffi_type_ulong) ())
;
(c-declare "void* get_ffi_type_float() { return &ffi_type_float; }") ;(c-declare "void* get_ffi_type_float() { return &ffi_type_float; }")
(define-c (pointer void*) (get-ffi-type-float get_ffi_type_float) ()) ;(define-c (pointer void*) (get-ffi-type-float get_ffi_type_float) ())
;
(c-declare "void* get_ffi_type_double() { return &ffi_type_double; }") ;(c-declare "void* get_ffi_type_double() { return &ffi_type_double; }")
(define-c (pointer void*) (get-ffi-type-double get_ffi_type_double) ()) ;(define-c (pointer void*) (get-ffi-type-double get_ffi_type_double) ())
;
(c-declare "void* get_ffi_type_void() { return &ffi_type_void; }") ;(c-declare "void* get_ffi_type_void() { return &ffi_type_void; }")
(define-c (pointer void*) (get-ffi-type-void get_ffi_type_void) ()) ;(define-c (pointer void*) (get-ffi-type-void get_ffi_type_void) ())
;
(c-declare "void* get_ffi_type_pointer() { return &ffi_type_pointer; }") ;(c-declare "void* get_ffi_type_pointer() { return &ffi_type_pointer; }")
(define-c (pointer void*) (get-ffi-type-pointer get_ffi_type_pointer) ()) ;(define-c (pointer void*) (get-ffi-type-pointer get_ffi_type_pointer) ())
(define-c-const int (FFI-OK "FFI_OK")) (define-c-const int (FFI-OK "FFI_OK"))
#;(c-declare #;(c-declare
@ -254,49 +260,124 @@
struct sexp_struct* avalues[]) struct sexp_struct* avalues[])
{ {
ffi_type* c_atypes[nargs]; ffi_type* c_atypes[nargs];
void* temps[nargs];
void* c_avalues[nargs]; void* c_avalues[nargs];
int8_t vals1[nargs];
uint8_t vals2[nargs];
int16_t vals3[nargs];
uint16_t vals4[nargs];
int32_t vals5[nargs];
uint32_t vals6[nargs];
int64_t vals7[nargs];
uint64_t vals8[nargs];
char vals9[nargs];
unsigned char vals10[nargs];
short vals11[nargs];
unsigned short vals12[nargs];
int vals13[nargs];
unsigned int vals14[nargs];
long vals15[nargs];
unsigned long vals16[nargs];
float vals17[nargs];
double vals18[nargs];
void* vals20[nargs];
for(int i = 0; i < nargs; i++) { for(int i = 0; i < nargs; i++) {
void* arg = NULL; void* arg = NULL;
switch(atypes[i]) { switch(atypes[i]) {
//case 1: c_atypes[i] = &ffi_type_sint8; arg = sexp_sint_value(avalues[i]); break; case 1:
c_atypes[i] = &ffi_type_sint8;
vals1[i] = (int8_t)sexp_sint_value(avalues[i]);
c_avalues[i] = &vals1[i];
break;
case 2: case 2:
c_atypes[i] = &ffi_type_uint8; c_atypes[i] = &ffi_type_uint8;
temps[i] = sexp_uint_value(avalues[i]); vals2[i] = (uint8_t)sexp_uint_value(avalues[i]);
c_avalues[i] = &temps[i]; c_avalues[i] = &vals2[i];
break;
case 3:
c_atypes[i] = &ffi_type_sint16;
vals3[i] = (int16_t)sexp_sint_value(avalues[i]);
c_avalues[i] = &vals3[i];
break;
case 4:
c_atypes[i] = &ffi_type_uint16;
vals4[i] = (uint16_t)sexp_uint_value(avalues[i]);
c_avalues[i] = &vals4[i];
break;
case 5:
c_atypes[i] = &ffi_type_sint32;
vals5[i] = (int32_t)sexp_sint_value(avalues[i]);
c_avalues[i] = &vals5[i];
break;
case 6:
c_atypes[i] = &ffi_type_uint32;
vals6[i] = (int64_t)sexp_uint_value(avalues[i]);
c_avalues[i] = &vals6[i];
break;
case 7:
c_atypes[i] = &ffi_type_sint64;
vals7[i] = (int64_t) sexp_sint_value(avalues[i]);
c_avalues[i] = &vals7[i];
break; break;
//case 3: c_atypes[i] = &ffi_type_sint16; arg = sexp_sint_value(avalues[i]); break;
//case 4: c_atypes[i] = &ffi_type_uint16; arg = sexp_uint_value(avalues[i]); break;
//case 5: c_atypes[i] = &ffi_type_sint32; arg = sexp_sint_value(avalues[i]); break;
//case 6: c_atypes[i] = &ffi_type_uint32; arg = sexp_uint_value(avalues[i]); break;
//case 7: c_atypes[i] = &ffi_type_sint64; arg = sexp_sint_value(avalues[i]); break;
case 8: case 8:
c_atypes[i] = &ffi_type_uint64; c_atypes[i] = &ffi_type_uint64;
temps[i] = sexp_uint_value(avalues[i]); vals8[i] = (uint64_t)sexp_uint_value(avalues[i]);
c_avalues[i] = &temps[i]; c_avalues[i] = &vals8[i];
break;
case 9:
c_atypes[i] = &ffi_type_schar;
vals9[i] = (char)sexp_sint_value(avalues[i]);
c_avalues[i] = &vals9[i];
break;
case 10:
c_atypes[i] = &ffi_type_uchar;
vals10[i] = (unsigned char)sexp_uint_value(avalues[i]);
break;
case 11:
c_atypes[i] = &ffi_type_sshort;
vals11[i] = (short)sexp_sint_value(avalues[i]);
break;
case 12:
c_atypes[i] = &ffi_type_ushort;
vals12[i] = (unsigned short)sexp_uint_value(avalues[i]);
break; break;
//case 9: c_atypes[i] = &ffi_type_schar; arg = sexp_sint_value(avalues[i]); break;
//case 10: c_atypes[i] = &ffi_type_uchar; arg = sexp_uint_value(avalues[i]); break;
//case 11: c_atypes[i] = &ffi_type_sshort; arg = sexp_sint_value(avalues[i]); break;
//case 12: c_atypes[i] = &ffi_type_ushort; arg = sexp_uint_value(avalues[i]); break;
case 13: case 13:
c_atypes[i] = &ffi_type_sint; c_atypes[i] = &ffi_type_sint;
temps[i] = sexp_sint_value(avalues[i]); vals13[i] = (int)sexp_sint_value(avalues[i]);
c_avalues[i] = &temps[i]; c_avalues[i] = &vals13[i];
break;
case 14:
c_atypes[i] = &ffi_type_uint;
vals14[i] = (unsigned int)sexp_uint_value(avalues[i]);
c_avalues[i] = &vals14[i];
break;
case 15:
c_atypes[i] = &ffi_type_slong;
vals15[i] = (long)sexp_sint_value(avalues[i]);
c_avalues[i] = &vals15[i];
break;
case 16:
c_atypes[i] = &ffi_type_ulong;
vals16[i] = (unsigned long)sexp_uint_value(avalues[i]);
c_avalues[i] = &vals16[i];
break;
case 17:
c_atypes[i] = &ffi_type_float;
vals17[i] = (float)sexp_flonum_value(avalues[i]);
break;
case 18:
c_atypes[i] = &ffi_type_double;
vals18[i] = (double)sexp_flonum_value(avalues[i]);
break;
case 19:
c_atypes[i] = &ffi_type_void;
arg = NULL;
break; break;
//case 14: c_atypes[i] = &ffi_type_uint; arg = sexp_uint_value(avalues[i]); break;
//case 15: c_atypes[i] = &ffi_type_slong; arg = sexp_sint_value(avalues[i]); break;
//case 16: c_atypes[i] = &ffi_type_ulong; arg = sexp_uint_value(avalues[i]); break;
// FIXME
//case 17: c_atypes[i] = &ffi_type_float; arg = sexp_flonum_value(avalues[i]); break;
// FIXME
//case 18: c_atypes[i] = &ffi_type_double; arg = sexp_flonum_value(avalues[i]); break;
//case 19: c_atypes[i] = &ffi_type_void; arg = NULL; break;
case 20: case 20:
c_atypes[i] = &ffi_type_pointer; c_atypes[i] = &ffi_type_pointer;
c_avalues[i] = &sexp_cpointer_value(avalues[i]); vals20[i] = sexp_cpointer_value(avalues[i]);
//printf(\"Pointer value: %s\\n\", sexp_cpointer_maybe_null_value(avalues[i])); c_avalues[i] = &vals20[i];
break; break;
default: default:
printf(\"Undefined argument type integer: %i, index: %i\\n\", atypes[i], i); printf(\"Undefined argument type integer: %i, index: %i\\n\", atypes[i], i);

8
foreign/c/primitives/chicken.scm
View File

@ -173,6 +173,14 @@
(lambda (c-bytevector k byte) (lambda (c-bytevector k byte)
(pointer-u8-set! (pointer+ c-bytevector k) byte))) (pointer-u8-set! (pointer+ c-bytevector k) byte)))
(define c-bytevector-pointer-ref
(lambda (c-bytevector k)
(address->pointer (pointer-u64-ref (pointer+ c-bytevector k)))))
(define c-bytevector-pointer-set!
(lambda (c-bytevector k pointer)
(pointer-u64-set! (pointer+ c-bytevector k) (pointer->address pointer))))
#;(define pffi-pointer-set! #;(define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(cond (cond

77
foreign/c/primitives/gauche.scm
View File

@ -3,6 +3,8 @@
shared-object-load shared-object-load
c-bytevector-u8-set! c-bytevector-u8-set!
c-bytevector-u8-ref c-bytevector-u8-ref
c-bytevector-pointer-set!
c-bytevector-pointer-ref
;pointer-null ;pointer-null
;pointer-null? ;pointer-null?
;make-c-bytevector ;make-c-bytevector
@ -11,39 +13,16 @@
c-free c-free
;pointer-set! ;pointer-set!
;pointer-get ;pointer-get
define-c-procedure ;define-c-procedure
define-c-callback)) define-c-callback
dlerror
dlsym
internal-ffi-call
))
(select-module foreign.c.primitives.gauche) (select-module foreign.c.primitives.gauche)
(dynamic-load "foreign/c/lib/gauche") (dynamic-load "foreign/c/lib/gauche")
;; FIXME This is copied from types.scm
(define type->libffi-type-number
(lambda (type)
(cond ((equal? type 'int8) 1)
((equal? type 'uint8) 2)
((equal? type 'int16) 3)
((equal? type 'uint16) 4)
((equal? type 'int32) 5)
((equal? type 'uint32) 6)
((equal? type 'int64) 7)
((equal? type 'uint64) 8)
((equal? type 'char) 9)
((equal? type 'unsigned-char) 10)
((equal? type 'short) 11)
((equal? type 'unsigned-short) 12)
((equal? type 'int) 13)
((equal? type 'unsigned-int) 14)
((equal? type 'long) 15)
((equal? type 'unsigned-long) 16)
((equal? type 'float) 17)
((equal? type 'double) 18)
((equal? type 'void) 19)
((equal? type 'pointer) 20)
((equal? type 'pointer-address) 21)
((equal? type 'callback) 22)
(else (error "Undefined type" type)))))
(define size-of-type (define size-of-type
(lambda (type) (lambda (type)
(cond (cond
@ -87,8 +66,10 @@
(define c-bytevector-u8-set! pointer-set-uint8!) (define c-bytevector-u8-set! pointer-set-uint8!)
(define c-bytevector-u8-ref pointer-get-uint8) (define c-bytevector-u8-ref pointer-get-uint8)
(define c-bytevector-pointer-set! pointer-set-pointer!)
(define c-bytevector-pointer-ref pointer-get-pointer)
(define pointer-set! #;(define pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-int8! pointer offset value)) (cond ((equal? type 'int8) (pointer-set-int8! pointer offset value))
((equal? type 'uint8) (pointer-set-uint8! pointer offset value)) ((equal? type 'uint8) (pointer-set-uint8! pointer offset value))
@ -110,7 +91,7 @@
((equal? type 'void) (pointer-set-pointer! pointer offset value)) ((equal? type 'void) (pointer-set-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-pointer! pointer offset value))))) ((equal? type 'pointer) (pointer-set-pointer! pointer offset value)))))
(define pointer-get #;(define pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(cond ((equal? type 'int8) (pointer-get-int8 pointer offset)) (cond ((equal? type 'int8) (pointer-get-int8 pointer offset))
((equal? type 'uint8) (pointer-get-uint8 pointer offset)) ((equal? type 'uint8) (pointer-get-uint8 pointer offset))
@ -189,40 +170,6 @@
(pointer-set! pointer type 0 value) (pointer-set! pointer type 0 value)
pointer))))) pointer)))))
(define make-c-function
(lambda (shared-object c-name return-type argument-types)
(dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror)))
(lambda arguments
(display "Calling: ")
(write c-name)
(newline)
(let ((return-pointer (internal-ffi-call (length argument-types)
(type->libffi-type-number return-type)
(map type->libffi-type-number argument-types)
c-function
(size-of-type return-type)
arguments)))
(cond ((equal? return-type 'pointer)
(display "SCM return value: ")
(write return-pointer)
(newline)
return-pointer)
((not (equal? return-type 'void))
(display "SCM return value: ")
(write (pointer-get return-pointer return-type 0))
(newline)
(pointer-get return-pointer return-type 0))))))))
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-c-function shared-object
(symbol->string c-name)
return-type
argument-types)))))
(define make-c-callback (define make-c-callback
(lambda (return-type argument-types procedure) (lambda (return-type argument-types procedure)

25
foreign/c/primitives/gauche/define-c-procedure.scm Normal file
View File

@ -0,0 +1,25 @@
;;;; This file is dependent on content of other files added trough (include...)
;;;; And that's why it is separated
(define make-c-function
(lambda (shared-object c-name return-type argument-types)
(dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror)))
(lambda arguments
(let ((return-pointer (internal-ffi-call (length argument-types)
(type->libffi-type-number return-type)
(map type->libffi-type-number argument-types)
c-function
(size-of-type return-type)
arguments)))
(c-bytevector-get return-pointer return-type 0))))))
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-c-function shared-object
(symbol->string c-name)
return-type
argument-types)))))

118
foreign/c/primitives/gauche/gauchelib.scm
View File

@ -24,51 +24,51 @@
(define-cproc size-of-pointer () size_of_pointer) (define-cproc size-of-pointer () size_of_pointer)
(define-cproc size-of-void () size_of_void) (define-cproc size-of-void () size_of_void)
(define-cproc shared-object-load (path::<string> options) shared_object_load) (define-cproc shared-object-load (path::<string> options) shared_object_load)
(define-cproc pointer-null () pointer_null) ;(define-cproc pointer-null () pointer_null)
(define-cproc pointer-null? (pointer) is_pointer_null) ;(define-cproc pointer-null? (pointer) is_pointer_null)
(define-cproc pointer-allocate (size::<int>) pointer_allocate) ;(define-cproc pointer-allocate (size::<int>) pointer_allocate)
(define-cproc pointer-address (object) pointer_address) ;(define-cproc pointer-address (object) pointer_address)
(define-cproc pointer? (pointer) is_pointer) (define-cproc pointer? (pointer) is_pointer)
(define-cproc pointer-free (pointer) pointer_free) ;(define-cproc pointer-free (pointer) pointer_free)
(define-cproc pointer-set-int8! (pointer offset::<int> value::<int8>) pointer_set_int8) ;(define-cproc pointer-set-int8! (pointer offset::<int> value::<int8>) pointer_set_int8)
(define-cproc pointer-set-uint8! (pointer offset::<int> value::<int8>) pointer_set_uint8) (define-cproc pointer-set-uint8! (pointer offset::<int> value::<int8>) pointer_set_uint8)
(define-cproc pointer-set-int16! (pointer offset::<int> value::<int16>) pointer_set_int16) ;(define-cproc pointer-set-int16! (pointer offset::<int> value::<int16>) pointer_set_int16)
(define-cproc pointer-set-uint16! (pointer offset::<int> value::<int16>) pointer_set_uint16) ;(define-cproc pointer-set-uint16! (pointer offset::<int> value::<int16>) pointer_set_uint16)
(define-cproc pointer-set-int32! (pointer offset::<int> value::<int32>) pointer_set_int32) ;(define-cproc pointer-set-int32! (pointer offset::<int> value::<int32>) pointer_set_int32)
(define-cproc pointer-set-uint32! (pointer offset::<int> value::<int32>) pointer_set_uint32) ;(define-cproc pointer-set-uint32! (pointer offset::<int> value::<int32>) pointer_set_uint32)
(define-cproc pointer-set-int64! (pointer offset::<int> value::<int64>) pointer_set_int64) ;(define-cproc pointer-set-int64! (pointer offset::<int> value::<int64>) pointer_set_int64)
(define-cproc pointer-set-uint64! (pointer offset::<int> value::<int64>) pointer_set_uint64) ;(define-cproc pointer-set-uint64! (pointer offset::<int> value::<int64>) pointer_set_uint64)
(define-cproc pointer-set-char! (pointer offset::<int> value::<char>) pointer_set_char) ;(define-cproc pointer-set-char! (pointer offset::<int> value::<char>) pointer_set_char)
(define-cproc pointer-set-unsigned-char! (pointer offset::<int> value::<char>) pointer_set_unsigned_char) ;(define-cproc pointer-set-unsigned-char! (pointer offset::<int> value::<char>) pointer_set_unsigned_char)
(define-cproc pointer-set-short! (pointer offset::<int> value::<short>) pointer_set_short) ;(define-cproc pointer-set-short! (pointer offset::<int> value::<short>) pointer_set_short)
(define-cproc pointer-set-unsigned-short! (pointer offset::<int> value::<short>) pointer_set_unsigned_short) ;(define-cproc pointer-set-unsigned-short! (pointer offset::<int> value::<short>) pointer_set_unsigned_short)
(define-cproc pointer-set-int! (pointer offset::<int> value::<int>) pointer_set_int) ;(define-cproc pointer-set-int! (pointer offset::<int> value::<int>) pointer_set_int)
(define-cproc pointer-set-unsigned-int! (pointer offset::<int> value::<int>) pointer_set_unsigned_int) ;(define-cproc pointer-set-unsigned-int! (pointer offset::<int> value::<int>) pointer_set_unsigned_int)
(define-cproc pointer-set-long! (pointer offset::<int> value::<long>) pointer_set_long) ;(define-cproc pointer-set-long! (pointer offset::<int> value::<long>) pointer_set_long)
(define-cproc pointer-set-unsigned-long! (pointer offset::<int> value::<long>) pointer_set_unsigned_long) ;(define-cproc pointer-set-unsigned-long! (pointer offset::<int> value::<long>) pointer_set_unsigned_long)
(define-cproc pointer-set-float! (pointer offset::<int> value::<float>) pointer_set_float) ;(define-cproc pointer-set-float! (pointer offset::<int> value::<float>) pointer_set_float)
(define-cproc pointer-set-double! (pointer offset::<int> value::<double>) pointer_set_double) ;(define-cproc pointer-set-double! (pointer offset::<int> value::<double>) pointer_set_double)
(define-cproc pointer-set-pointer! (pointer offset::<int> value) pointer_set_pointer) (define-cproc pointer-set-pointer! (pointer offset::<int> value) pointer_set_pointer)
(define-cproc pointer-get-int8 (pointer offset::<int>) pointer_get_int8) ;(define-cproc pointer-get-int8 (pointer offset::<int>) pointer_get_int8)
(define-cproc pointer-get-uint8 (pointer offset::<int>) pointer_get_uint8) (define-cproc pointer-get-uint8 (pointer offset::<int>) pointer_get_uint8)
(define-cproc pointer-get-int16 (pointer offset::<int>) pointer_get_int16) ;(define-cproc pointer-get-int16 (pointer offset::<int>) pointer_get_int16)
(define-cproc pointer-get-uint16 (pointer offset::<int>) pointer_get_uint16) ;(define-cproc pointer-get-uint16 (pointer offset::<int>) pointer_get_uint16)
(define-cproc pointer-get-int32 (pointer offset::<int>) pointer_get_int32) ;(define-cproc pointer-get-int32 (pointer offset::<int>) pointer_get_int32)
(define-cproc pointer-get-uint32 (pointer offset::<int>) pointer_get_uint32) ;(define-cproc pointer-get-uint32 (pointer offset::<int>) pointer_get_uint32)
(define-cproc pointer-get-int64 (pointer offset::<int>) pointer_get_int64) ;(define-cproc pointer-get-int64 (pointer offset::<int>) pointer_get_int64)
(define-cproc pointer-get-uint64 (pointer offset::<int>) pointer_get_uint64) ;(define-cproc pointer-get-uint64 (pointer offset::<int>) pointer_get_uint64)
(define-cproc pointer-get-char (pointer offset::<int>) pointer_get_char) ;(define-cproc pointer-get-char (pointer offset::<int>) pointer_get_char)
(define-cproc pointer-get-unsigned-char (pointer offset::<int>) pointer_get_unsigned_char) ;(define-cproc pointer-get-unsigned-char (pointer offset::<int>) pointer_get_unsigned_char)
(define-cproc pointer-get-short (pointer offset::<int>) pointer_get_short) ;(define-cproc pointer-get-short (pointer offset::<int>) pointer_get_short)
(define-cproc pointer-get-unsigned-short (pointer offset::<int>) pointer_get_unsigned_short) ;(define-cproc pointer-get-unsigned-short (pointer offset::<int>) pointer_get_unsigned_short)
(define-cproc pointer-get-int (pointer offset::<int>) pointer_get_int) ;(define-cproc pointer-get-int (pointer offset::<int>) pointer_get_int)
(define-cproc pointer-get-unsigned-int (pointer offset::<int>) pointer_get_unsigned_int) ;(define-cproc pointer-get-unsigned-int (pointer offset::<int>) pointer_get_unsigned_int)
(define-cproc pointer-get-long (pointer offset::<int>) pointer_get_long) ;(define-cproc pointer-get-long (pointer offset::<int>) pointer_get_long)
(define-cproc pointer-get-unsigned-long (pointer offset::<int>) pointer_get_unsigned_long) ;(define-cproc pointer-get-unsigned-long (pointer offset::<int>) pointer_get_unsigned_long)
(define-cproc pointer-get-float (pointer offset::<int>) pointer_get_float) ;(define-cproc pointer-get-float (pointer offset::<int>) pointer_get_float)
(define-cproc pointer-get-double (pointer offset::<int>) pointer_get_double) ;(define-cproc pointer-get-double (pointer offset::<int>) pointer_get_double)
(define-cproc pointer-get-pointer (pointer offset::<int>) pointer_get_pointer) (define-cproc pointer-get-pointer (pointer offset::<int>) pointer_get_pointer)
(define-cproc dlerror () internal_dlerror) (define-cproc dlerror () internal_dlerror)
@ -76,26 +76,26 @@
(define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call) (define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call)
(define-cproc scheme-procedure-to-pointer (procedure) scheme_procedure_to_pointer) (define-cproc scheme-procedure-to-pointer (procedure) scheme_procedure_to_pointer)
(define-cproc get-ffi-type-int8 () get_ffi_type_int8) ;(define-cproc get-ffi-type-int8 () get_ffi_type_int8)
(define-cproc get-ffi-type-uint8 () get_ffi_type_uint8) ;(define-cproc get-ffi-type-uint8 () get_ffi_type_uint8)
(define-cproc get-ffi-type-int16 () get_ffi_type_int16) ;(define-cproc get-ffi-type-int16 () get_ffi_type_int16)
(define-cproc get-ffi-type-uint16 () get_ffi_type_uint16) ;(define-cproc get-ffi-type-uint16 () get_ffi_type_uint16)
(define-cproc get-ffi-type-int32 () get_ffi_type_int32) ;(define-cproc get-ffi-type-int32 () get_ffi_type_int32)
(define-cproc get-ffi-type-uint32 () get_ffi_type_uint32) ;(define-cproc get-ffi-type-uint32 () get_ffi_type_uint32)
(define-cproc get-ffi-type-int64 () get_ffi_type_int64) ;(define-cproc get-ffi-type-int64 () get_ffi_type_int64)
(define-cproc get-ffi-type-uint64 () get_ffi_type_uint64) ;(define-cproc get-ffi-type-uint64 () get_ffi_type_uint64)
(define-cproc get-ffi-type-char () get_ffi_type_char) ;(define-cproc get-ffi-type-char () get_ffi_type_char)
(define-cproc get-ffi-type-unsigned-char () get_ffi_type_unsigned_char) ;(define-cproc get-ffi-type-unsigned-char () get_ffi_type_unsigned_char)
(define-cproc get-ffi-type-short () get_ffi_type_short) ;(define-cproc get-ffi-type-short () get_ffi_type_short)
(define-cproc get-ffi-type-unsigned-short () get_ffi_type_unsigned_short) ;(define-cproc get-ffi-type-unsigned-short () get_ffi_type_unsigned_short)
(define-cproc get-ffi-type-int () get_ffi_type_int) ;(define-cproc get-ffi-type-int () get_ffi_type_int)
(define-cproc get-ffi-type-unsigned-int () get_ffi_type_unsigned_int) ;(define-cproc get-ffi-type-unsigned-int () get_ffi_type_unsigned_int)
(define-cproc get-ffi-type-long () get_ffi_type_long) ;(define-cproc get-ffi-type-long () get_ffi_type_long)
(define-cproc get-ffi-type-unsigned-long () get_ffi_type_unsigned_long) ;(define-cproc get-ffi-type-unsigned-long () get_ffi_type_unsigned_long)
(define-cproc get-ffi-type-float () get_ffi_type_float) ;(define-cproc get-ffi-type-float () get_ffi_type_float)
(define-cproc get-ffi-type-double () get_ffi_type_double) ;(define-cproc get-ffi-type-double () get_ffi_type_double)
(define-cproc get-ffi-type-void() get_ffi_type_void) ;(define-cproc get-ffi-type-void() get_ffi_type_void)
(define-cproc get-ffi-type-pointer () get_ffi_type_pointer) ;(define-cproc get-ffi-type-pointer () get_ffi_type_pointer)
;(define-cproc procedure-to-pointer (procedure) procedure_to_pointer) ;(define-cproc procedure-to-pointer (procedure) procedure_to_pointer)
) )

99
foreign/c/primitives/guile.scm
View File

@ -66,46 +66,61 @@
(let ((p (pointer->bytevector c-bytevector (+ k 100)))) (let ((p (pointer->bytevector c-bytevector (+ k 100))))
(bytevector-u8-ref p k)))) (bytevector-u8-ref p k))))
(define pointer-set! (define c-bytevector-pointer-set!
(lambda (pointer type offset value) (lambda (c-bytevector k pointer)
(let ((p (pointer->bytevector pointer (+ offset 100)))) (c-bytevector-uint-set! c-bytevector
(cond ((equal? type 'int8) (bytevector-s8-set! p offset value)) k
((equal? type 'uint8) (bytevector-u8-set! p offset value)) (pointer-address pointer)
((equal? type 'int16) (bytevector-s16-set! p offset value (native-endianness))) (native-endianness)
((equal? type 'uint16) (bytevector-u16-set! p offset value (native-endianness))) (size-of-type 'pointer))))
((equal? type 'int32) (bytevector-s32-set! p offset value (native-endianness)))
((equal? type 'uint32) (bytevector-u32-set! p offset value (native-endianness)))
((equal? type 'int64) (bytevector-s64-set! p offset value (native-endianness)))
((equal? type 'uint64) (bytevector-u64-set! p offset value (native-endianness)))
((equal? type 'char) (bytevector-s8-set! p offset (char->integer value)))
((equal? type 'short) (bytevector-s8-set! p offset value))
((equal? type 'unsigned-short) (bytevector-u8-set! p offset value))
((equal? type 'int) (bytevector-sint-set! p offset value (native-endianness) (size-of-type type)))
((equal? type 'unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (size-of-type type)))
((equal? type 'long) (bytevector-s64-set! p offset value (native-endianness)))
((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness)))
((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness)))
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))))))
(define pointer-get (define c-bytevector-pointer-ref
(lambda (pointer type offset) (lambda (c-bytevector k)
(let ((p (pointer->bytevector pointer (+ offset 100)))) (make-pointer (c-bytevector-uint-ref c-bytevector
(cond ((equal? type 'int8) (bytevector-s8-ref p offset)) k
((equal? type 'uint8) (bytevector-u8-ref p offset)) (native-endianness)
((equal? type 'int16) (bytevector-s16-ref p offset (native-endianness))) (size-of-type 'pointer)))))
((equal? type 'uint16) (bytevector-u16-ref p offset (native-endianness)))
((equal? type 'int32) (bytevector-s32-ref p offset (native-endianness))) #;(define pointer-set!
((equal? type 'uint32) (bytevector-u32-ref p offset (native-endianness))) (lambda (pointer type offset value)
((equal? type 'int64) (bytevector-s64-ref p offset (native-endianness))) (let ((p (pointer->bytevector pointer (+ offset 100))))
((equal? type 'uint64) (bytevector-u64-ref p offset (native-endianness))) (cond ((equal? type 'int8) (bytevector-s8-set! p offset value))
((equal? type 'char) (integer->char (bytevector-s8-ref p offset))) ((equal? type 'uint8) (bytevector-u8-set! p offset value))
((equal? type 'short) (bytevector-s8-ref p offset)) ((equal? type 'int16) (bytevector-s16-set! p offset value (native-endianness)))
((equal? type 'unsigned-short) (bytevector-u8-ref p offset)) ((equal? type 'uint16) (bytevector-u16-set! p offset value (native-endianness)))
((equal? type 'int) (bytevector-sint-ref p offset (native-endianness) (size-of-type type))) ((equal? type 'int32) (bytevector-s32-set! p offset value (native-endianness)))
((equal? type 'unsigned-int) (bytevector-uint-ref p offset (native-endianness) (size-of-type type))) ((equal? type 'uint32) (bytevector-u32-set! p offset value (native-endianness)))
((equal? type 'long) (bytevector-s64-ref p offset (native-endianness))) ((equal? type 'int64) (bytevector-s64-set! p offset value (native-endianness)))
((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness))) ((equal? type 'uint64) (bytevector-u64-set! p offset value (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness))) ((equal? type 'char) (bytevector-s8-set! p offset (char->integer value)))
((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness))) ((equal? type 'short) (bytevector-s8-set! p offset value))
((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))))))) ((equal? type 'unsigned-short) (bytevector-u8-set! p offset value))
((equal? type 'int) (bytevector-sint-set! p offset value (native-endianness) (size-of-type type)))
((equal? type 'unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (size-of-type type)))
((equal? type 'long) (bytevector-s64-set! p offset value (native-endianness)))
((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness)))
((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness)))
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))))))
#;(define pointer-get
(lambda (pointer type offset)
(let ((p (pointer->bytevector pointer (+ offset 100))))
(cond ((equal? type 'int8) (bytevector-s8-ref p offset))
((equal? type 'uint8) (bytevector-u8-ref p offset))
((equal? type 'int16) (bytevector-s16-ref p offset (native-endianness)))
((equal? type 'uint16) (bytevector-u16-ref p offset (native-endianness)))
((equal? type 'int32) (bytevector-s32-ref p offset (native-endianness)))
((equal? type 'uint32) (bytevector-u32-ref p offset (native-endianness)))
((equal? type 'int64) (bytevector-s64-ref p offset (native-endianness)))
((equal? type 'uint64) (bytevector-u64-ref p offset (native-endianness)))
((equal? type 'char) (integer->char (bytevector-s8-ref p offset)))
((equal? type 'short) (bytevector-s8-ref p offset))
((equal? type 'unsigned-short) (bytevector-u8-ref p offset))
((equal? type 'int) (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))
((equal? type 'unsigned-int) (bytevector-uint-ref p offset (native-endianness) (size-of-type type)))
((equal? type 'long) (bytevector-s64-ref p offset (native-endianness)))
((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness)))
((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness)))
((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))))))

30
foreign/c/primitives/kawa.scm
View File

@ -170,25 +170,21 @@
u8-value-layout u8-value-layout
k))) k)))
(define pointer-set! (define pointer-value-layout (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
(lambda (pointer type offset value) (define c-bytevector-pointer-set!
(invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) (lambda (c-bytevector k pointer)
(invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
'set 'set
(type->native-type type) pointer-value-layout
offset k
(if (equal? type 'char) pointer)))
(char->integer value)
value))))
(define pointer-get (define c-bytevector-pointer-ref
(lambda (pointer type offset) (lambda (c-bytevector k)
(let ((r (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) (invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
'get 'get
(type->native-type type) pointer-value-layout
offset))) k)))
(if (equal? type 'char)
(integer->char r)
r))))
#;(define-syntax call-with-address-of-c-bytevector #;(define-syntax call-with-address-of-c-bytevector
(syntax-rules () (syntax-rules ()

2
foreign/c/primitives/mosh.scm
View File

@ -33,6 +33,8 @@
(define c-bytevector-u8-set! pointer-set-c-uint8!) (define c-bytevector-u8-set! pointer-set-c-uint8!)
(define c-bytevector-u8-ref pointer-ref-c-uint8) (define c-bytevector-u8-ref pointer-ref-c-uint8)
(define c-bytevector-pointer-set! pointer-set-c-pointer!)
(define c-bytevector-pointer-ref pointer-ref-c-pointer)
#;(define pointer-set! #;(define pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)

24
foreign/c/primitives/racket.scm
View File

@ -65,25 +65,13 @@
(lambda (c-bytevector k) (lambda (c-bytevector k)
(ptr-ref c-bytevector _uint8 'abs k))) (ptr-ref c-bytevector _uint8 'abs k)))
#;(define pointer-set! (define c-bytevector-pointer-set!
(lambda (pointer type offset value) (lambda (c-bytevector k pointer)
(ptr-set! pointer (ptr-set! c-bytevector _pointer 'abs k pointer)))
(type->native-type type)
'abs
offset
(if (equal? type 'char)
(char->integer value)
value))))
#;(define pointer-get (define c-bytevector-pointer-ref
(lambda (pointer type offset) (lambda (c-bytevector k)
(let ((r (ptr-ref pointer (ptr-ref c-bytevector _pointer 'abs k)))
(type->native-type type)
'abs
offset)))
(if (equal? type 'char)
(integer->char r)
r))))
#;(define-syntax call-with-address-of-c-bytevector #;(define-syntax call-with-address-of-c-bytevector
(syntax-rules () (syntax-rules ()

6
foreign/c/primitives/sagittarius.scm
View File

@ -75,8 +75,10 @@
(define c-bytevector-u8-set! pointer-set-c-uint8_t!) (define c-bytevector-u8-set! pointer-set-c-uint8_t!)
(define c-bytevector-u8-ref pointer-ref-c-uint8_t) (define c-bytevector-u8-ref pointer-ref-c-uint8_t)
(define c-bytevector-pointer-set! pointer-set-c-pointer!)
(define c-bytevector-pointer-ref pointer-ref-c-pointer)
(define pointer-set! #;(define pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value)) (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value)) ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
@ -98,7 +100,7 @@
((equal? type 'void) (pointer-set-c-pointer! pointer offset value)) ((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
(define pointer-get #;(define pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset)) (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset)) ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))

6
foreign/c/primitives/stklos.scm
View File

@ -97,8 +97,10 @@
(define c-bytevector-u8-set! pointer-set-c-uint8_t!) (define c-bytevector-u8-set! pointer-set-c-uint8_t!)
(define c-bytevector-u8-ref pointer-ref-c-uint8_t) (define c-bytevector-u8-ref pointer-ref-c-uint8_t)
(define c-bytevector-pointer-set! pointer-set-c-pointer!)
(define c-bytevector-pointer-ref pointer-ref-c-pointer)
(define pffi-pointer-set! #;(define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value)) (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value)) ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
@ -120,7 +122,7 @@
((equal? type 'void) (pointer-set-c-pointer! pointer offset value)) ((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
(define pffi-pointer-get #;(define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset)) (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset)) ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))

12
foreign/c/primitives/ypsilon.scm
View File

@ -40,8 +40,16 @@
(bytevector-c-int8-ref (make-bytevector-mapping (+ c-bytevector k) (bytevector-c-int8-ref (make-bytevector-mapping (+ c-bytevector k)
(c-size-of 'uint8)) (c-size-of 'uint8))
0))) 0)))
(define c-bytevector-pointer-set!
(lambda (c-bytevector k pointer)
(let ((bv (make-bytevector-mapping (+ c-bytevector k) (c-size-of 'pointer))))
(bytevector-c-void*-set! bv 0 pointer))))
(define c-bytevector-pointer-ref
(lambda (c-bytevector k)
(let ((bv (make-bytevector-mapping (+ c-bytevector k) (c-size-of 'pointer))))
(bytevector-c-void*-ref bv 0))))
(define pointer-set! #;(define pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(let ((bv (make-bytevector-mapping (+ pointer offset) (c-size-of type)))) (let ((bv (make-bytevector-mapping (+ pointer offset) (c-size-of type))))
(cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value)) (cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value))
@ -64,7 +72,7 @@
((equal? type 'void) (bytevector-c-void*-set! bv 0 value)) ((equal? type 'void) (bytevector-c-void*-set! bv 0 value))
((equal? type 'pointer) (bytevector-c-void*-set! bv 0 value)))))) ((equal? type 'pointer) (bytevector-c-void*-set! bv 0 value))))))
(define pointer-get #;(define pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(let ((bv (make-bytevector-mapping (+ pointer offset) (c-size-of type)))) (let ((bv (make-bytevector-mapping (+ pointer offset) (c-size-of type))))
(cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0)) (cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0))

2
tests/addressof.scm
View File

@ -88,8 +88,6 @@
'(pointer pointer)) '(pointer pointer))
(define input-pointer (make-c-bytevector (c-size-of 'int))) (define input-pointer (make-c-bytevector (c-size-of 'int)))
(debug (c-bytevector->address input-pointer))
(assert equal? (number? (c-bytevector->address input-pointer)) #t)
(c-bytevector-s32-native-set! input-pointer 0 100) (c-bytevector-s32-native-set! input-pointer 0 100)
(assert equal? (= (c-bytevector-s32-native-ref input-pointer 0) 100) #t) (assert equal? (= (c-bytevector-s32-native-ref input-pointer 0) 100) #t)
(debug (c-bytevector-s32-native-ref input-pointer 0)) (debug (c-bytevector-s32-native-ref input-pointer 0))

128
tests/callback.scm Normal file
View File

@ -0,0 +1,128 @@
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(foreign c))
;; util
(define header-count 1)
(define print-header
(lambda (title)
(set-tag title)
(display "=========================================")
(newline)
(display header-count)
(display " ")
(display title)
(newline)
(display "=========================================")
(newline)
(set! header-count (+ header-count 1))))
(define count 0)
(define assert-tag 'none)
(define set-tag
(lambda (tag)
(set! assert-tag tag)
(set! count 0)))
(cond-expand
(gambit
(define assert
(lambda (check value-a value-b)
(let ((result (apply check (list value-a value-b))))
(set! count (+ count 1))
(if (not result) (display "FAIL ") (display "PASS "))
(display "[")
(display assert-tag)
(display " - ")
(display count)
(display "]")
(display ": ")
(write (list 'check 'value-a 'value-b))
(newline)
(when (not result) (exit 1))))))
(else
(define-syntax assert
(syntax-rules ()
((_ check value-a value-b)
(let ((result (apply check (list value-a value-b))))
(set! count (+ count 1))
(if (not result) (display "FAIL ") (display "PASS "))
(display "[")
(display assert-tag)
(display " - ")
(display count)
(display "]")
(display ": ")
(write (list 'check 'value-a 'value-b))
(newline)
(when (not result) (exit 1))))))))
(define-syntax debug
(syntax-rules ()
((_ value)
(begin
(display 'value)
(display ": ")
(write value)
(newline)))))
;; define-c-library
(print-header 'define-c-library)
(cond-expand
(windows (define-c-library libc
'("stdio.h" "string.h")
"ucrtbase"
'((additional-versions ("0" "6")))))
(else (define-c-library libc
'("stdio.h" "string.h")
"c"
'((additional-versions ("0" "6"))))))
(debug libc)
;; define-c-callback
(print-header 'define-c-callback)
(define array (make-c-bytevector (* (c-size-of 'int) 3)))
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 0) 3)
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 1) 2)
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 2) 1)
(define-c-procedure qsort libc 'qsort 'void '(pointer int int callback))
(define-c-callback compare
'int
'(pointer pointer)
(lambda (pointer-a pointer-b)
(let ((a (c-bytevector-s32-native-ref pointer-a 0))
(b (c-bytevector-s32-native-ref pointer-b 0)))
(cond ((> a b) 1)
((= a b) 0)
((< a b) -1)))))
(write compare)
(newline)
(define unsorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0))
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 1))
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 2))))
(debug unsorted)
(assert equal? unsorted (list 3 2 1))
(qsort array 3 (c-size-of 'int) compare)
(define sorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0))
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 1))
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 2))))
(debug sorted)
(assert equal? sorted (list 1 2 3))
(exit 0)

50
tests/primitives.scm
View File

@ -279,6 +279,19 @@
(debug (c-bytevector-u8-ref u8-pointer 0)) (debug (c-bytevector-u8-ref u8-pointer 0))
(assert equal? (= (c-bytevector-u8-ref u8-pointer 0) 42) #t) (assert equal? (= (c-bytevector-u8-ref u8-pointer 0) 42) #t)
;; c-bytevector-pointer-set! and c-bytevector-pointer-ref
(print-header "c-bytevector-pointer-set! and c-bytevector-pointer-ref")
(define p-pointer (make-c-bytevector (c-size-of 'pointer)))
(debug p-pointer)
(debug (c-bytevector? p-pointer))
(assert equal? (c-bytevector? p-pointer) #t)
(c-bytevector-pointer-set! p-pointer 0 u8-pointer)
(debug p-pointer)
(debug (c-bytevector-pointer-ref p-pointer 0))
(debug (c-bytevector-u8-ref (c-bytevector-pointer-ref p-pointer 0) 0))
(assert equal? (= (c-bytevector-u8-ref (c-bytevector-pointer-ref p-pointer 0) 0) 42) #t)
;; string->-utf8 c-utf8->string ;; string->-utf8 c-utf8->string
(print-header "string->c-utf8 c-utf8->string") (print-header "string->c-utf8 c-utf8->string")
(for-each (for-each
@ -333,41 +346,4 @@
(lambda () (read-line))) (lambda () (read-line)))
"Hello world") #t) "Hello world") #t)
;; define-c-callback
(print-header 'define-c-callback)
(define array (make-c-bytevector (* (c-size-of 'int) 3)))
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 0) 3)
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 1) 2)
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 2) 1)
(define-c-procedure qsort libc 'qsort 'void '(pointer int int callback))
(define-c-callback compare
'int
'(pointer pointer)
(lambda (pointer-a pointer-b)
(let ((a (c-bytevector-s32-native-ref pointer-a 0))
(b (c-bytevector-s32-native-ref pointer-b 0)))
(cond ((> a b) 1)
((= a b) 0)
((< a b) -1)))))
(write compare)
(newline)
(define unsorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0))
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 1))
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 2))))
(debug unsorted)
(assert equal? unsorted (list 3 2 1))
(qsort array 3 (c-size-of 'int) compare)
(define sorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0))
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 1))
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 2))))
(debug sorted)
(assert equal? sorted (list 1 2 3))
(exit 0) (exit 0)