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

Add test for C address of replacement

This commit is contained in:
retropikzel 2025-04-26 10:49:18 +03:00
parent ed96fcad0b
commit 04d4e43b04
11 changed files with 153 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile
View File

@ -67,7 +67,6 @@ ypsilon:
test-compile-r7rs: tmp/test/libtest.o tmp/test/libtest.so tmp/test/libtest.a
make ${COMPILE_R7RS}
cp -r retropikzel tmp/test/
cp tests/*.sld tmp/test/
cp tests/*.scm tmp/test/
cp tests/c-include/libtest.h tmp/test/
cd tmp/test && \

34
retropikzel/pffi/gambit.scm
View File

@ -177,8 +177,7 @@
((equal? type 'double) 'double)
((equal? type 'pointer) '(pointer void))
((equal? type 'void) 'void)
((equal? type 'callback) 'c-pointer)
((equal? type 'struct) 'c-pointer)
((equal? type 'callback) '(pointer void))
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(native-argument-types
(if (equal? '(list) argument-types)
@ -207,3 +206,34 @@
(c-lambda ,native-argument-types
,native-return-type
,c-code)))))
(define-macro
(define-c-callback scheme-name return-type argument-types procedure)
(let* ((type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'byte)
((equal? type 'uint8) 'unsigned-int8)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32)
((equal? type 'uint32) 'unsigned-int32)
((equal? type 'int64) 'int64)
((equal? type 'uint64) 'unsigned-int64)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'unsigned-char)
((equal? type 'short) 'short)
((equal? type 'unsigned-short) 'unsigned-short)
((equal? type 'int) 'int)
((equal? type 'unsigned-int) 'unsigned-int)
((equal? type 'long) 'long)
((equal? type 'unsigned-long) 'unsigned-long)
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) '(pointer void))
((equal? type 'void) 'void)
((equal? type 'callback) '(pointer void))
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(native-return-type (type->native-type (cadr return-type)))
(native-argument-types (map type->native-type (cadr argument-types))))
`(define ,scheme-name ,procedure
#;(c-callback ,native-return-type ,native-argument-types ,procedure))))

1
retropikzel/pffi/gauche-src/gauchelib.scm
View File

@ -74,6 +74,7 @@
(define-cproc dlerror () pffi_dlerror)
(define-cproc dlsym (shared-object c-name) pffi_dlsym)
(define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call)
(define-cproc scheme-procedure-to-pointer (procedure) scheme_procedure_to_pointer)
(define-cproc get-ffi-type-int8 () get_ffi_type_int8)
(define-cproc get-ffi-type-uint8 () get_ffi_type_uint8)

17
retropikzel/pffi/kawa.scm
View File

@ -190,12 +190,11 @@
(integer->char r)
r))))
#;(define pffi-struct-dereference
(lambda (struct)
;; WIP
(pffi-struct-pointer struct)
#;(invoke (pffi-struct-pointer struct) 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
#;(invoke (pffi-struct-pointer struct)
'get
(invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1)
0)))
(define-syntax call-with-address-of-c-bytevector
(syntax-rules ()
((_ input-pointer thunk)
(let ((address-pointer (make-c-bytevector (c-size-of 'pointer))))
(pffi-pointer-set! address-pointer 'pointer 0 input-pointer)
(apply thunk (list address-pointer))
(set! input-pointer (pffi-pointer-get address-pointer 'pointer 0))
(c-free address-pointer)))))

1
retropikzel/pffi/mosh.scm
View File

@ -102,7 +102,6 @@
((equal? type 'pointer) 'void*)
((equal? type 'void) 'void)
((equal? type 'callback) 'void*)
((equal? type 'struct) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(define-syntax define-c-procedure

1
retropikzel/pffi/racket.scm
View File

@ -21,7 +21,6 @@
((equal? type 'pointer) _pointer)
((equal? type 'void) _void)
((equal? type 'callback) _pointer)
((equal? type 'struct) _pointer)
(else #f))))
(define c-bytevector?

20
retropikzel/pffi/shared/pointer.scm
View File

@ -120,13 +120,13 @@
(let ((address (c-memset-pointer->address c-bytevector 0 0)))
(c-memset-address (+ address k) byte 1))))))
(define-syntax call-with-address-of-c-bytevector
(syntax-rules ()
((_ input-pointer thunk)
(let ((address-pointer (make-c-bytevector (c-size-of 'pointer))))
;(pffi-pointer-set! address-pointer 'pointer 0 input-pointer)
(c-bytevector-pointer-set! address-pointer 0 input-pointer)
(apply thunk (list address-pointer))
;(set! input-pointer (pffi-pointer-get address-pointer 'pointer 0))
(set! input-pointer (c-bytevector-pointer-ref address-pointer 0))
(c-free address-pointer)))))
(cond-expand
(kawa #t) ; Defined in kawa.scm
(else (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)))))))

35
tests/test-util.scm → tests/addressof.scm
View File

@ -1,3 +1,11 @@
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(retropikzel pffi))
;; util
(define header-count 1)
(define print-header
@ -62,3 +70,30 @@
(display ": ")
(write value)
(newline)))))
;; call-with-address-of-c-bytevector
(define-c-library c-testlib
'("libtest.h")
"test"
'((additional-paths ("." "./tests"))))
(print-header 'call-with-address-of-c-bytevector)
(define-c-procedure test-passing-pointer-address
c-testlib
'test_passing_pointer_address
'int
'(pointer pointer))
(define input-pointer (make-c-bytevector (c-size-of 'int)))
(c-bytevector-s32-native-set! input-pointer 0 100)
(debug (c-bytevector-s32-native-ref input-pointer 0))
(call-with-address-of-c-bytevector
input-pointer
(lambda (address)
(test-passing-pointer-address input-pointer address)))
(debug input-pointer)
(debug (c-bytevector-s32-native-ref input-pointer 0))
(assert equal? (= (c-bytevector-s32-native-ref input-pointer 0) 42) #t)

0
tests/compliance.scm → tests/old-all.scm
View File

68
tests/primitives.scm
View File

@ -3,9 +3,75 @@
(scheme char)
(scheme file)
(scheme process-context)
(test-util)
(retropikzel pffi))
;; util
(define header-count 1)
(define print-header
(lambda (title)
(set-tag title)
(display "=========================================")
(newline)
(display header-count)
(display " ")
(display title)
(newline)
(display "=========================================")
(newline)
(set! header-count (+ header-count 1))))
(define count 0)
(define assert-tag 'none)
(define set-tag
(lambda (tag)
(set! assert-tag tag)
(set! count 0)))
(cond-expand
(gambit
(define assert
(lambda (check value-a value-b)
(let ((result (apply check (list value-a value-b))))
(set! count (+ count 1))
(if (not result) (display "FAIL ") (display "PASS "))
(display "[")
(display assert-tag)
(display " - ")
(display count)
(display "]")
(display ": ")
(write (list 'check 'value-a 'value-b))
(newline)
(when (not result) (exit 1))))))
(else
(define-syntax assert
(syntax-rules ()
((_ check value-a value-b)
(let ((result (apply check (list value-a value-b))))
(set! count (+ count 1))
(if (not result) (display "FAIL ") (display "PASS "))
(display "[")
(display assert-tag)
(display " - ")
(display count)
(display "]")
(display ": ")
(write (list 'check 'value-a 'value-b))
(newline)
(when (not result) (exit 1))))))))
(define-syntax debug
(syntax-rules ()
((_ value)
(begin
(display 'value)
(display ": ")
(write value)
(newline)))))
;; c-size-of
(print-header 'c-size-of)

7
tests/test-util.sld
View File

@ -1,7 +0,0 @@
(define-library
(test-util)
(import (scheme base)
(scheme write)
(scheme process-context))
(export print-header debug assert)
(include "test-util.scm"))