From 531c8bc42d693b29f81d665ea1d618749f2a0b74 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 14 Sep 2024 15:46:03 +0300 Subject: [PATCH] Working on Chicken bugs, backup --- Makefile | 1 + retropikzel/r7rs-pffi/version/chicken.scm | 65 ++++--- test.scm | 212 +++++++++++++++------- 3 files changed, 193 insertions(+), 85 deletions(-) diff --git a/Makefile b/Makefile index a1d7a63..3084a97 100644 --- a/Makefile +++ b/Makefile @@ -70,6 +70,7 @@ test-sagittarius: build RACKET=racket -I r7rs -S . -S ./schubert --script test-racket: build ${SCHEME_RUNNER} racket "${RACKET} test.scm" + #${RACKET} test.scm STKLOS=stklos -A . -A ./schubert -f test-stklos: build diff --git a/retropikzel/r7rs-pffi/version/chicken.scm b/retropikzel/r7rs-pffi/version/chicken.scm index 50cc92c..8aca339 100644 --- a/retropikzel/r7rs-pffi/version/chicken.scm +++ b/retropikzel/r7rs-pffi/version/chicken.scm @@ -53,7 +53,8 @@ (define pffi-pointer? (lambda (object) - (pointer? object))) + (or (string? object) + (pointer? object)))) (define-syntax pffi-define (er-macro-transformer @@ -175,17 +176,33 @@ (lambda () (address->pointer 0))) + (pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) + (pffi-define puts #f 'puts 'int (list 'pointer)) + (pffi-define memset #f 'memset 'void (list 'pointer 'int 'int)) + (define pffi-string->pointer (lambda (string-content) - (let* ((size (+ (string-length string-content) 1)) - (pointer (pffi-pointer-allocate size))) - (move-memory! string-content pointer (- size 1) 0) - pointer))) - - (define pffi-string->pointer-maybe - (lambda (string-content) - (location string-content))) + (let* ((size (string-length string-content)) + (pointer (pffi-pointer-allocate (+ size 1)))) + (memset pointer 0 size) + (display "STRING-LENGTH: ") + (display size) + (display " / ") + (display pointer) + (display " === ") + (strncpy-ps pointer (location string-content) size) + ;(move-memory! string-content pointer size 0) + ;(pffi-pointer-set! pointer 'char size #\null) + (puts pointer) + (display " ::: ") + (write string-content) + (display " OTHER: ") + (display (strlen pointer)) + (newline) + ;(pointer-s8-set! pointer size (foreign-value "\0" char)) + pointer))) + (pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) (pffi-define strlen #f 'strlen 'int (list 'pointer)) (define pffi-pointer->string @@ -193,7 +210,17 @@ (cond ((pffi-pointer? pointer) (let* ((size (strlen pointer)) (string-content (make-string size))) - (move-memory! pointer string-content size 0) + (display "STRLEN: ") + (display size) + (display " / ") + (display pointer) + ;(move-memory! pointer string-content size) + (strncpy-pp (location string-content) pointer size) + (display " ::: ") + (write string-content) + (display " === ") + (puts pointer) + (newline) string-content)) (error "pffi-pointer->string -- Argument not pointer " pointer)))) @@ -221,8 +248,6 @@ (define pffi-pointer-set! (lambda (pointer type offset value) - (write pointer) - (newline) (cond ((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value)) ((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value)) @@ -239,15 +264,13 @@ ((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value)) ((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value)) ((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value)) - ((equal? type 'float) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'double) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'pointer) (pointer-s8-set! (pointer+ pointer offset) value)) - ((equal? type 'string) (pffi-pointer-set! pointer type offset (pffi-string->pointer value)))))) + ((equal? type 'float) (pointer-f32-set! (pointer+ pointer offset) value)) + ((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value)) + ((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value))) + ((equal? type 'string) (pffi-pointer-set! pointer 'pointer offset (pffi-string->pointer value)))))) (define pffi-pointer-get (lambda (pointer type offset) - (write pointer) - (newline) (cond ((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset))) ((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset))) @@ -264,9 +287,9 @@ ((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset))) ((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset))) ((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset))) - ((equal? type 'float) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'double) (pointer-s8-ref (pointer+ pointer offset))) - ((equal? type 'pointer) (pointer->address (pointer+ pointer offset))) + ((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset))) + ((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset))) + ((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))) ((equal? type 'string) (pffi-pointer->string (pffi-pointer-get pointer 'pointer offset)))))) (define pffi-pointer-deref diff --git a/test.scm b/test.scm index c347711..a3d06e7 100644 --- a/test.scm +++ b/test.scm @@ -6,6 +6,7 @@ (define print-header (lambda (title) + (set-tag title) (display "=========================================") (newline) (display title) @@ -13,11 +14,26 @@ (display "=========================================") (newline))) +(define count 0) +(define assert-tag 'none) + +(define set-tag + (lambda (tag) + (set! assert-tag tag) + (set! count 0))) + (define-syntax assert (syntax-rules () ((_ check value-a value-b) (let ((result (apply check (list value-a value-b)))) - (if (not result) (display "FAIL: ") (display "PASS: ")) + (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)))))) @@ -46,54 +62,30 @@ (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list "")) (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" ".6")))) -;; pffi-define +;; pffi-string->pointer -(print-header 'pffi-define) +(print-header 'pffi-string->pointer) +(define string-pointer (pffi-string->pointer "Hello world")) +(debug string-pointer) +(assert equal? (pffi-pointer? string-pointer) #t) +(assert equal? (pffi-pointer-null? string-pointer) #f) -(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer)) -(assert = (atoi (pffi-string->pointer "100")) 100) +;; pffi-pointer->string -;; pffi-define-callback +(print-header 'pffi-pointer->string) -(print-header 'pffi-define-callback) - -(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h") ; Headers - (list ".") ; Additional search paths - "curl" ; The named of shared object without the lib prefix - (list ".4"))) -(pffi-define curl-easy-init libcurl 'curl_easy_init 'pointer (list)) -(pffi-define curl-easy-setopt libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'pointer)) -(pffi-define curl-easy-setopt-callback libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'callback)) -(pffi-define curl-easy-getinfo libcurl 'curl_easy_getinfo 'int (list 'pointer 'int 'pointer)) -(pffi-define curl-easy-perform libcurl 'curl_easy_perform 'int (list 'pointer)) -(define CURLOPT-WRITEFUNCTION 20011) -(define CURLOPT-FOLLOWLOCATION 52) -(define CURLOPT-URL 10002) -(define CURLINFO-RESPONSE-CODE 2097154) - -(define result "") -(pffi-define-callback collect-result - 'void - (list 'pointer 'int 'int 'pointer) - (lambda (pointer size nmemb client-pointer) - (set! result (string-append result (pffi-pointer->string pointer))))) - -(define handle (curl-easy-init)) -(define url (pffi-string->pointer "https://scheme.org")) -(define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION url)) -(debug curl-code1) -(assert = curl-code1 0) -(define curl-code2 (curl-easy-setopt handle CURLOPT-URL url)) -(debug curl-code2) -(assert = curl-code2 0) -(define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result)) -(debug curl-code3) -(assert = curl-code3 0) -(debug (curl-easy-perform handle)) -(define http-code (pffi-pointer-allocate (pffi-size-of 'int))) -(curl-easy-getinfo handle CURLINFO-RESPONSE-CODE http-code) -(assert = (pffi-pointer-get http-code 'int 0) 200) +(define pointer-string (pffi-pointer->string string-pointer)) +(debug pointer-string) +(assert equal? (string? pointer-string) #t) +(assert string=? pointer-string "Hello world") +(assert string=? (pffi-pointer->string (pffi-string->pointer "https://scheme.org")) "https://scheme.org") +(define test-url-string "https://scheme.org") +(debug test-url-string) +(define test-url (pffi-string->pointer test-url-string)) +(debug test-url) +(debug (pffi-pointer->string test-url)) +(assert equal? (string=? (pffi-pointer->string test-url) test-url-string) #t) ;; pffi-size-of @@ -104,24 +96,62 @@ (assert equal? (number? size-int8) #t) (assert = size-int8 1) +(define size-uint8 (pffi-size-of 'uint8)) +(debug size-uint8) (assert equal? (number? (pffi-size-of 'uint8)) #t) +(define size-int16 (pffi-size-of 'int16)) +(debug size-int16) (assert equal? (number? (pffi-size-of 'int16)) #t) +(define size-uint16 (pffi-size-of 'uint16)) +(debug size-uint16) (assert equal? (number? (pffi-size-of 'uint16)) #t) +(define size-int32 (pffi-size-of 'int32)) +(debug size-int32) (assert equal? (number? (pffi-size-of 'int32)) #t) +(define size-uint32 (pffi-size-of 'uint32)) +(debug size-uint32) (assert equal? (number? (pffi-size-of 'uint32)) #t) +(define size-int64 (pffi-size-of 'int64)) +(debug size-int64) (assert equal? (number? (pffi-size-of 'int64)) #t) +(define size-uint64 (pffi-size-of 'uint64)) +(debug size-uint64) (assert equal? (number? (pffi-size-of 'uint64)) #t) +(define size-char (pffi-size-of 'char)) +(debug size-char) (assert equal? (number? (pffi-size-of 'char)) #t) +(define size-unsigned-char (pffi-size-of 'unsigned-char)) +(debug size-unsigned-char) (assert equal? (number? (pffi-size-of 'unsigned-char)) #t) +(define size-short (pffi-size-of 'short)) +(debug size-short) (assert equal? (number? (pffi-size-of 'short)) #t) +(define size-unsigned-short (pffi-size-of 'unsigned-short)) +(debug size-unsigned-short) (assert equal? (number? (pffi-size-of 'unsigned-short)) #t) +(define size-int (pffi-size-of 'int)) +(debug size-int) (assert equal? (number? (pffi-size-of 'int)) #t) +(define size-unsigned-int (pffi-size-of 'unsigned-int)) +(debug size-unsigned-int) (assert equal? (number? (pffi-size-of 'unsigned-int)) #t) +(define size-long (pffi-size-of 'long)) +(debug size-long) (assert equal? (number? (pffi-size-of 'long)) #t) +(define size-unsigned-long (pffi-size-of 'unsigned-long)) +(debug size-unsigned-long) (assert equal? (number? (pffi-size-of 'unsigned-long)) #t) +(define size-float (pffi-size-of 'float)) +(debug size-float) (assert equal? (number? (pffi-size-of 'float)) #t) +(define size-double (pffi-size-of 'double)) +(debug size-double) (assert equal? (number? (pffi-size-of 'double)) #t) +(define size-string (pffi-size-of 'string)) +(debug size-string) (assert equal? (number? (pffi-size-of 'string)) #t) +(define size-pointer (pffi-size-of 'pointer)) +(debug size-pointer) (assert equal? (number? (pffi-size-of 'pointer)) #t) ;; pffi-pointer-allocate @@ -140,22 +170,6 @@ (debug null-pointer) (assert equal? (pffi-pointer-null? null-pointer) #t) -;; pffi-string->pointer - -(print-header 'pffi-string->pointer) - -(define string-pointer (pffi-string->pointer "Hello world")) -(debug string-pointer) -(assert equal? (pffi-pointer? string-pointer) #t) - -;; pffi-pointer->string - -(print-header 'pffi-pointer->string) - -(define pointer-string (pffi-pointer->string string-pointer)) -(debug pointer-string) -(assert string=? pointer-string "Hello world") - ;; pffi-pointer-free (print-header 'pffi-pointer-free) @@ -192,9 +206,9 @@ (print-header "pffi-pointer-set! and pffi-pointer-get") -(define set-pointer (pffi-pointer-allocate 100)) +(define set-pointer (pffi-pointer-allocate 256)) (define offset 50) -(define value 10) +(define value 1) (debug set-pointer) (debug offset) (debug value) @@ -220,15 +234,25 @@ (test-type 'unsigned-int) (test-type 'long) (test-type 'unsigned-long) -(test-type 'float) -(test-type 'double) + +(pffi-pointer-set! set-pointer 'float offset 1.5) +(debug (pffi-pointer-get set-pointer 'float offset)) +(assert = (pffi-pointer-get set-pointer 'float offset) 1.5) +(pffi-pointer-set! set-pointer 'double offset 1.5) +(debug (pffi-pointer-get set-pointer 'double offset)) +(assert = (pffi-pointer-get set-pointer 'double offset) 1.5) (define pointer-to-be-set (pffi-string->pointer "FOOBAR")) (debug pointer-to-be-set) (pffi-pointer-set! set-pointer 'pointer offset pointer-to-be-set) +(debug (pffi-pointer-get set-pointer 'pointer offset)) (assert equal? (pffi-pointer? (pffi-pointer-get set-pointer 'pointer offset)) #t) +(debug (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))) +(assert equal? + (string? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))) + #t) (assert string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") @@ -256,6 +280,66 @@ (string=? pffi-os-name "unix")) #t) +;; pffi-define +(print-header 'pffi-define) + + +(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer)) +(assert = (atoi (pffi-string->pointer "100")) 100) + +;; pffi-define-callback + +(print-header 'pffi-define-callback) + +(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h") ; Headers + (list ".") ; Additional search paths + "curl" ; The named of shared object without the lib prefix + (list ".4"))) +(pffi-define curl-easy-init libcurl 'curl_easy_init 'pointer (list)) +(pffi-define curl-easy-setopt libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'pointer)) +(pffi-define curl-easy-setopt-url libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'string)) +(pffi-define curl-easy-setopt-callback libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'callback)) +(pffi-define curl-easy-getinfo libcurl 'curl_easy_getinfo 'int (list 'pointer 'int 'pointer)) +(pffi-define curl-easy-perform libcurl 'curl_easy_perform 'int (list 'pointer)) +(pffi-define curl-easy-strerror libcurl 'curl_easy_strerror 'string (list 'int)) +(define CURLOPT-WRITEFUNCTION 20011) +(define CURLOPT-FOLLOWLOCATION 52) +(define CURLOPT-URL 10002) +(define CURLINFO-RESPONSE-CODE 2097154) + +(define result "") +(pffi-define-callback collect-result + 'void + (list 'pointer 'int 'int 'pointer) + (lambda (pointer size nmemb client-pointer) + (set! result (string-append result (string-copy (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))) +(curl-easy-getinfo handle CURLINFO-RESPONSE-CODE http-code) +(assert = (pffi-pointer-get http-code 'int 0) 200) (exit 0)