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

Started adding pffi-pointer-address

This commit is contained in:
retropikzel 2025-04-20 22:10:59 +03:00
parent baa9f40714
commit 637d31b834
5 changed files with 78 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
retropikzel/pffi.sld
View File

@ -155,7 +155,6 @@
pffi-struct-offset-get
pffi-struct-get
pffi-struct-set!
pffi-struct-dereference
pffi-array-allocate
pffi-array-pointer
pffi-array?

5
retropikzel/pffi/sagittarius.scm
View File

@ -27,8 +27,7 @@
(define pffi-pointer?
(lambda (object)
(or (pointer? object)
(string? object))))
(pointer? object)))
(define-syntax pffi-define-function
(syntax-rules ()
@ -79,7 +78,7 @@
(define pffi-pointer-address
(lambda (pointer)
(address pointer 0)))
(address pointer)))
(define pffi-pointer-null
(lambda ()

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

@ -8,6 +8,18 @@
"c"
'((additional-versions ("0" "6"))))))
(cond-expand
(windows (pffi-define-library pffi-libc-stdio
'("stdio.h")
"ucrtbase"
'((additional-versions ("0" "6")))))
(else (pffi-define-library pffi-libc-stdio
'("stdio")
"c"
'((additional-versions ("0" "6"))))))
;(pffi-define-function c-snprintf pffi-libc-stdio 'snprintf 'int '(pointer int pointer pointer))
;(pffi-define-function c-strtol pffi-libc-stdio 'strtol 'uint64 '(pointer pointer int))
(cond-expand
(chibi #t) ; FIXME
(else (pffi-define-function pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int))))
@ -17,3 +29,47 @@
(cond-expand
(chibi #t) ; FIXME
(else (pffi-define-function pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer))))
#;(define pffi-pointer-null
(lambda ()
(let ((pointer (pffi-pointer-allocate (pffi-size-of 'pointer))))
(pffi-pointer-set! pointer 'int 0 0)
pointer)))
#;(define pffi-pointer-null?
(lambda (pointer)
(let ((address
(let ((str (pffi-pointer-allocate 512)))
(c-snprintf str 512 (pffi-string->pointer "%p") pointer)
(display "Scheme: p1 address: ")
(write (pffi-pointer->string str))
(newline)
(display "Scheme: p1 address int: ")
(write (c-strtol str (pffi-pointer-null) 16))
(newline)
(c-strtol str (pffi-pointer-null) 16))))
(= address 0))))
#;(define pffi-pointer-address
(lambda (pointer)
(let* ((address-number
(let ((str (pffi-pointer-allocate 512)))
(c-snprintf str 512 (pffi-string->pointer "%p") pointer)
(display "Scheme: p1 address: ")
(write (pffi-pointer->string str))
(newline)
(display "Scheme: p1 address int: ")
(write (c-strtol str (pffi-pointer-null) 16))
(newline)
(c-strtol str (pffi-pointer-null) 16)))
(address (pffi-pointer-allocate (pffi-size-of 'uint64))))
(display "Scheme: p2 address: ")
(write address)
(newline)
;address-number
(pffi-pointer-set! address 'uint64 0 address-number)
;address-number
;(pffi-pointer-get address 'pointer 0)
address
)
))

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

@ -21,7 +21,7 @@
(c-type-string (if (string? c-type) c-type (symbol->string c-type))))
(struct-make c-type-string size pointer offsets)))))))
(define pffi-struct-dereference
#;(define pffi-struct-dereference
(lambda (struct)
(let ((pointer (pffi-pointer-allocate (pffi-struct-size struct)))
(offset 0))

20
tests/compliance.scm
View File

@ -468,12 +468,30 @@
(print-header 'pffi-pointer-allocate)
(pffi-define-function test-passing-pointer-address
c-testlib
'test_passing_pointer_address
'int
'(pointer pointer))
(pffi-define-function pa c-testlib 'pa 'pointer '(pointer))
(pffi-define-function printa c-testlib 'printa 'void '(pointer))
(define test-pointer1 (pffi-pointer-allocate 100))
(debug test-pointer1)
(debug (pffi-pointer? test-pointer1))
(assert equal? (pffi-pointer? test-pointer1) #t)
(debug (pffi-pointer-address test-pointer1))
;(assert equal? (number? (pffi-pointer-address test-pointer1)) #t)
(define input-pointer (pffi-pointer-allocate (pffi-size-of 'int)))
(pffi-pointer-set! input-pointer 'int 0 100)
(define input-pointer-address (pffi-pointer-address input-pointer))
(debug input-pointer-address)
(test-passing-pointer-address input-pointer input-pointer-address)
(debug input-pointer)
(debug input-pointer-address)
(debug (pffi-pointer-get input-pointer 'int 0))
;(assert equal? (pffi-pointer? input-pointer-address) #t)
;(assert equal? (= (pffi-pointer-get input-pointer 'int 0) 42) #t)
;(assert equal? (> (pffi-pointer-address test-pointer1) 0) #t)
;; pffi-pointer?