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

Switch to shared allocate and free functions

This commit is contained in:
retropikzel 2025-04-05 19:19:25 +03:00
parent f783ea1521
commit 1d4d2c7339
19 changed files with 300 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
retropikzel/pffi.sld
View File

@ -31,7 +31,7 @@
pffi-struct-set!
pffi-define
pffi-define-callback
scheme-procedure-to-pointer
;scheme-procedure-to-pointer
)
(include-shared "pffi/chibi-pffi"))
(chicken-5
@ -66,8 +66,7 @@
pffi-struct-get
pffi-struct-set!
pffi-define
;pffi-define-callback
))
pffi-define-callback))
(chicken6
(import (scheme base)
(scheme write)
@ -404,8 +403,7 @@
pffi-struct-get
pffi-struct-set!
pffi-define
;pffi-define-callback
))
pffi-define-callback))
(skint
(import (scheme base)
(scheme write)
@ -544,5 +542,7 @@
(tr7 (include "pffi/tr7.scm"))
(ypsilon (include "pffi/ypsilon.scm")))
;(include "pffi/shared/union.scm")
(include "pffi/shared/main.scm")
(include "pffi/shared/pointer.scm")
(include "pffi/shared/struct.scm")
(include "pffi/shared/main.scm"))
)

4
retropikzel/pffi/chibi.scm
View File

@ -46,7 +46,7 @@
(or (equal? object #f) ; False can be null pointer
(pointer? object))))
(define pffi-pointer-allocate
#;(define pffi-pointer-allocate
(lambda (size)
(pointer-allocate size)))
@ -54,7 +54,7 @@
(lambda (pointer)
(pointer-address pointer)))
(define pffi-pointer-free
#;(define pffi-pointer-free
(lambda (pointer)
(pointer-free pointer)))

5
retropikzel/pffi/chibi/pffi.stub
View File

