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

Progress on Chibi

This commit is contained in:
retropikzel 2025-04-27 15:54:46 +03:00
parent 7789dfdd48
commit 1f9732020a
20 changed files with 453 additions and 375 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
README.md
View File

@ -15,18 +15,18 @@ The new readme is a work in progress.
## Primitives ## Primitives
| | c-size-of | define-c-library | c-bytevector? | define-c-procedure | define-c-callbck | c-bytevector-u8-ref | | | c-size-of | c-bytevector-u8-set! |c-bytevector-u8-ref | define-c-library | c-bytevector? | define-c-procedure | define-c-callback |
|------------------|:------------:|:-------------------:|:-------------:|:-------------------:|:----------------:|:-------------------:| |------------------|:------------:|:------------------- :|-------------------:|:-------------------:|:-------------:|:-------------------:|:-----------------:|
| Chibi | X | X | X | X | | X | | Chibi | X | X |X | X | X | X | |
| **Chicken** | X | X | X | X | X | X | | **Chicken** | X | X |X | X | X | X | X |
| Gauche | X | X | X | X | | | | Gauche | X | X |X | X | X | X | |
| **Guile** | X | X | X | X | X | X | | **Guile** | X | X |X | X | X | X | X |
| Kawa | X | X | X | X | | X | | Kawa | X | X |X | X | X | X | |
| **Mosh** | X | X | X | X | X | X | | **Mosh** | X | X |X | X | X | X | X |
| **Racket** | X | X | X | X | X | X | | **Racket** | X | X |X | X | X | X | X |
| **Saggittarius** | X | X | X | X | X | X | | **Saggittarius** | X | X |X | X | X | X | X |
| Stklos | X | X | X | X | | X | | Stklos | X | X |X | X | X | X | |
| **Ypsilon** | X | X | X | X | X | X | | **Ypsilon** | X | X |X | X | X | X | X |
## Test files pass ## Test files pass
@ -36,7 +36,7 @@ The new readme is a work in progress.
| **Chicken** | X | X | | **Chicken** | X | X |
| Gauche | | | | Gauche | | |
| **Guile** | X | X | | **Guile** | X | X |
| Kawa | | X | | Kawa | | |
| Mosh | X | | | Mosh | X | |
| Racket | X | | | Racket | X | |
| **Saggittarius** | X | X | | **Saggittarius** | X | X |

9
foreign/c.sld
View File

@ -132,7 +132,7 @@
(scheme inexact) (scheme inexact)
(scheme process-context) (scheme process-context)
(only (stklos) (only (stklos)
make-external-function %make-callback
allocate-bytes allocate-bytes
free-bytes free-bytes
cpointer? cpointer?
@ -176,10 +176,9 @@
pointer-set-c-pointer! pointer-set-c-pointer!
pointer-ref-c-pointer pointer-ref-c-pointer
void?)) void?))
(export make-external-function (export ; calculate-struct-size-and-offsets
; calculate-struct-size-and-offsets
;struct-make ;struct-make
pffi:string-split foreign-c:string-split
c-bytevector-pointer-set! c-bytevector-pointer-set!
c-bytevector-pointer-ref)) c-bytevector-pointer-ref))
#;(tr7 #;(tr7
@ -208,8 +207,6 @@
c-bytevector-u8-ref c-bytevector-u8-ref
;; c-bytevector ;; c-bytevector
;pffi-pointer-set!;c-bytevector-u8-set! and so on
;pffi-pointer-get;c-bytevector-u8-ref and so on
native-endianness native-endianness
;; TODO Docs for all of these ;; TODO Docs for all of these
c-bytevector->address c-bytevector->address

73
foreign/c/main.scm
View File

