diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index ae098ac..229e9b9 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -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? diff --git a/retropikzel/pffi/sagittarius.scm b/retropikzel/pffi/sagittarius.scm index 4835926..98df939 100644 --- a/retropikzel/pffi/sagittarius.scm +++ b/retropikzel/pffi/sagittarius.scm @@ -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 () diff --git a/retropikzel/pffi/shared/pointer.scm b/retropikzel/pffi/shared/pointer.scm index 5b1a047..186f4b2 100644 --- a/retropikzel/pffi/shared/pointer.scm +++ b/retropikzel/pffi/shared/pointer.scm @@ -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 + ) + )) diff --git a/retropikzel/pffi/shared/struct.scm b/retropikzel/pffi/shared/struct.scm index 2de0ebd..66c3786 100644 --- a/retropikzel/pffi/shared/struct.scm +++ b/retropikzel/pffi/shared/struct.scm @@ -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)) diff --git a/tests/compliance.scm b/tests/compliance.scm index c1a3a9b..f4ad12d 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -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?