From 2d62b6824165d2b79ed02d59fc6f86d61ce98422 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 15 Sep 2024 10:27:15 +0300 Subject: [PATCH] Bug fixes --- retropikzel/r7rs-pffi/version/main.rkt | 12 +-- retropikzel/r7rs-pffi/version/main.scm | 12 +-- retropikzel/r7rs-pffi/version/main.sld | 12 +-- retropikzel/r7rs-pffi/version/racket.scm | 37 +++++--- retropikzel/r7rs-pffi/version/sagittarius.scm | 93 +++++++++---------- test.scm | 7 +- 6 files changed, 89 insertions(+), 84 deletions(-) diff --git a/retropikzel/r7rs-pffi/version/main.rkt b/retropikzel/r7rs-pffi/version/main.rkt index 5c3f403..ca8742c 100644 --- a/retropikzel/r7rs-pffi/version/main.rkt +++ b/retropikzel/r7rs-pffi/version/main.rkt @@ -84,6 +84,12 @@ pffi-os-name) (begin + (define pffi-os-name + (cond-expand + (windows "windows") + (racket (if (equal? (system-type 'os) 'windows) "windows" "unix")) + (else "unix"))) + (define-syntax pffi-init (syntax-rules () ((pffi-init) @@ -91,12 +97,6 @@ (chicken (import (chicken foreign))) (else #t))))) - (define pffi-os-name - (cond-expand - (windows "windows") - (racket (if (equal? (system-type 'os) 'windows) "windows" "unix")) - (else "unix"))) - (define library-version "v0-3-0") (define slash (cond-expand (windows (string #\\)) (else "/"))) diff --git a/retropikzel/r7rs-pffi/version/main.scm b/retropikzel/r7rs-pffi/version/main.scm index f3798cc..df4b485 100644 --- a/retropikzel/r7rs-pffi/version/main.scm +++ b/retropikzel/r7rs-pffi/version/main.scm @@ -83,6 +83,12 @@ pffi-os-name) (begin + (define pffi-os-name + (cond-expand + (windows "windows") + (racket (if (equal? (system-type 'os) 'windows) "windows" "unix")) + (else "unix"))) + (define-syntax pffi-init (syntax-rules () ((pffi-init) @@ -90,12 +96,6 @@ (chicken (import (chicken foreign))) (else #t))))) - (define pffi-os-name - (cond-expand - (windows "windows") - (racket (if (equal? (system-type 'os) 'windows) "windows" "unix")) - (else "unix"))) - (define library-version "v0-3-0") (define slash (cond-expand (windows (string #\\)) (else "/"))) diff --git a/retropikzel/r7rs-pffi/version/main.sld b/retropikzel/r7rs-pffi/version/main.sld index f3798cc..df4b485 100644 --- a/retropikzel/r7rs-pffi/version/main.sld +++ b/retropikzel/r7rs-pffi/version/main.sld @@ -83,6 +83,12 @@ pffi-os-name) (begin + (define pffi-os-name + (cond-expand + (windows "windows") + (racket (if (equal? (system-type 'os) 'windows) "windows" "unix")) + (else "unix"))) + (define-syntax pffi-init (syntax-rules () ((pffi-init) @@ -90,12 +96,6 @@ (chicken (import (chicken foreign))) (else #t))))) - (define pffi-os-name - (cond-expand - (windows "windows") - (racket (if (equal? (system-type 'os) 'windows) "windows" "unix")) - (else "unix"))) - (define library-version "v0-3-0") (define slash (cond-expand (windows (string #\\)) (else "/"))) diff --git a/retropikzel/r7rs-pffi/version/racket.scm b/retropikzel/r7rs-pffi/version/racket.scm index 74058a4..e0c82b6 100644 --- a/retropikzel/r7rs-pffi/version/racket.scm +++ b/retropikzel/r7rs-pffi/version/racket.scm @@ -5,6 +5,7 @@ (scheme file) (scheme process-context) (compatibility mlist) + (only (racket base) system-type) (ffi unsafe) (ffi vector)) (export pffi-shared-object-load @@ -44,7 +45,7 @@ ((equal? type 'float) _float) ((equal? type 'double) _double) ((equal? type 'pointer) _pointer) - ((equal? type 'string) _pointer) + ((equal? type 'string) _string) ((equal? type 'void) _void) ((equal? type 'callback) _pointer) (else (error "pffi-type->native-type -- No such pffi type" type))))) @@ -84,11 +85,29 @@ (define pffi-string->pointer (lambda (string-content) - (cast string-content _string _pointer))) + (write string-content) + (newline) + (let* ((size (string-length string-content)) + (pointer (pffi-pointer-allocate (+ size 1)))) + (memmove pointer (cast string-content _string _pointer) size) + (display "STRING SIZE: ") + (display size) + (display " : ") + (write (cast pointer _pointer _string)) + (newline) + pointer))) (define pffi-pointer->string (lambda (pointer) - (cast pointer _pointer _string))) + (let* ((size (string-length (cast pointer _pointer _string))) + (string-content (string-copy (cast pointer _pointer _string)))) + (memmove (cast string-content _string _pointer) pointer size) + (display "SIZE: ") + (display size) + (display " : ") + (write string-content) + (newline) + string-content))) (define pffi-shared-object-load (lambda (header path) @@ -104,19 +123,11 @@ (define pffi-pointer-set! (lambda (pointer type offset value) - (cond - ((equal? type 'string) - (ptr-set! pointer (pffi-type->native-type type) 'abs offset (pffi-string->pointer value))) - (else - (ptr-set! pointer (pffi-type->native-type type) 'abs offset value))))) + (ptr-set! pointer (pffi-type->native-type type) 'abs offset value))) (define pffi-pointer-get (lambda (pointer type offset) - (cond - ((equal? type 'string) - (pffi-pointer->string (ptr-ref pointer (pffi-type->native-type type) 'abs offset))) - (else - (ptr-ref pointer (pffi-type->native-type type) 'abs offset))))) + (ptr-ref pointer (pffi-type->native-type type) 'abs offset))) (define pffi-pointer-deref (lambda (pointer) diff --git a/retropikzel/r7rs-pffi/version/sagittarius.scm b/retropikzel/r7rs-pffi/version/sagittarius.scm index a919e86..c389ba4 100644 --- a/retropikzel/r7rs-pffi/version/sagittarius.scm +++ b/retropikzel/r7rs-pffi/version/sagittarius.scm @@ -50,8 +50,7 @@ (define pffi-pointer? (lambda (object) - (or (string? object) - (pointer? object)))) + (pointer? object))) (define-syntax pffi-define (syntax-rules () @@ -104,13 +103,13 @@ (define pffi-string->pointer (lambda (string-content) - string-content)) + (write string-content) + (newline) + (bytevector->pointer (string->utf8 string-content)))) (define pffi-pointer->string (lambda (pointer) - (if (string? pointer) - pointer - (pointer->string pointer)))) + (pointer->string pointer))) (define pffi-shared-object-load (lambda (header path) @@ -127,51 +126,49 @@ (define pffi-pointer-set! (lambda (pointer type offset value) - (let ((p pointer)) - (cond ((equal? type 'int8) (pointer-set-c-int8_t! p offset value)) - ((equal? type 'uint8) (pointer-set-c-uint8_t! p offset value)) - ((equal? type 'int16) (pointer-set-c-int16_t! p offset value)) - ((equal? type 'uint16) (pointer-set-c-uint16_t! p offset value)) - ((equal? type 'int32) (pointer-set-c-int32_t! p offset value)) - ((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value)) - ((equal? type 'int64) (pointer-set-c-int64_t! p offset value)) - ((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value)) - ((equal? type 'char) (pointer-set-c-char! p offset value)) - ((equal? type 'short) (pointer-set-c-short! p offset value)) - ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value)) - ((equal? type 'int) (pointer-set-c-int! p offset value)) - ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! p offset value)) - ((equal? type 'long) (pointer-set-c-long! p offset value)) - ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value)) - ((equal? type 'float) (pointer-set-c-float! p offset value)) - ((equal? type 'double) (pointer-set-c-double! p offset value)) - ((equal? type 'void*) (pointer-set-c-pointer! p offset value)) - ((equal? type 'pointer) (pointer-set-c-pointer! p 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 'int16) (pointer-set-c-int16_t! pointer offset value)) + ((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value)) + ((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value)) + ((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value)) + ((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value)) + ((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value)) + ((equal? type 'char) (pointer-set-c-char! pointer offset value)) + ((equal? type 'short) (pointer-set-c-short! pointer offset value)) + ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value)) + ((equal? type 'int) (pointer-set-c-int! pointer offset value)) + ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value)) + ((equal? type 'long) (pointer-set-c-long! pointer offset value)) + ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value)) + ((equal? type 'float) (pointer-set-c-float! pointer offset value)) + ((equal? type 'double) (pointer-set-c-double! pointer offset value)) + ((equal? type 'void*) (pointer-set-c-pointer! pointer offset value)) + ((equal? type 'string) (pointer-set-c-pointer! pointer offset value)) + ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) (define pffi-pointer-get (lambda (pointer type offset) - (let ((p pointer) - (native-type (pffi-type->native-type type))) - (cond ((equal? native-type 'int8_t) (pointer-ref-c-int8_t p offset)) - ((equal? native-type 'uint8_t) (pointer-ref-c-uint8_t p offset)) - ((equal? native-type 'int16_t) (pointer-ref-c-int16_t p offset)) - ((equal? native-type 'uint16_t) (pointer-ref-c-uint16_t p offset)) - ((equal? native-type 'int32_t) (pointer-ref-c-int32_t p offset)) - ((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset)) - ((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset)) - ((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset)) - ((equal? native-type 'char) (pointer-ref-c-char p offset)) - ((equal? native-type 'short) (pointer-ref-c-short p offset)) - ((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset)) - ((equal? native-type 'int) (pointer-ref-c-int p offset)) - ((equal? native-type 'unsigned-int) (pointer-ref-c-unsigned-int p offset)) - ((equal? native-type 'long) (pointer-ref-c-long p offset)) - ((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset)) - ((equal? native-type 'float) (pointer-ref-c-float p offset)) - ((equal? native-type 'double) (pointer-ref-c-double p offset)) - ((equal? native-type 'void*) (pointer-ref-c-pointer p offset)) - ((equal? native-type 'char*) (pffi-pointer->string (pointer-ref-c-pointer p offset))) - )))) + (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset)) + ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset)) + ((equal? type 'int16) (pointer-ref-c-int16_t pointer offset)) + ((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset)) + ((equal? type 'int32) (pointer-ref-c-int32_t pointer offset)) + ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset)) + ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset)) + ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset)) + ((equal? type 'char) (pointer-ref-c-char pointer offset)) + ((equal? type 'short) (pointer-ref-c-short pointer offset)) + ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset)) + ((equal? type 'int) (pointer-ref-c-int pointer offset)) + ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset)) + ((equal? type 'long) (pointer-ref-c-long pointer offset)) + ((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset)) + ((equal? type 'float) (pointer-ref-c-float pointer offset)) + ((equal? type 'double) (pointer-ref-c-double pointer offset)) + ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) + ((equal? type 'string) (pffi-pointer->string (pointer-ref-c-pointer pointer offset))) + ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) (define pffi-pointer-deref (lambda (pointer) diff --git a/test.scm b/test.scm index a3d06e7..f55d55a 100644 --- a/test.scm +++ b/test.scm @@ -288,6 +288,7 @@ (pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer)) (assert = (atoi (pffi-string->pointer "100")) 100) +(exit) ;; pffi-define-callback (print-header 'pffi-define-callback) @@ -313,29 +314,25 @@ 'void (list 'pointer 'int 'int 'pointer) (lambda (pointer size nmemb client-pointer) - (set! result (string-append result (string-copy (pffi-pointer->string pointer)))))) + (set! result (string-append result (pffi-pointer->string pointer))))) (define handle (curl-easy-init)) (define url "https://scheme.org") (debug url) (define curl-code1 (curl-easy-setopt-url handle CURLOPT-FOLLOWLOCATION url)) (debug curl-code1) -(when (not (= curl-code1 0)) (error (curl-easy-strerror curl-code1))) (assert = curl-code1 0) (define curl-code2 (curl-easy-setopt-url handle CURLOPT-URL url)) (debug curl-code2) -(when (not (= curl-code2 0)) (error (curl-easy-strerror curl-code2))) (assert = curl-code2 0) (define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result)) (debug curl-code3) -(when (not (= curl-code3 0)) (error (curl-easy-strerror curl-code3))) (assert = curl-code3 0) (define curl-code4 (curl-easy-perform handle)) (debug curl-code4) -(when (not (= curl-code4 0)) (error (curl-easy-strerror curl-code4))) (assert = curl-code4 0) (define http-code (pffi-pointer-allocate (pffi-size-of 'int)))