@ -272,8 +272,9 @@
(c-declare
"void* scheme_procedure_to_pointer(sexp proc) {
if(sexp_procedurep(proc) == 1) {
sexp debug1 = sexp_procedure_code(proc);
printf(\"HERE: %u\\n\", sexp_bytecode_length(debug1));
return 0; //&sexp_unbox_fixnum(proc);
} else {
printf(\"NOT A FUNCTION\\n\");
}
return (void*)proc;
}")

14
retropikzel/pffi/chicken5.scm
View File

@ -67,14 +67,10 @@
`(define ,scheme-name
(foreign-safe-lambda ,return-type ,c-name ,@ argument-types)))))))
#;(define-syntax pffi-define-callback
(define-syntax pffi-define-callback
(er-macro-transformer
(lambda (expr rename compare)
(let* ((debug (begin
(write (list-ref expr 4))
(newline)
))
(pffi-type->native-type ; Chicken has this procedure in three places
(let* ((pffi-type->native-type ; Chicken has this procedure in three places
(lambda (type)
(cond ((equal? type 'int8) 'byte)
((equal? type 'uint8) 'unsigned-byte)
@ -107,7 +103,7 @@
(lambda (name type)
`(,name ,type))
argument-types argument-names))
(procedure-body (cadr (cdr (list-ref expr 4)))))
(procedure-body (cdr (cdr (list-ref expr 4)))))
`(begin (define-external ,(cons 'external_123456789 arguments)
,return-type
(begin ,@ procedure-body))
@ -137,7 +133,7 @@
((equal? type 'string) (foreign-value "sizeof(void*)" int))
((equal? type 'callback) (foreign-value "sizeof(void*)" int)))))
(define pffi-pointer-allocate
#;(define pffi-pointer-allocate
(lambda (size)
(allocate size)))
@ -186,7 +182,7 @@
`(foreign-declare ,(string-append "#include <" header ">")))
headers))))))
(define pffi-pointer-free
#;(define pffi-pointer-free
(lambda (pointer)
(if (not (pointer? pointer))
(error "pffi-pointer-free -- Argument is not pointer" pointer))

4
retropikzel/pffi/cyclone.scm
View File

@ -93,7 +93,7 @@
((equal? type 'double) (c-value "sizeof(double)" int))
((equal? type 'pointer) (c-value "sizeof(void*)" int)))))
(define-c pffi-pointer-allocate
#;(define-c pffi-pointer-allocate
"(void *data, int argc, closure _, object k, object size)"
"make_c_opaque(opq, malloc(obj_obj2int(size)));
return_closcall1(data, k, &opq);")
@ -121,7 +121,7 @@
`(include-c-header ,(string-append "<" header ">")))
(cdr (car (cdr expr))))))))
(define-c pffi-pointer-free
#;(define-c pffi-pointer-free
"(void *data, int argc, closure _, object k, object pointer)"
"free(opaque_ptr(pointer));
return_closcall1(data, k, make_boolean(boolean_t));")

6
retropikzel/pffi/gambit.scm
View File

@ -58,7 +58,7 @@
(map
(lambda (header)
(string-append "#include <" header ">" (string #\newline)))
(cdr headers))))))
header-list)))))
(define pointer? (c-lambda ((pointer void)) bool "___return(1);"))
(define pffi-pointer?
@ -77,11 +77,11 @@
(and (pffi-pointer? pointer)
(pointer-null? pointer))))
(define pffi-pointer-allocate (c-lambda (int) (pointer void) "void* p = malloc(___arg1); ___return(p);"))
;(define pffi-pointer-allocate (c-lambda (int) (pointer void) "void* p = malloc(___arg1); ___return(p);"))
(define pffi-pointer-address (c-lambda ((pointer void)) ptrdiff_t "void* p = ___arg1; ___return((intptr_t)&p);"))
(define pffi-pointer-free (c-lambda ((pointer void)) void "free(___arg1);"))
;(define pffi-pointer-free (c-lambda ((pointer void)) void "free(___arg1);"))
(define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
(define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))

17
retropikzel/pffi/gauche.scm
View File

@ -113,14 +113,6 @@
((equal? type 'void) (pointer-get-pointer pointer offset))
((equal? type 'pointer) (pointer-get-pointer pointer offset)))))
#;(define pffi-string->pointer
(lambda (string-content)
(string->pointer string-content)))
#;(define pffi-pointer->string
(lambda (pointer)
(pointer->string pointer)))
(define pffi-type->libffi-type
(lambda (type)
(cond ((equal? type 'int8) (get-ffi-type-int8))
@ -185,3 +177,12 @@
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 ()
((pffi-define scheme-name return-type argument-types procedure)
(define scheme-name
(make-c-callback return-type 'argument-types procedure)))))

3
retropikzel/pffi/gauche/gauchelib.scm
View File

@ -96,4 +96,5 @@
(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-pointer () get_ffi_type_pointer)
)
(define-cproc procedure-to-pointer (procedure) procedure_to_pointer))

6
retropikzel/pffi/kawa.scm
View File

@ -131,7 +131,7 @@
(invoke native-type 'byteAlignment)
#f))))
(define pffi-pointer-allocate
#;(define pffi-pointer-allocate
(lambda (size)
(invoke (invoke arena 'allocate size 1) 'reinterpret size)))
@ -154,7 +154,7 @@
(invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getString 0)))
(define pffi-shared-object-load
(lambda (header path . options)
(lambda (path options)
(let* ((library-file (make java.io.File path))
(file-name (invoke library-file 'getName))
(library-parent-folder (make java.io.File (invoke library-file 'getParent)))
@ -169,7 +169,7 @@
(list (cons 'linker linker)
(cons 'lookup lookup)))))
(define pffi-pointer-free
#;(define pffi-pointer-free
(lambda (pointer)
#t))

88
retropikzel/pffi/larceny-util.scm Normal file
View File

@ -0,0 +1,88 @@
;; Copied from Larceny source
;; Copyright 1998 Lars T Hansen.
;; Copied code begins
(define %set32u)
; %peek* and %poke*: convenient access to values in memory.
(define (%peek8 addr)
(let ((x (make-bytevector 1)))
(peek-bytes addr x 1)
(let ((v (bytevector-ref x 0)))
(if (> v 127)
(- (- 256 v))
v))))
(define (%peek16 addr)
(let ((x (make-bytevector 2)))
(peek-bytes addr x 2)
(%get16 x 0)))
(define (%peek32 addr)
(let ((x (make-bytevector 4)))
(peek-bytes addr x 4)
(%get32 x 0)))
(define (%peek8u addr)
(let ((x (make-bytevector 1)))
(peek-bytes addr x 1)
(bytevector-ref x 0)))
(define (%peek16u addr)
(let ((x (make-bytevector 2)))
(peek-bytes addr x 2)
(%get16u x 0)))
(define (%peek32u addr)
(let ((x (make-bytevector 4)))
(peek-bytes addr x 4)
(%get32u x 0)))
(define (%poke8 addr val)
(let ((x (make-bytevector 1)))
(if (< val 0)
(bytevector-set! x 0 (+ 256 val))
(bytevector-set! x 0 val))
(poke-bytes addr x 1)))
(define (%poke16 addr val)
(let ((x (make-bytevector 2)))
(%set16 x 0 val)
(poke-bytes addr x 2)))
(define (%poke32 addr val)
(let ((x (make-bytevector 4)))
(%set32 x 0 val)
(poke-bytes addr x 4)))
(define (%poke8u addr val)
(let ((x (make-bytevector 1)))
(bytevector-set! x 0 val)
(poke-bytes addr x 1)))
(define (%poke16u addr val)
(let ((x (make-bytevector 2)))
(%set16u x 0 val)
(poke-bytes addr x 2)))
(define (%poke32u addr val)
(let ((x (make-bytevector 4)))
(%set32u x 0 val)
(poke-bytes addr x 4)))
(define %peek-int %peek32)
(define %peek-long %peek32)
(define %peek-uint %peek32u)
(define %peek-ulong %peek32u)
(define %peek-short %peek16)
(define %peek-ushort %peek16u)
(define %peek-pointer %peek32u)
(define %poke-int %poke32)
(define %poke-long %poke32)
(define %poke-uint %poke32u)
(define %poke-ulong %poke32u)
(define %poke-short %poke16)
(define %poke-ushort %poke16u)
(define %poke-pointer %poke32u)

114
retropikzel/pffi/larceny.scm
View File

@ -1,4 +1,6 @@
(require 'std-ffi)
;(require "Standard/foreign-stdlib")
;(require "Lib/Common/system-interface")
;; FIXME
(define size-of-type
@ -23,3 +25,115 @@
((eq? type 'double) 8)
((eq? type 'pointer) 4)
(else (error "Can not get size of unknown type" type)))))
(define c-malloc (foreign-procedure "malloc" '(int) 'void*))
;(define c-malloc (stdlib/malloc rtd-void*))
#;(define pffi-pointer-allocate
(lambda (size)
(c-malloc size)))
#;(define c-free (foreign-procedure "free" '(void*) 'int))
;(define c-malloc (stdlib/malloc rtd-void*))
#;(define pffi-pointer-free
(lambda (pointer)
(c-free pointer)))
(define pffi-pointer-null (lambda () 0))
(define pffi-pointer-null?
(lambda (object)
(and (number? object)
(= object 0))))
(define pffi-pointer?
(lambda (object)
;(void*? object)
(number? object)
))
(define pffi-pointer-address
(lambda (pointer)
;(void*->address pointer)
pointer
))
(define pffi-pointer->string
(lambda (pointer)
;(char*->string pointer)
pointer
))
(define pffi-string->pointer
(lambda (string-content)
;(string->char* string-content)
string-content
))
(define pffi-shared-object-load
(lambda (headers path . options)
(foreign-file path)))
(define pffi-pointer-set!
(lambda (pointer type offset value)
0
#;(cond ((equal? type 'int8) (%poke8 (+ pointer offset) value))
((equal? type 'uint8) (%poke8u (+ pointer offset) value))
((equal? type 'int16) (%poke16 (+ pointer offset) value))
((equal? type 'uint16) (%poke16u (+ pointer offset) value))
((equal? type 'int32) (%poke32 (+ pointer offset) value))
((equal? type 'uint32) (%poke32u (+ pointer offset) value))
;((equal? type 'int64) (%poke64 (+ pointer offset) value))
;((equal? type 'uint64) (%poke64u (+ pointer offset) value))
((equal? type 'char) (%poke8 (+ pointer offset) value))
((equal? type 'short) (%poke-short (+ pointer offset) value))
((equal? type 'unsigned-short) (%poke-ushort (+ pointer offset) value))
((equal? type 'int) (%poke-int (+ pointer offset) value))
((equal? type 'unsigned-int) (%poke-uint (+ pointer offset) value))
((equal? type 'long) (%poke-long (+ pointer offset) value))
((equal? type 'unsigned-long) (%poke-ulong (+ pointer offset) value))
;((equal? type 'float) (%poke-ulong (+ pointer offset) value))
;((equal? type 'double) (pointer-set-c-double! pointer offset value))
((equal? type 'void) (%poke-pointer (+ pointer offset) value))
((equal? type 'pointer) (%poke-pointer (+ pointer offset) value)))))
(define pffi-pointer-get
(lambda (pointer type offset)
0
#;(cond ((equal? type 'int8) (%peek8 (+ pointer offset)))
((equal? type 'uint8) (%peek8u (+ pointer offset)))
((equal? type 'int16) (%peek16 (+ pointer offset)))
((equal? type 'uint16) (%peek16u (+ pointer offset)))
((equal? type 'int32) (%peek32 (+ pointer offset)))
((equal? type 'uint32) (%peek32u (+ pointer offset)))
;((equal? type 'int64) (%peek64 (+ pointer offset)))
;((equal? type 'uint64) (%peek64u (+ pointer offset)))
((equal? type 'char) (%peek8 (+ pointer offset)))
((equal? type 'short) (%peek-short (+ pointer offset)))
((equal? type 'unsigned-short) (%peek-ushort (+ pointer offset)))
((equal? type 'int) (%peek-int (+ pointer offset)))
((equal? type 'unsigned-int) (%peek-uint (+ pointer offset)))
((equal? type 'long) (%peek-long (+ pointer offset)))
((equal? type 'unsigned-long) (%peek-ulong (+ pointer offset)))
;((equal? type 'float) (%peek-ulong (+ pointer offset)))
;((equal? type 'double) (pointer-set-c-double! pointer offset))
((equal? type 'void) (%peek-pointer (+ pointer offset)))
((equal? type 'pointer) (%peek-pointer (+ pointer offset))))))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(define scheme-name
0
#;(make-c-function shared-object
(symbol->string c-name)
return-type
argument-types)))))
(define-syntax pffi-define-callback
(syntax-rules ()
((pffi-define scheme-name return-type argument-types procedure)
(define scheme-name
0
#;(make-c-callback return-type argument-types procedure)))))

6
retropikzel/pffi/mosh.scm
View File

@ -25,7 +25,7 @@
(else #f))))
(define pffi-shared-object-load
(lambda (header path . options)
(lambda (path . options)
(open-shared-library path)))
(define pffi-pointer-null
@ -36,7 +36,7 @@
(lambda (pointer)
(pointer-null? pointer)))
(define pffi-pointer-allocate
#;(define pffi-pointer-allocate
(lambda (size)
(malloc size)))
@ -48,7 +48,7 @@
(lambda (object)
(pointer? object)))
(define pffi-pointer-free
#;(define pffi-pointer-free
(lambda (pointer)
(free pointer)))

4
retropikzel/pffi/racket.scm
View File

@ -53,7 +53,7 @@
(ctype-sizeof native-type)
#f))))
(define pffi-pointer-allocate
#;(define pffi-pointer-allocate
(lambda (size)
(malloc 'raw size)))
@ -87,7 +87,7 @@
(list #f))))
(ffi-lib path))))
(define pffi-pointer-free
#;(define pffi-pointer-free
(lambda (pointer)
(free pointer)))

10
retropikzel/pffi/sagittarius.scm
View File

@ -39,7 +39,7 @@
c-name
(map pffi-type->native-type argument-types))))))
#;(define-syntax pffi-define-callback
(define-syntax pffi-define-callback
(syntax-rules ()
((_ scheme-name return-type argument-types procedure)
(define scheme-name
@ -73,15 +73,15 @@
((eq? type 'callback) size-of-void*)
(else #f))))
(define pffi-pointer-allocate
#;(define pffi-pointer-allocate
(lambda (size)
(c-malloc size)))
(define pffi-pointer-address
(lambda (pointer)
(pointer-address pointer)))
(address pointer 0)))
(define pffi-pointer-null
#;(define pffi-pointer-null
(lambda ()
(empty-pointer)))
@ -105,7 +105,7 @@
(lambda (path options)
(open-shared-library path)))
(define pffi-pointer-free
#;(define pffi-pointer-free
(lambda (pointer)
(when (pointer? pointer)
(c-free pointer))))

19
retropikzel/pffi/shared/pointer.scm Normal file
View File

@ -0,0 +1,19 @@
(cond-expand
;(kawa #t) ; JVM
(windows (pffi-define-library pffi-libc-stdlib
'("stdlib.h")
"ucrtbase"
'((additional-versions ("0" "6")))))
(else (pffi-define-library pffi-libc-stdlib
'("stdlib.h")
"c"
'((additional-versions ("0" "6"))))))
(pffi-define pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int))
;(pffi-define pffi-pointer-allocate-aligned pffi-libc-stdlib 'aligned_alloc 'pointer '(int int))
(pffi-define pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer))
#;(define pffi-pointer-null
(lambda ()
; Make aligned_alloc fail and return us a null pointer
(pffi-pointer-allocate-aligned -1 -1)))

2
retropikzel/pffi/shared/struct.scm
View File

@ -62,7 +62,7 @@
(size (cdr (assoc 'size size-and-offsets)))
(offsets (cdr (assoc 'offsets size-and-offsets)))
(pointer (if (null? pointer) (pffi-pointer-allocate size) (car pointer)))
(c-typr (if (string? c-type) c-type (symbol->string c-type))))
(c-type (if (string? c-type) c-type (symbol->string c-type))))
(struct-make c-type size pointer offsets))))
(define (pffi-struct-offset-get struct member-name)

5
retropikzel/pffi/stklos.scm
View File

@ -99,7 +99,7 @@
)))
(define pffi-pointer-allocate
#;(define pffi-pointer-allocate
(lambda (size)
(allocate-bytes size)))
@ -108,13 +108,14 @@
(lambda (pointer)
0))
;; FIXME
(define pffi-pointer-null
(lambda ()
(let ((p (allocate-bytes 0)))
(free-bytes p)
p)))
(define pffi-pointer-free
#;(define pffi-pointer-free
(lambda (pointer)
(free-bytes pointer)))

53
retropikzel/pffi/ypsilon.scm
View File

@ -28,7 +28,7 @@
(define c-malloc (c-function void* malloc (size_t)))
(define c-free (c-function int free (void*)))
(define pffi-pointer-allocate
#;(define pffi-pointer-allocate
(lambda (size)
(c-malloc size)))
@ -40,7 +40,7 @@
(lambda (object)
(number? object)))
(define pffi-pointer-free
#;(define pffi-pointer-free
(lambda (pointer)
(c-free pointer)))
@ -118,31 +118,30 @@
(lambda (headers path options)
(load-shared-object path)))
(define pffi-type->native-type
(lambda (type)
(cond ((equal? type '(quote int8)) 'int8_t)
((equal? type '(quote uint8)) 'uint8_t)
((equal? type '(quote int16)) 'int16_t)
((equal? type '(quote uint16)) 'uint16_t)
((equal? type '(quote int32)) 'int32_t)
((equal? type '(quote uint32)) 'uint32_t)
((equal? type '(quote int64)) 'int64_t)
((equal? type '(quote uint64)) 'uint64_t)
((equal? type '(quote char)) 'char)
((equal? type '(quote unsigned-char)) 'char)
((equal? type '(quote short)) 'short)
((equal? type '(quote unsigned-short)) 'unsigned-short)
((equal? type '(quote int)) 'int)
((equal? type '(quote unsigned-int)) 'unsigned-int)
((equal? type '(quote long)) 'long)
((equal? type '(quote unsigned-long)) 'unsigned-long)
((equal? type '(quote float)) 'float)
((equal? type '(quote double)) 'double)
((equal? type '(quote pointer)) 'void*)
((equal? type '(quote string)) 'void*)
((equal? type '(quote void)) 'void)
((equal? type '(quote callback)) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(define-macro (pffi-type->native-type 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) void*)
((equal? ,type string) void*)
((equal? ,type void) void)
((equal? ,type callback) void*)
(else (error "pffi-type->native-type -- No such pffi type" ,type))))
(define-macro
(pffi-define scheme-name shared-object c-name return-type argument-types)

8
tests/compliance.scm
View File

@ -887,7 +887,7 @@
;; pffi-struct-dereference
;(print-header "pffi-struct-dereference 1")
;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int '(struct))
;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int '(uint32))
#;(define struct-color (pffi-struct-make 'color '((int8 . r)
(int8 . g)
(int8 . b)
@ -896,11 +896,11 @@
;(debug (pffi-struct-set! struct-color 'g 101))
;(debug (pffi-struct-set! struct-color 'b 102))
;(debug (pffi-struct-set! struct-color 'a 103))
;(assert = (c-color-check-by-value (pffi-struct-dereference struct-color)) 0)
;(assert = (c-color-check-by-value (pffi-pointer-address (pffi-struct-pointer struct-color))) 0)
;(print-header "pffi-struct-dereference 2")
;(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int '(struct))
;(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int '(int))
#;(define struct-test3 (pffi-struct-make 'test
'((int8 . a)
(char . b)
@ -944,7 +944,7 @@
;(debug (pffi-struct-get struct-test3 'l))
;(debug (pffi-struct-get struct-test3 'm))
;(debug (pffi-struct-get struct-test3 'n))
;(c-test-check-by-value (pffi-struct-dereference struct-test3))
;(c-test-check-by-value (pffi-pointer-address (pffi-struct-pointer struct-test3)))
;; pffi-define-callback