@ -1,57 +1,8 @@
#;(cond-expand
(mosh (define pffi-init (lambda () #t)))
(chicken
(define-syntax pffi-init
(er-macro-transformer
(lambda (expr rename compare)
'(import (chicken foreign)
(chicken memory))
#t))))
(gambit #t)
#;(ypsilon
(define-syntax pffi-init
(syntax-rules ()
((_)
(import (ypsilon ffi)
(ypsilon c-types))))))
(else (define pffi-init (lambda () #t))))
(define pffi-type?
(lambda (object)
(if (equal? (size-of-type object) #f)
#f
#t)))
(define c-size-of (define c-size-of
(lambda (object) (lambda (object)
(size-of-type object) (size-of-type object)))
#;(cond ((pffi-struct? object) (pffi-struct-size object))
((pffi-type? object) (size-of-type object))
(else (error "Not pffi-struct, pffi-enum of pffi-type" object)))))
(define pffi-types (define foreign-c:string-split
'(int8
uint8
int16
uint16
int32
uint32
int64
uint64
char
unsigned-char
short
unsigned-short
int
unsigned-int
long
unsigned-long
float
double
pointer
void))
(define pffi:string-split
(lambda (str mark) (lambda (str mark)
(let* ((str-l (string->list str)) (let* ((str-l (string->list str))
(res (list)) (res (list))
@ -69,9 +20,9 @@
res))) res)))
(cond-expand (cond-expand
(gambit #t) ; Defined in pffi/gambit.scm (gambit #t) ; Defined in gambit.scm
(chicken #t) ; Defined in pffi/chicken.scm (chicken #t) ; Defined in chicken.scm
(cyclone #t) ; Defined in pffi/cyclone.scm (cyclone #t) ; Defined in cyclone.scm
(else (else
(define-syntax define-c-library (define-syntax define-c-library
(syntax-rules () (syntax-rules ()
@ -95,8 +46,8 @@
(cond-expand (cond-expand
(windows (windows
(append (append
(if (get-environment-variable "PFFI_LOAD_PATH") (if (get-environment-variable "FOREIGN_C_LOAD_PATH")
(pffi:string-split (get-environment-variable "PFFI_LOAD_PATH") #\;) (foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\;)
(list)) (list))
(if (get-environment-variable "SYSTEM") (if (get-environment-variable "SYSTEM")
(list (get-environment-variable "SYSTEM")) (list (get-environment-variable "SYSTEM"))
@ -115,15 +66,15 @@
(list)) (list))
(list ".") (list ".")
(if (get-environment-variable "PATH") (if (get-environment-variable "PATH")
(pffi:string-split (get-environment-variable "PATH") #\;) (foreign-c:string-split (get-environment-variable "PATH") #\;)
(list)) (list))
(if (get-environment-variable "PWD") (if (get-environment-variable "PWD")
(list (get-environment-variable "PWD")) (list (get-environment-variable "PWD"))
(list)))) (list))))
(else (else
(append (append
(if (get-environment-variable "PFFI_LOAD_PATH") (if (get-environment-variable "FOREIGN_C_LOAD_PATH")
(pffi:string-split (get-environment-variable "PFFI_LOAD_PATH") #\:) (foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\:)
(list)) (list))
; Guix ; Guix
(list (if (get-environment-variable "GUIX_ENVIRONMENT") (list (if (get-environment-variable "GUIX_ENVIRONMENT")
@ -132,7 +83,7 @@
"/run/current-system/profile/lib") "/run/current-system/profile/lib")
; Debian ; Debian
(if (get-environment-variable "LD_LIBRARY_PATH") (if (get-environment-variable "LD_LIBRARY_PATH")
(pffi:string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) (foreign-c:string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
(list)) (list))
(list (list
;;; x86-64 ;;; x86-64
@ -207,5 +158,5 @@
(exit 1)) (exit 1))
(cond-expand (cond-expand
(stklos shared-object) (stklos shared-object)
(else (pffi-shared-object-load shared-object (else (shared-object-load shared-object
`((additional-versions ,additional-versions))))))))))))) `((additional-versions ,additional-versions)))))))))))))

15
foreign/c/pointer.scm
View File

@ -8,7 +8,7 @@
"c" "c"
'((additional-versions ("0" "6")))))) '((additional-versions ("0" "6"))))))
(define-c-procedure pffi-pointer-allocate-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))
@ -17,7 +17,7 @@
(define-c-procedure c-strlen libc 'strlen 'int '(pointer)) (define-c-procedure c-strlen libc 'strlen 'int '(pointer))
(cond-expand (cond-expand
(chibi #t) ; FIXME ;(chibi #t) ; FIXME
(else (define make-c-bytevector (else (define make-c-bytevector
(lambda (k . byte) (lambda (k . byte)
(if (null? byte) (if (null? byte)
@ -29,7 +29,6 @@
(bytevector->c-bytevector (apply bytevector bytes)))) (bytevector->c-bytevector (apply bytevector bytes))))
(cond-expand (cond-expand
(chibi #t) ; FIXME
(else (define-c-procedure c-free libc 'free 'void '(pointer)))) (else (define-c-procedure c-free libc 'free 'void '(pointer))))
(define bytevector->c-bytevector (define bytevector->c-bytevector
@ -112,16 +111,18 @@
(native-endianness) (native-endianness)
(c-size-of 'pointer))))) (c-size-of 'pointer)))))
(cond-expand #;(cond-expand
(kawa #t) ; Defined in kawa.scm (kawa #t) ; Defined in kawa.scm
(chibi #t)
(else (else
(define c-bytevector-u8-set! (define c-bytevector-u8-set!
(lambda (c-bytevector k byte) (lambda (c-bytevector k byte)
(let ((address (c-memset-pointer->address c-bytevector 0 0))) (c-memset-address (+ (c-memset-pointer->address c-bytevector 0 0) k)
(c-memset-address (+ address k) byte 1)))))) byte
1)))))
(cond-expand (cond-expand
(kawa #t) ; Defined in kawa.scm ;(kawa #t) ; Defined in kawa.scm
(else (define-syntax call-with-address-of-c-bytevector (else (define-syntax call-with-address-of-c-bytevector
(syntax-rules () (syntax-rules ()
((_ input-pointer thunk) ((_ input-pointer thunk)

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

@ -19,18 +19,15 @@
((eq? type 'float) (size-of-float)) ((eq? type 'float) (size-of-float))
((eq? type 'double) (size-of-double)) ((eq? type 'double) (size-of-double))
((eq? type 'pointer) (size-of-pointer)) ((eq? type 'pointer) (size-of-pointer))
((eq? type 'string) (size-of-pointer)) ((eq? type 'pointer-address) (size-of-pointer))
((eq? type 'struct) (size-of-pointer))
((eq? type 'callback) (size-of-pointer)) ((eq? type 'callback) (size-of-pointer))
((eq? type 'void) 0) ((eq? type 'void) 0)
(else #f)))) (else #f))))
(define pffi-shared-object-load (define shared-object-load
(lambda (path options) (lambda (path options)
(let ((shared-object (dlopen path RTLD-NOW)) (let ((shared-object (dlopen path RTLD-NOW))
(maybe-error (dlerror))) (maybe-error (dlerror)))
#;(when (not (pffi-pointer-null? maybe-error))
(error (c-bytevector->string maybe-error)))
shared-object))) shared-object)))
(define c-bytevector? (define c-bytevector?
@ -38,20 +35,14 @@
(or (equal? object #f) ; False can be null pointer (or (equal? object #f) ; False can be null pointer
(pointer? object)))) (pointer? object))))
(define make-c-bytevector #;(define c-free
(lambda (k . byte)
(if (null? byte)
(pointer-allocate k)
(bytevector->c-bytevector (make-bytevector k byte)))))
(define c-free
(lambda (pointer) (lambda (pointer)
(pointer-free pointer))) (pointer-free pointer)))
(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-u8-set! pointer-set-c-uint8_t!)
(define pffi-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))
@ -73,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 pffi-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))
@ -116,14 +107,14 @@
((equal? type 'float) 'float) ((equal? type 'float) 'float)
((equal? type 'double) 'double) ((equal? type 'double) 'double)
((equal? type 'pointer) '(maybe-null void*)) ((equal? type 'pointer) '(maybe-null void*))
((equal? type 'string) 'string) ((equal? type 'pointer-address) '(maybe-null void*))
((equal? type 'void) 'void) ((equal? type 'void) 'void)
((equal? type 'callback) '(maybe-null void*)) ((equal? type 'callback) '(maybe-null void*))
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))
;; define-c-procedure ;; define-c-procedure
(define pffi-type->libffi-type #;(define type->libffi-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) (get-ffi-type-int8)) (cond ((equal? type 'int8) (get-ffi-type-int8))
((equal? type 'uint8) (get-ffi-type-uint8)) ((equal? type 'uint8) (get-ffi-type-uint8))
@ -146,13 +137,40 @@
((equal? type 'double) (get-ffi-type-double)) ((equal? type 'double) (get-ffi-type-double))
((equal? type 'void) (get-ffi-type-void)) ((equal? type 'void) (get-ffi-type-void))
((equal? type 'pointer) (get-ffi-type-pointer)) ((equal? type 'pointer) (get-ffi-type-pointer))
((equal? type 'pointer-address) 1)
((equal? type 'callback) (get-ffi-type-pointer))))) ((equal? type 'callback) (get-ffi-type-pointer)))))
(define argument->pointer (define type->libffi-type
(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 argument->pointer
(lambda (value type) (lambda (value type)
(cond ((procedure? value) (scheme-procedure-to-pointer value)) (cond ((procedure? value) (scheme-procedure-to-pointer value))
(else (let ((pointer (make-c-bytevector (size-of-type type)))) (else (let ((pointer (pointer-allocate (size-of-type type))))
(pffi-pointer-set! pointer type 0 value) (pointer-set! pointer type 0 value)
pointer))))) pointer)))))
(define make-c-function (define make-c-function
@ -160,23 +178,16 @@
(dlerror) ;; Clean all previous errors (dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name)) (let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror))) (maybe-dlerror (dlerror)))
#;(when (not (pffi-pointer-null? maybe-dlerror))
(error (c-bytevector->string maybe-dlerror)))
(lambda arguments (lambda arguments
(let ((return-value (make-c-bytevector (let* ((return-pointer
(if (equal? return-type 'void)
0
(size-of-type return-type)))))
(internal-ffi-call (length argument-types) (internal-ffi-call (length argument-types)
(pffi-type->libffi-type return-type) (type->libffi-type return-type)
(map pffi-type->libffi-type argument-types) (map type->libffi-type argument-types)
c-function c-function
return-value (c-size-of return-type)
(map argument->pointer arguments)))
arguments (when (not (equal? return-type 'void))
argument-types)) (pointer-get return-pointer return-type 0)))))))
(cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0))))))))
(define-syntax define-c-procedure (define-syntax define-c-procedure
(syntax-rules () (syntax-rules ()
@ -191,7 +202,7 @@
(lambda (return-type argument-types procedure) (lambda (return-type argument-types procedure)
(scheme-procedure-to-pointer procedure))) (scheme-procedure-to-pointer procedure)))
(define-syntax pffi-define-callback (define-syntax define-c-callback
(syntax-rules () (syntax-rules ()
((_ scheme-name return-type argument-types procedure) ((_ scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name

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

@ -2,6 +2,7 @@
(c-system-include "stdint.h") (c-system-include "stdint.h")
(c-system-include "dlfcn.h") (c-system-include "dlfcn.h")
(c-system-include "stdio.h")
(c-system-include "ffi.h") (c-system-include "ffi.h")
;; c-size-of ;; c-size-of
@ -47,7 +48,7 @@
(define-c int (size-of-double size_of_double) ()) (define-c int (size-of-double size_of_double) ())
(define-c int (size-of-pointer size_of_pointer) ()) (define-c int (size-of-pointer size_of_pointer) ())
;; pffi-shared-object-load ;; shared-object-load
(define-c-const int (RTLD-NOW "RTLD_NOW")) (define-c-const int (RTLD-NOW "RTLD_NOW"))
(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 ())
@ -71,14 +72,14 @@
(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* pointer_address(struct sexp_struct* pointer) {
return (void*)&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*)))
;; pffi-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; }")
@ -128,7 +129,7 @@
(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*)))
;; pffi-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); }")
@ -237,28 +238,114 @@
(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
"int internal_ffi_prep_cif(unsigned int nargs, void* rtype, void* atypes[]) { "int internal_ffi_prep_cif(unsigned int nargs, void* rtype, void* atypes[]) {
printf(\"A1: %u, A2: %u, nargs: %u\\n\", &ffi_type_pointer, atypes[0], nargs); printf(\"A1: %u, A2: %u, nargs: %u\\n\", &ffi_type_pointer, atypes[0], nargs);
return ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes); return ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
}") }")
(define-c int (internal-ffi-prep-cif internal_ffi_prep_cif) (unsigned-int (pointer void*) (array void*))) ;(define-c int (internal-ffi-prep-cif internal_ffi_prep_cif) (unsigned-int (pointer void*) (array void*)))
(c-declare (c-declare
"void internal_ffi_call(unsigned int nargs, void* rtype, void** atypes, void* fn, void* rvalue, struct sexp_struct* avalues[]) { "void* internal_ffi_call(
ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes); unsigned int nargs,
unsigned int rtype,
unsigned int atypes[],
void* fn,
unsigned int rvalue_size,
struct sexp_struct* avalues[])
{
ffi_type* c_atypes[nargs];
void* temps[nargs];
void* c_avalues[nargs]; void* c_avalues[nargs];
for(int i = 0; i < nargs; i++) { for(int i = 0; i < nargs; i++) {
c_avalues[i] = sexp_cpointer_value(avalues[i]); void* arg = NULL;
switch(atypes[i]) {
//case 1: c_atypes[i] = &ffi_type_sint8; arg = sexp_sint_value(avalues[i]); break;
case 2:
c_atypes[i] = &ffi_type_uint8;
temps[i] = sexp_uint_value(avalues[i]);
c_avalues[i] = &temps[i];
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:
c_atypes[i] = &ffi_type_uint64;
temps[i] = sexp_uint_value(avalues[i]);
c_avalues[i] = &temps[i];
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:
c_atypes[i] = &ffi_type_sint;
temps[i] = sexp_sint_value(avalues[i]);
c_avalues[i] = &temps[i];
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:
c_atypes[i] = &ffi_type_pointer;
c_avalues[i] = &sexp_cpointer_value(avalues[i]);
//printf(\"Pointer value: %s\\n\", sexp_cpointer_maybe_null_value(avalues[i]));
break;
default:
printf(\"Undefined argument type integer: %i, index: %i\\n\", atypes[i], i);
//c_avalues[i] = sexp_cpointer_value(avalues[i]);
break;
} }
}
ffi_type* c_rtype = &ffi_type_void;
switch(rtype) {
case 1: c_rtype = &ffi_type_sint8; break;
case 2: c_rtype = &ffi_type_uint8; break;
case 3: c_rtype = &ffi_type_sint16; break;
case 4: c_rtype = &ffi_type_uint16; break;
case 5: c_rtype = &ffi_type_sint32; break;
case 6: c_rtype = &ffi_type_uint32; break;
case 7: c_rtype = &ffi_type_sint64; break;
case 8: c_rtype = &ffi_type_uint64; break;
case 9: c_rtype = &ffi_type_schar; break;
case 10: c_rtype = &ffi_type_uchar; break;
case 11: c_rtype = &ffi_type_sshort; break;
case 12: c_rtype = &ffi_type_ushort; break;
case 13: c_rtype = &ffi_type_sint; break;
case 14: c_rtype = &ffi_type_uint; break;
case 15: c_rtype = &ffi_type_slong; break;
case 16: c_rtype = &ffi_type_ulong; break;
case 17: c_rtype = &ffi_type_float; break;
case 18: c_rtype = &ffi_type_double; break;
case 19: c_rtype = &ffi_type_void; break;
case 20: c_rtype = &ffi_type_pointer; break;
default:
printf(\"Undefined return type: %i\\n\", rtype);
c_rtype = &ffi_type_pointer;
break;
}
int r = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, c_rtype, c_atypes);
void* rvalue = malloc(rvalue_size);
ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues); ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues);
return rvalue;
}") }")
(define-c void (define-c (maybe-null pointer void*)
(internal-ffi-call internal_ffi_call) (internal-ffi-call internal_ffi_call)
(unsigned-int (unsigned-int
unsigned-int
(array unsigned-int)
(pointer void*) (pointer void*)
(array void*) unsigned-int
(pointer void*)
(pointer void*)
(array sexp))) (array sexp)))
(c-declare (c-declare

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

@ -169,7 +169,7 @@
(lambda (c-bytevector k) (lambda (c-bytevector k)
(pointer-u8-ref (pointer+ c-bytevector k)))) (pointer-u8-ref (pointer+ c-bytevector k))))
#;(define c-bytevector-u8-set! (define c-bytevector-u8-set!
(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)))

176
foreign/c/primitives/cyclone.scm
View File

@ -1,4 +1,4 @@
(define pffi-type->native-type (define type->native-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) int) (cond ((equal? type 'int8) int)
((equal? type 'uint8) int) ((equal? type 'uint8) int)
@ -21,7 +21,7 @@
((equal? type 'pointer) opaque) ((equal? type 'pointer) opaque)
((equal? type 'void) c-void) ((equal? type 'void) c-void)
((equal? type 'callback) opaque) ((equal? type 'callback) opaque)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "type->native-type -- No such type" type)))))
(define c-bytevector? (define c-bytevector?
(lambda (object) (lambda (object)
@ -30,7 +30,7 @@
(define-syntax define-c-procedure (define-syntax define-c-procedure
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let* ((pffi-type->native-type (let* ((type->native-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) 'int) (cond ((equal? type 'int8) 'int)
((equal? type 'uint8) 'int) ((equal? type 'uint8) 'int)
@ -53,15 +53,15 @@
((equal? type 'pointer) 'opaque) ((equal? type 'pointer) 'opaque)
((equal? type 'void) 'c-void) ((equal? type 'void) 'c-void)
((equal? type 'callback) 'opaque) ((equal? type 'callback) 'opaque)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "type->native-type -- No such type" type)))))
(scheme-name (cadr expr)) (scheme-name (cadr expr))
(c-name (symbol->string (car (cdr (car (cdr (cdr (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))))))))) (return-type (type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
(argument-types (argument-types
(let ((types (cadr (car (cdr (cdr (cdr (cdr (cdr expr))))))))) (let ((types (cadr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
(if (null? types) (if (null? types)
'() '()
(map pffi-type->native-type types))))) (map type->native-type types)))))
(if (null? argument-types) (if (null? argument-types)
`(c-define ,scheme-name ,return-type ,c-name) `(c-define ,scheme-name ,return-type ,c-name)
`(c-define ,scheme-name `(c-define ,scheme-name
@ -69,7 +69,7 @@
(define define-c-callback (define define-c-callback
(lambda (scheme-name return-type argument-types procedure) (lambda (scheme-name return-type argument-types procedure)
(error "pffi-define-callback not yet implemented on Cyclone"))) (error "define-callback not yet implemented on Cyclone")))
(define size-of-type (define size-of-type
(lambda (type) (lambda (type)
@ -93,12 +93,12 @@
((equal? type 'double) (c-value "sizeof(double)" int)) ((equal? type 'double) (c-value "sizeof(double)" int))
((equal? type 'pointer) (c-value "sizeof(void*)" int))))) ((equal? type 'pointer) (c-value "sizeof(void*)" int)))))
(define-c pffi-pointer-address (define-c pointer-address
"(void *data, int argc, closure _, object k, object pointer)" "(void *data, int argc, closure _, object k, object pointer)"
"make_c_opaque(opq, &(void*)opaque_ptr(pointer)); "make_c_opaque(opq, &(void*)opaque_ptr(pointer));
return_closcall1(data, k, &opq);") return_closcall1(data, k, &opq);")
(define pffi-pointer-null (define pointer-null
(lambda () (lambda ()
(make-opaque))) (make-opaque)))
@ -107,9 +107,9 @@
((_ scheme-name headers object-name options) ((_ scheme-name headers object-name options)
(begin (begin
(define scheme-name #t) (define scheme-name #t)
(pffi-shared-object-load headers))))) (shared-object-load headers)))))
(define-syntax pffi-shared-object-load (define-syntax shared-object-load
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let* ((headers (cadr (cadr expr))) (let* ((headers (cadr (cadr expr)))
@ -119,254 +119,254 @@
headers))) headers)))
`(,@includes))))) `(,@includes)))))
(define pffi-pointer-null? (define pointer-null?
(lambda (pointer) (lambda (pointer)
(and (opaque? pointer) (and (opaque? pointer)
(opaque-null? pointer)))) (opaque-null? pointer))))
(define-c pffi-pointer-int8-set! (define-c pointer-int8-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-uint8-set! (define-c pointer-uint8-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-int16-set! (define-c pointer-int16-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-uint16-set! (define-c pointer-uint16-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-int32-set! (define-c pointer-int32-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-uint32-set! (define-c pointer-uint32-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-int64-set! (define-c pointer-int64-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-uint64-set! (define-c pointer-uint64-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-char-set! (define-c pointer-char-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"char* p = opaque_ptr(pointer) + obj_obj2int(offset); "char* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2char(value); *p = obj_obj2char(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-short-set! (define-c pointer-short-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"short* p = opaque_ptr(pointer) + obj_obj2int(offset); "short* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-unsigned-short-set! (define-c pointer-unsigned-short-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset); "unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-int-set! (define-c pointer-int-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"int* p = opaque_ptr(pointer) + obj_obj2int(offset); "int* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-unsigned-int-set! (define-c pointer-unsigned-int-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset); "unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-long-set! (define-c pointer-long-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"long* p = opaque_ptr(pointer) + obj_obj2int(offset); "long* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-unsigned-long-set! (define-c pointer-unsigned-long-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset); "unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = obj_obj2int(value); *p = obj_obj2int(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-float-set! (define-c pointer-float-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"float* p = opaque_ptr(pointer) + obj_obj2int(offset); "float* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = double_value(value); *p = double_value(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-double-set! (define-c pointer-double-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"double* p = opaque_ptr(pointer) + obj_obj2int(offset); "double* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = double_value(value); *p = double_value(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pffi-pointer-pointer-set! (define-c pointer-pointer-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)" "(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"uintptr_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "uintptr_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = (uintptr_t)&opaque_ptr(value); *p = (uintptr_t)&opaque_ptr(value);
return_closcall1(data, k, make_boolean(boolean_t));") return_closcall1(data, k, make_boolean(boolean_t));")
(define pffi-pointer-set! (define pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(cond (cond
((equal? type 'int8) (pffi-pointer-int8-set! pointer offset value)) ((equal? type 'int8) (pointer-int8-set! pointer offset value))
((equal? type 'uint8) (pffi-pointer-uint8-set! pointer offset value)) ((equal? type 'uint8) (pointer-uint8-set! pointer offset value))
((equal? type 'int16) (pffi-pointer-int16-set! pointer offset value)) ((equal? type 'int16) (pointer-int16-set! pointer offset value))
((equal? type 'uint16) (pffi-pointer-uint16-set! pointer offset value)) ((equal? type 'uint16) (pointer-uint16-set! pointer offset value))
((equal? type 'int32) (pffi-pointer-int32-set! pointer offset value)) ((equal? type 'int32) (pointer-int32-set! pointer offset value))
((equal? type 'uint32) (pffi-pointer-uint32-set! pointer offset value)) ((equal? type 'uint32) (pointer-uint32-set! pointer offset value))
((equal? type 'int64) (pffi-pointer-int64-set! pointer offset value)) ((equal? type 'int64) (pointer-int64-set! pointer offset value))
((equal? type 'uint64) (pffi-pointer-uint64-set! pointer offset value)) ((equal? type 'uint64) (pointer-uint64-set! pointer offset value))
((equal? type 'char) (pffi-pointer-char-set! pointer offset value)) ((equal? type 'char) (pointer-char-set! pointer offset value))
((equal? type 'short) (pffi-pointer-short-set! pointer offset value)) ((equal? type 'short) (pointer-short-set! pointer offset value))
((equal? type 'unsigned-short) (pffi-pointer-unsigned-short-set! pointer offset value)) ((equal? type 'unsigned-short) (pointer-unsigned-short-set! pointer offset value))
((equal? type 'int) (pffi-pointer-int-set! pointer offset value)) ((equal? type 'int) (pointer-int-set! pointer offset value))
((equal? type 'unsigned-int) (pffi-pointer-unsigned-int-set! pointer offset value)) ((equal? type 'unsigned-int) (pointer-unsigned-int-set! pointer offset value))
((equal? type 'long) (pffi-pointer-long-set! pointer offset value)) ((equal? type 'long) (pointer-long-set! pointer offset value))
((equal? type 'unsigned-long) (pffi-pointer-unsigned-long-set! pointer offset value)) ((equal? type 'unsigned-long) (pointer-unsigned-long-set! pointer offset value))
((equal? type 'float) (pffi-pointer-float-set! pointer offset value)) ((equal? type 'float) (pointer-float-set! pointer offset value))
((equal? type 'double) (pffi-pointer-double-set! pointer offset value)) ((equal? type 'double) (pointer-double-set! pointer offset value))
((equal? type 'pointer) (pffi-pointer-pointer-set! pointer offset value))))) ((equal? type 'pointer) (pointer-pointer-set! pointer offset value)))))
(define-c pffi-pointer-int8-get (define-c pointer-int8-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-uint8-get (define-c pointer-uint8-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-int16-get (define-c pointer-int16-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-uint16-get (define-c pointer-uint16-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-int32-get (define-c pointer-int32-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-uint32-get (define-c pointer-uint32-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-int64-get (define-c pointer-int64-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-uint64-get (define-c pointer-uint64-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); "uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-char-get (define-c pointer-char-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"char* p = opaque_ptr(pointer) + obj_obj2int(offset); "char* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_char2obj(*p));") return_closcall1(data, k, obj_char2obj(*p));")
(define-c pffi-pointer-short-get (define-c pointer-short-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"short* p = opaque_ptr(pointer) + obj_obj2int(offset); "short* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-unsigned-short-get (define-c pointer-unsigned-short-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset); "unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-int-get (define-c pointer-int-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"int* p = opaque_ptr(pointer) + obj_obj2int(offset); "int* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-unsigned-int-get (define-c pointer-unsigned-int-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset); "unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-long-get (define-c pointer-long-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"long* p = opaque_ptr(pointer) + obj_obj2int(offset); "long* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-unsigned-long-get (define-c pointer-unsigned-long-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset); "unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset);
return_closcall1(data, k, obj_int2obj(*p));") return_closcall1(data, k, obj_int2obj(*p));")
(define-c pffi-pointer-float-get (define-c pointer-float-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"float* p = opaque_ptr(pointer) + obj_obj2int(offset); "float* p = opaque_ptr(pointer) + obj_obj2int(offset);
alloca_double(d, *p); alloca_double(d, *p);
return_closcall1(data, k, d);") return_closcall1(data, k, d);")
(define-c pffi-pointer-double-get (define-c pointer-double-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"double* p = opaque_ptr(pointer) + obj_obj2int(offset); "double* p = opaque_ptr(pointer) + obj_obj2int(offset);
alloca_double(d, *p); alloca_double(d, *p);
return_closcall1(data, k, d);") return_closcall1(data, k, d);")
(define-c pffi-pointer-pointer-get (define-c pointer-pointer-get
"(void *data, int argc, closure _, object k, object pointer, object offset)" "(void *data, int argc, closure _, object k, object pointer, object offset)"
"make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset)); "make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset));
return_closcall1(data, k, &opq);") return_closcall1(data, k, &opq);")
#;(define c-bytevector-u8-set! pffi-pointer-uint8-set!) #;(define c-bytevector-u8-set! pointer-uint8-set!)
(define c-bytevector-u8-ref pffi-pointer-uint8-get) (define c-bytevector-u8-ref pointer-uint8-get)
(define pffi-pointer-get (define pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(cond (cond
((equal? type 'int8) (pffi-pointer-int8-get pointer offset)) ((equal? type 'int8) (pointer-int8-get pointer offset))
((equal? type 'uint8) (pffi-pointer-uint8-get pointer offset)) ((equal? type 'uint8) (pointer-uint8-get pointer offset))
((equal? type 'int16) (pffi-pointer-int16-get pointer offset)) ((equal? type 'int16) (pointer-int16-get pointer offset))
((equal? type 'uint16) (pffi-pointer-uint16-get pointer offset)) ((equal? type 'uint16) (pointer-uint16-get pointer offset))
((equal? type 'int32) (pffi-pointer-int32-get pointer offset)) ((equal? type 'int32) (pointer-int32-get pointer offset))
((equal? type 'uint32) (pffi-pointer-uint32-get pointer offset)) ((equal? type 'uint32) (pointer-uint32-get pointer offset))
((equal? type 'int64) (pffi-pointer-int64-get pointer offset)) ((equal? type 'int64) (pointer-int64-get pointer offset))
((equal? type 'uint64) (pffi-pointer-uint64-get pointer offset)) ((equal? type 'uint64) (pointer-uint64-get pointer offset))
((equal? type 'char) (pffi-pointer-char-get pointer offset)) ((equal? type 'char) (pointer-char-get pointer offset))
((equal? type 'short) (pffi-pointer-short-get pointer offset)) ((equal? type 'short) (pointer-short-get pointer offset))
((equal? type 'unsigned-short) (pffi-pointer-unsigned-short-get pointer offset)) ((equal? type 'unsigned-short) (pointer-unsigned-short-get pointer offset))
((equal? type 'int) (pffi-pointer-int-get pointer offset)) ((equal? type 'int) (pointer-int-get pointer offset))
((equal? type 'unsigned-int) (pffi-pointer-unsigned-int-get pointer offset)) ((equal? type 'unsigned-int) (pointer-unsigned-int-get pointer offset))
((equal? type 'long) (pffi-pointer-long-get pointer offset)) ((equal? type 'long) (pointer-long-get pointer offset))
((equal? type 'unsigned-long) (pffi-pointer-unsigned-long-get pointer offset)) ((equal? type 'unsigned-long) (pointer-unsigned-long-get pointer offset))
((equal? type 'float) (pffi-pointer-float-get pointer offset)) ((equal? type 'float) (pointer-float-get pointer offset))
((equal? type 'double) (pffi-pointer-double-get pointer offset)) ((equal? type 'double) (pointer-double-get pointer offset))
((equal? type 'pointer) (pffi-pointer-pointer-get pointer offset))))) ((equal? type 'pointer) (pointer-pointer-get pointer offset)))))

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

@ -1,16 +1,16 @@
(define-module foreign.c.primitives.gauche (define-module foreign.c.primitives.gauche
(export size-of-type (export size-of-type
pffi-shared-object-load shared-object-load
c-bytevector-u8-set! c-bytevector-u8-set!
c-bytevector-u8-ref c-bytevector-u8-ref
;pffi-pointer-null ;pointer-null
;pffi-pointer-null? ;pointer-null?
make-c-bytevector make-c-bytevector
;pffi-pointer-address ;pointer-address
c-bytevector? c-bytevector?
c-free c-free
pffi-pointer-set! pointer-set!
pffi-pointer-get pointer-get
define-c-procedure define-c-procedure
define-c-callback)) define-c-callback))
@ -42,7 +42,7 @@
((equal? type 'pointer) (size-of-pointer)) ((equal? type 'pointer) (size-of-pointer))
((equal? type 'void) (size-of-void))))) ((equal? type 'void) (size-of-void)))))
(define pffi-shared-object-load #;(define shared-object-load
(lambda (path options) (lambda (path options)
(shared-object-load path))) (shared-object-load path)))
@ -58,10 +58,10 @@
(lambda (pointer) (lambda (pointer)
(pointer-free pointer))) (pointer-free pointer)))
;(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 pffi-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))
@ -83,7 +83,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 pffi-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))
@ -134,7 +134,7 @@
(lambda (value type) (lambda (value type)
(cond ((procedure? value) (scheme-procedure-to-pointer value)) (cond ((procedure? value) (scheme-procedure-to-pointer value))
(else (let ((pointer (make-c-bytevector (size-of-type type)))) (else (let ((pointer (make-c-bytevector (size-of-type type))))
(pffi-pointer-set! pointer type 0 value) (pointer-set! pointer type 0 value)
pointer))))) pointer)))))
(define make-c-function (define make-c-function
@ -142,7 +142,7 @@
(dlerror) ;; Clean all previous errors (dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name)) (let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror))) (maybe-dlerror (dlerror)))
#;(when (not (pffi-pointer-null? maybe-dlerror)) #;(when (not (pointer-null? maybe-dlerror))
(error (c-bytevector->string maybe-dlerror))) (error (c-bytevector->string maybe-dlerror)))
(lambda arguments (lambda arguments
(let ((return-value (make-c-bytevector (let ((return-value (make-c-bytevector
@ -158,7 +158,7 @@
arguments arguments
argument-types)) argument-types))
(cond ((not (equal? return-type 'void)) (cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0)))))))) (pointer-get return-value return-type 0))))))))
(define-syntax define-c-procedure (define-syntax define-c-procedure
(syntax-rules () (syntax-rules ()

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

@ -23,7 +23,7 @@
(define-cproc size-of-string () size_of_string) (define-cproc size-of-string () size_of_string)
(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>) 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)

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

@ -1,4 +1,4 @@
(define pffi-type->native-type (define type->native-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) int8) (cond ((equal? type 'int8) int8)
((equal? type 'uint8) uint8) ((equal? type 'uint8) uint8)
@ -34,29 +34,29 @@
(define scheme-name (define scheme-name
(foreign-library-function shared-object (foreign-library-function shared-object
(symbol->string c-name) (symbol->string c-name)
#:return-type (pffi-type->native-type return-type) #:return-type (type->native-type return-type)
#:arg-types (map pffi-type->native-type argument-types)))))) #:arg-types (map type->native-type argument-types))))))
(define-syntax define-c-callback (define-syntax define-c-callback
(syntax-rules () (syntax-rules ()
((_ scheme-name return-type argument-types procedure) ((_ scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name
(procedure->pointer (pffi-type->native-type return-type) (procedure->pointer (type->native-type return-type)
procedure procedure
(map pffi-type->native-type argument-types)))))) (map type->native-type argument-types))))))
(define size-of-type (define size-of-type
(lambda (type) (lambda (type)
(let ((native-type (pffi-type->native-type type))) (let ((native-type (type->native-type type)))
(cond ((equal? native-type void) 0) (cond ((equal? native-type void) 0)
(native-type (sizeof native-type)) (native-type (sizeof native-type))
(else #f))))) (else #f)))))
(define pffi-shared-object-load (define shared-object-load
(lambda (path options) (lambda (path options)
(load-foreign-library path))) (load-foreign-library path)))
#;(define c-bytevector-u8-set! (define c-bytevector-u8-set!
(lambda (c-bytevector k byte) (lambda (c-bytevector k byte)
(let ((p (pointer->bytevector c-bytevector (+ k 100)))) (let ((p (pointer->bytevector c-bytevector (+ k 100))))
(bytevector-u8-set! p k byte)))) (bytevector-u8-set! p k byte))))
@ -66,7 +66,7 @@
(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 pffi-pointer-set! (define pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(let ((p (pointer->bytevector pointer (+ offset 100)))) (let ((p (pointer->bytevector pointer (+ offset 100))))
(cond ((equal? type 'int8) (bytevector-s8-set! p offset value)) (cond ((equal? type 'int8) (bytevector-s8-set! p offset value))
@ -88,7 +88,7 @@
((equal? type 'double) (bytevector-ieee-double-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))))))) ((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))))))
(define pffi-pointer-get (define pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(let ((p (pointer->bytevector pointer (+ offset 100)))) (let ((p (pointer->bytevector pointer (+ offset 100))))
(cond ((equal? type 'int8) (bytevector-s8-ref p offset)) (cond ((equal? type 'int8) (bytevector-s8-ref p offset))

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

@ -26,7 +26,7 @@
(java.lang.Char value)) (java.lang.Char value))
(else value)))) (else value))))
(define pffi-type->native-type (define type->native-type
(lambda (type) (lambda (type)
(cond (cond
((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) ((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
@ -71,10 +71,10 @@
'orElseThrow) 'orElseThrow)
(if (equal? return-type 'void) (if (equal? return-type 'void)
(apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid) (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)
(map pffi-type->native-type argument-types)) (map type->native-type argument-types))
(apply (class-methods java.lang.foreign.FunctionDescriptor 'of) (apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
(pffi-type->native-type return-type) (type->native-type return-type)
(map pffi-type->native-type argument-types)))) (map type->native-type argument-types))))
'invokeWithArguments 'invokeWithArguments
(map value->object vals argument-types))))))) (map value->object vals argument-types)))))))
@ -103,10 +103,10 @@
(let ((function-descriptor (let ((function-descriptor
(if (equal? return-type 'void) (if (equal? return-type 'void)
(apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid) (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)
(map pffi-type->native-type argument-types)) (map type->native-type argument-types))
(apply (class-methods java.lang.foreign.FunctionDescriptor 'of) (apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
(pffi-type->native-type return-type) (type->native-type return-type)
(map pffi-type->native-type argument-types))))) (map type->native-type argument-types)))))
(write function-descriptor) (write function-descriptor)
(newline) (newline)
(write (invoke function-descriptor 'getClass)) (write (invoke function-descriptor 'getClass))
@ -125,7 +125,7 @@
(define size-of-type (define size-of-type
(lambda (type) (lambda (type)
(let ((native-type (pffi-type->native-type type))) (let ((native-type (type->native-type type)))
(if native-type (if native-type
(invoke native-type 'byteAlignment) (invoke native-type 'byteAlignment)
#f)))) #f))))
@ -134,7 +134,7 @@
(lambda () (lambda ()
(static-field java.lang.foreign.MemorySegment 'NULL))) (static-field java.lang.foreign.MemorySegment 'NULL)))
(define pffi-shared-object-load (define shared-object-load
(lambda (path options) (lambda (path options)
(let* ((library-file (make java.io.File path)) (let* ((library-file (make java.io.File path))
(file-name (invoke library-file 'getName)) (file-name (invoke library-file 'getName))
@ -170,31 +170,31 @@
u8-value-layout u8-value-layout
k))) k)))
(define pffi-pointer-set! (define pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
'set 'set
(pffi-type->native-type type) (type->native-type type)
offset offset
(if (equal? type 'char) (if (equal? type 'char)
(char->integer value) (char->integer value)
value)))) value))))
(define pffi-pointer-get (define pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(let ((r (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) (let ((r (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
'get 'get
(pffi-type->native-type type) (type->native-type type)
offset))) offset)))
(if (equal? type 'char) (if (equal? type 'char)
(integer->char r) (integer->char r)
r)))) r))))
(define-syntax call-with-address-of-c-bytevector #;(define-syntax call-with-address-of-c-bytevector
(syntax-rules () (syntax-rules ()
((_ 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))))
(pffi-pointer-set! address-pointer 'pointer 0 input-pointer) (pointer-set! address-pointer 'pointer 0 input-pointer)
(apply thunk (list address-pointer)) (apply thunk (list address-pointer))
(set! input-pointer (pffi-pointer-get address-pointer 'pointer 0)) (set! input-pointer (pointer-get address-pointer 'pointer 0))
(c-free address-pointer))))) (c-free address-pointer)))))

4
foreign/c/primitives/larceny.scm
View File

@ -32,7 +32,7 @@
;(void*? object) ;(void*? object)
(number? object))) (number? object)))
(define pffi-shared-object-load (define shared-object-load
(lambda (headers path . options) (lambda (headers path . options)
(foreign-file path))) (foreign-file path)))
@ -51,7 +51,7 @@
return-type return-type
argument-types))))) argument-types)))))
(define-syntax pffi-define-callback (define-syntax define-c-callback
(syntax-rules () (syntax-rules ()
((_ scheme-name return-type argument-types procedure) ((_ scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name

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

@ -19,12 +19,11 @@
((eq? type 'float) size-of-float) ((eq? type 'float) size-of-float)
((eq? type 'double) size-of-double) ((eq? type 'double) size-of-double)
((eq? type 'pointer) size-of-pointer) ((eq? type 'pointer) size-of-pointer)
((eq? type 'string) size-of-pointer)
((eq? type 'callback) size-of-pointer) ((eq? type 'callback) size-of-pointer)
((eq? type 'void) 0) ((eq? type 'void) 0)
(else #f)))) (else #f))))
(define pffi-shared-object-load (define shared-object-load
(lambda (path options) (lambda (path options)
(open-shared-library path))) (open-shared-library path)))
@ -32,10 +31,10 @@
(lambda (object) (lambda (object)
(pointer? object))) (pointer? object)))
;(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 pffi-pointer-set! #;(define pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8! pointer offset value)) (cond ((equal? type 'int8) (pointer-set-c-int8! pointer offset value))
((equal? type 'uint8) (pointer-set-c-uint8! pointer offset value)) ((equal? type 'uint8) (pointer-set-c-uint8! pointer offset value))
@ -57,7 +56,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 pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(cond ((equal? type 'int8) (pointer-ref-c-int8 pointer offset)) (cond ((equal? type 'int8) (pointer-ref-c-int8 pointer offset))
((equal? type 'uint8) (pointer-ref-c-uint8 pointer offset)) ((equal? type 'uint8) (pointer-ref-c-uint8 pointer offset))
@ -79,7 +78,7 @@
((equal? type 'void) (pointer-ref-c-pointer pointer offset)) ((equal? type 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
(define pffi-type->native-type (define type->native-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) 'int8_t) (cond ((equal? type 'int8) 'int8_t)
((equal? type 'uint8) 'uint8_t) ((equal? type 'uint8) 'uint8_t)
@ -102,21 +101,21 @@
((equal? type 'pointer) 'void*) ((equal? type 'pointer) 'void*)
((equal? type 'void) 'void) ((equal? type 'void) 'void)
((equal? type 'callback) 'void*) ((equal? type 'callback) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "type->native-type -- No such type" type)))))
(define-syntax define-c-procedure (define-syntax define-c-procedure
(syntax-rules () (syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
(make-c-function shared-object (make-c-function shared-object
(pffi-type->native-type return-type) (type->native-type return-type)
c-name c-name
(map pffi-type->native-type argument-types)))))) (map type->native-type argument-types))))))
(define-syntax define-c-callback (define-syntax define-c-callback
(syntax-rules () (syntax-rules ()
((_ scheme-name return-type argument-types procedure) ((_ scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name
(make-c-callback (pffi-type->native-type return-type) (make-c-callback (type->native-type return-type)
(map pffi-type->native-type argument-types) (map type->native-type argument-types)
procedure))))) procedure)))))

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

@ -1,4 +1,4 @@
(define pffi-type->native-type (define type->native-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) _int8) (cond ((equal? type 'int8) _int8)
((equal? type 'uint8) _uint8) ((equal? type 'uint8) _uint8)
@ -33,25 +33,22 @@
(define scheme-name (define scheme-name
(get-ffi-obj c-name (get-ffi-obj c-name
shared-object shared-object
(_cprocedure (mlist->list (map pffi-type->native-type argument-types)) (_cprocedure (mlist->list (map type->native-type argument-types))
(pffi-type->native-type return-type))))))) (type->native-type return-type)))))))
(define-syntax define-c-callback (define-syntax define-c-callback
(syntax-rules () (syntax-rules ()
((pffi-define-callback scheme-name return-type argument-types procedure) ((_ scheme-name return-type argument-types procedure)
(define scheme-name (function-ptr procedure (define scheme-name (function-ptr procedure
(_cprocedure (_cprocedure
(mlist->list (map pffi-type->native-type argument-types)) (mlist->list (map type->native-type argument-types))
(pffi-type->native-type return-type))))))) (type->native-type return-type)))))))
(define size-of-type (define size-of-type
(lambda (type) (lambda (type)
(let ((native-type (pffi-type->native-type type))) (ctype-sizeof (type->native-type type))))
(if native-type
(ctype-sizeof native-type)
#f))))
(define pffi-shared-object-load (define shared-object-load
(lambda (path options) (lambda (path options)
(if (and (not (null? options)) (if (and (not (null? options))
(assoc 'additional-versions options)) (assoc 'additional-versions options))
@ -60,7 +57,7 @@
(list #f)))) (list #f))))
(ffi-lib path)))) (ffi-lib path))))
#;(define c-bytevector-u8-set! (define c-bytevector-u8-set!
(lambda (c-bytevector k byte) (lambda (c-bytevector k byte)
(ptr-set! c-bytevector _uint8 'abs k byte))) (ptr-set! c-bytevector _uint8 'abs k byte)))
@ -68,22 +65,31 @@
(lambda (c-bytevector k) (lambda (c-bytevector k)
(ptr-ref c-bytevector _uint8 'abs k))) (ptr-ref c-bytevector _uint8 'abs k)))
(define pffi-pointer-set! #;(define pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(ptr-set! pointer (ptr-set! pointer
(pffi-type->native-type type) (type->native-type type)
'abs 'abs
offset offset
(if (equal? type 'char) (if (equal? type 'char)
(char->integer value) (char->integer value)
value)))) value))))
(define pffi-pointer-get #;(define pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(let ((r (ptr-ref pointer (let ((r (ptr-ref pointer
(pffi-type->native-type type) (type->native-type type)
'abs 'abs
offset))) offset)))
(if (equal? type 'char) (if (equal? type 'char)
(integer->char r) (integer->char r)
r)))) r))))
#;(define-syntax call-with-address-of-c-bytevector
(syntax-rules ()
((_ input-pointer thunk)
(let ((address-pointer (make-c-bytevector (c-size-of 'pointer))))
(c-bytevector-pointer-set! address-pointer 0 input-pointer)
(apply thunk (list address-pointer))
(set! input-pointer (c-bytevector-pointer-ref address-pointer 0))
(c-free address-pointer)))))

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

@ -23,11 +23,11 @@
((eq? type 'callback) size-of-void*) ((eq? type 'callback) size-of-void*)
(else #f)))) (else #f))))
(define pffi-shared-object-load (define shared-object-load
(lambda (path options) (lambda (path options)
(open-shared-library path))) (open-shared-library path)))
(define pffi-type->native-type (define type->native-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) 'int8_t) (cond ((equal? type 'int8) 'int8_t)
((equal? type 'uint8) 'uint8_t) ((equal? type 'uint8) 'uint8_t)
@ -57,26 +57,26 @@
((_ scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
(make-c-function shared-object (make-c-function shared-object
(pffi-type->native-type return-type) (type->native-type return-type)
c-name c-name
(map pffi-type->native-type argument-types)))))) (map type->native-type argument-types))))))
(define-syntax define-c-callback (define-syntax define-c-callback
(syntax-rules () (syntax-rules ()
((_ scheme-name return-type argument-types procedure) ((_ scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name
(make-c-callback (pffi-type->native-type return-type) (make-c-callback (type->native-type return-type)
(map pffi-type->native-type argument-types) (map type->native-type argument-types)
procedure))))) procedure)))))
(define c-bytevector? (define c-bytevector?
(lambda (object) (lambda (object)
(pointer? object))) (pointer? object)))
;(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 pffi-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 +98,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 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))

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

@ -42,7 +42,7 @@
((equal? type 'int64) :long) ((equal? type 'int64) :long)
((equal? type 'uint64) :ulong) ((equal? type 'uint64) :ulong)
((equal? type 'char) :char) ((equal? type 'char) :char)
((equal? type 'unsigned-char) :uchar) ((equal? type 'unsigned-char) :char)
((equal? type 'short) :short) ((equal? type 'short) :short)
((equal? type 'unsigned-short) :ushort) ((equal? type 'unsigned-short) :ushort)
((equal? type 'int) :int) ((equal? type 'int) :int)
@ -62,9 +62,15 @@
(type->native-type return-type) (type->native-type return-type)
shared-object)))))) shared-object))))))
(define define-c-callback (define-syntax define-c-callback
(lambda () (syntax-rules ()
(error "Not implemented"))) ((_ scheme-name return-type argument-types procedure)
(define scheme-name
(%make-callback procedure
(map type->native-type argument-types)
(type->native-type return-type))
))))
; FIXME ; FIXME
(define size-of-type (define size-of-type
@ -89,7 +95,7 @@
((equal? type 'double) 8) ((equal? type 'double) 8)
((equal? type 'pointer) 8)))) ((equal? type 'pointer) 8))))
;(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 pffi-pointer-set! (define pffi-pointer-set!

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

@ -28,7 +28,7 @@
(lambda (object) (lambda (object)
(number? object))) (number? object)))
#;(define c-bytevector-u8-set! (define c-bytevector-u8-set!
(lambda (c-bytevector k byte) (lambda (c-bytevector k byte)
(bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k) (bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k)
(c-size-of 'uint8)) (c-size-of 'uint8))
@ -41,7 +41,7 @@
(c-size-of 'uint8)) (c-size-of 'uint8))
0))) 0)))
(define pffi-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 +64,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 pffi-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))
@ -87,7 +87,7 @@
((equal? type 'void) (bytevector-c-void*-ref bv 0)) ((equal? type 'void) (bytevector-c-void*-ref bv 0))
((equal? type 'pointer) (bytevector-c-void*-ref bv 0)))))) ((equal? type 'pointer) (bytevector-c-void*-ref bv 0))))))
(define pffi-shared-object-load (define shared-object-load
(lambda (path options) (lambda (path options)
(load-shared-object path))) (load-shared-object path)))
@ -114,7 +114,7 @@
((equal? ,type 'pointer) 'void*) ((equal? ,type 'pointer) 'void*)
((equal? ,type 'void) 'void) ((equal? ,type 'void) 'void)
;((equal? ,type 'callback) 'void*) ;((equal? ,type 'callback) 'void*)
(else (error "type->native-type -- No such pffi type" ,type)))) (else (error "type->native-type -- No such type" ,type))))
(define-macro (define-macro
(define-c-procedure scheme-name shared-object c-name return-type argument-types) (define-c-procedure scheme-name shared-object c-name return-type argument-types)
@ -142,7 +142,7 @@
((equal? type 'pointer) 'void*) ((equal? type 'pointer) 'void*)
((equal? type 'void) 'void) ((equal? type 'void) 'void)
((equal? type 'callback) 'void*) ((equal? type 'callback) 'void*)
(else (error "type->native-type -- No such pffi type" type)))))) (else (error "type->native-type -- No such type" type))))))
`(define ,scheme-name `(define ,scheme-name
(c-function ,(type->native-type (cadr return-type)) (c-function ,(type->native-type (cadr return-type))
,(cadr c-name) ,(cadr c-name)
@ -173,7 +173,7 @@
((equal? type 'pointer) 'void*) ((equal? type 'pointer) 'void*)
((equal? type 'void) 'void) ((equal? type 'void) 'void)
((equal? type 'callback) 'void*) ((equal? type 'callback) 'void*)
(else (error "type->native-type -- No such pffi type" type))))) (else (error "type->native-type -- No such type" type)))))
(native-return-type (type->native-type (cadr return-type))) (native-return-type (type->native-type (cadr return-type)))
(native-argument-types (map type->native-type (cadr argument-types)))) (native-argument-types (map type->native-type (cadr argument-types))))
`(define ,scheme-name `(define ,scheme-name

4
tests/addressof.scm
View File

@ -88,8 +88,12 @@
'(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)
(debug (c-bytevector-s32-native-ref input-pointer 0)) (debug (c-bytevector-s32-native-ref input-pointer 0))
(debug input-pointer)
(call-with-address-of-c-bytevector (call-with-address-of-c-bytevector
input-pointer input-pointer
(lambda (address) (lambda (address)

128
tests/primitives.scm
View File

@ -212,31 +212,19 @@
;; define-c-library ;; define-c-library
(print-header 'pffi-define-library) (print-header 'define-c-library)
(cond-expand (cond-expand
(windows (define-c-library libc-stdlib (windows (define-c-library libc
'("stdlib.h") '("stdio.h" "string.h")
"ucrtbase" "ucrtbase"
'((additional-versions ("0" "6"))))) '((additional-versions ("0" "6")))))
(else (define-c-library libc-stdlib (else (define-c-library libc
'("stdlib.h") '("stdio.h" "string.h")
"c" "c"
'((additional-versions ("0" "6")))))) '((additional-versions ("0" "6"))))))
(debug libc-stdlib) (debug libc)
(cond-expand
(windows (define-c-library libc-stdio
'("stdio.h")
"ucrtbase"
'((additional-versions ("0" "6")))))
(else (define-c-library libc-stdio
'("stdio.h")
"c"
'((additional-versions ("0" "6"))))))
(debug libc-stdio)
(define-c-library c-testlib (define-c-library c-testlib
'("libtest.h") '("libtest.h")
@ -245,43 +233,15 @@
(debug c-testlib) (debug c-testlib)
;; define-c-procedure ;; define-c-procedure 1
(print-header "define-c-procedure 1")
(print-header 'define-c-procedure) (define-c-procedure c-abs libc 'abs 'int '(int))
(define-c-procedure c-abs libc-stdlib 'abs 'int '(int))
(debug c-abs) (debug c-abs)
(define absoluted (c-abs -2)) (define absoluted (c-abs -2))
(debug absoluted) (debug absoluted)
(assert = absoluted 2) (assert = absoluted 2)
(define-c-procedure c-puts libc-stdlib 'puts 'int '(pointer))
(debug c-puts)
(define chars-written (c-puts (string->c-utf8 "puts: Hello from testing, I am C function puts")))
(debug chars-written)
(assert = chars-written 47)
(define-c-procedure c-atoi libc-stdlib 'atoi 'int '(pointer))
(assert = (c-atoi (string->c-utf8 "100")) 100)
(define-c-procedure c-fopen libc-stdio 'fopen 'pointer '(pointer pointer))
(define output-file (c-fopen (string->c-utf8 "testfile.test")
(string->c-utf8 "w")))
(debug output-file)
(define-c-procedure c-fprintf libc-stdio 'fprintf 'int '(pointer pointer))
(define characters-written
(c-fprintf output-file (string->c-utf8 "Hello world")))
(debug characters-written)
(assert equal? (= characters-written 11) #t)
(define-c-procedure c-fclose libc-stdio 'fclose 'int '(pointer))
(define closed-status (c-fclose output-file))
(debug closed-status)
(assert equal? (= closed-status 0) #t)
(assert equal? (file-exists? "testfile.test") #t)
(assert equal? (string=? (with-input-from-file "testfile.test"
(lambda () (read-line)))
"Hello world") #t)
(define-c-procedure c-takes-no-args c-testlib 'takes_no_args 'void '()) (define-c-procedure c-takes-no-args c-testlib 'takes_no_args 'void '())
(debug c-takes-no-args) (debug c-takes-no-args)
(c-takes-no-args) (c-takes-no-args)
@ -291,26 +251,82 @@
(define takes-no-args-returns-int-result (c-takes-no-args-returns-int)) (define takes-no-args-returns-int-result (c-takes-no-args-returns-int))
(assert equal? (= takes-no-args-returns-int-result 0) #t) (assert equal? (= takes-no-args-returns-int-result 0) #t)
;; c-bytevector? ;; make-c-bytevector and c-bytevector?
(print-header "make-c-bytevector and c-bytevector?")
(print-header 'c-bytevector?) (define bytes (make-c-bytevector 100))
(debug bytes)
(assert equal? (c-bytevector? bytes) #t)
(define is-pointer (make-c-bytevector 100)) (define is-pointer (make-c-bytevector 100))
(debug is-pointer) (debug is-pointer)
(assert equal? (c-bytevector? is-pointer) #t) (assert equal? (c-bytevector? is-pointer) #t)
; FIXME Ypsilon
;(assert equal? (c-bytevector? 100) #f) ;(assert equal? (c-bytevector? 100) #f)
; FIXME Chibi
;(assert equal? (c-bytevector? #f) #f)
(assert equal? (c-bytevector? "Hello") #f)
(assert equal? (c-bytevector? 'bar) #f) (assert equal? (c-bytevector? 'bar) #f)
;; c-bytevector-u8-ref ;; c-bytevector-u8-set! and c-bytevector-u8-ref
(print-header "c-bytevector-u8-set! and c-bytevector-u8-ref")
(print-header "c-bytevector-u8-ref")
(define u8-pointer (make-c-bytevector (c-size-of 'uint8))) (define u8-pointer (make-c-bytevector (c-size-of 'uint8)))
(debug u8-pointer)
(debug (c-bytevector? u8-pointer))
(assert equal? (c-bytevector? u8-pointer) #t)
(c-bytevector-u8-set! u8-pointer 0 42) (c-bytevector-u8-set! u8-pointer 0 42)
(debug u8-pointer) (debug u8-pointer)
(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)
;; string->-utf8 c-utf8->string
(print-header "string->c-utf8 c-utf8->string")
(for-each
(lambda (str)
(debug str)
(assert equal? (string=? (c-utf8->string (string->c-utf8 str)) str) #t))
(list "100" "Hello world" "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
;; define-c-procedure 2
(print-header "define-c-procedure 2")
(define-c-procedure c-atoi libc 'atoi 'int '(pointer))
(assert = (c-atoi (string->c-utf8 "100")) 100)
(define-c-procedure c-puts libc 'puts 'int '(pointer))
(debug c-puts)
(define chars-written (c-puts (string->c-utf8 "puts: Hello from testing, I am C function puts")))
(debug chars-written)
(assert = chars-written 47)
(define-c-procedure c-strcat libc 'strcat 'pointer '(pointer pointer))
(define c-string1 (string->c-utf8 "test123"))
(debug (c-utf8->string c-string1))
(debug (c-utf8->string (c-strcat (string->c-utf8 "con1") (string->c-utf8 "cat1"))))
(assert equal? (string=? (c-utf8->string (c-strcat (string->c-utf8 "con2")
(string->c-utf8 "cat2")))
"con2cat2") #t)
(define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer))
(define output-file (c-fopen (string->c-utf8 "testfile.test")
(string->c-utf8 "w")))
(debug output-file)
(define-c-procedure c-fprintf libc 'fprintf 'int '(pointer pointer))
(define characters-written
(c-fprintf output-file (string->c-utf8 "Hello world")))
(debug characters-written)
(assert equal? (= characters-written 11) #t)
(define-c-procedure c-fclose libc 'fclose 'int '(pointer))
(define closed-status (c-fclose output-file))
(debug closed-status)
(assert equal? (= closed-status 0) #t)
(assert equal? (file-exists? "testfile.test") #t)
(assert equal? (string=? (with-input-from-file "testfile.test"
(lambda () (read-line)))
"Hello world") #t)
;; define-c-callback ;; define-c-callback
(print-header 'define-c-callback) (print-header 'define-c-callback)
@ -320,7 +336,7 @@
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 1) 2) (c-bytevector-s32-native-set! array (* (c-size-of 'int) 1) 2)
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 2) 1) (c-bytevector-s32-native-set! array (* (c-size-of 'int) 2) 1)
(define-c-procedure qsort libc-stdlib 'qsort 'void '(pointer int int callback)) (define-c-procedure qsort libc 'qsort 'void '(pointer int int callback))
(define-c-callback compare (define-c-callback compare
'int 'int