From 54712c1b4ce31abdbc9b359bd6034482445d86c0 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 15 Sep 2024 15:45:28 +0300 Subject: [PATCH] Backup --- Makefile | 13 ++-- retropikzel/r7rs-pffi/version/cyclone.scm | 31 ++++++-- scheme_runner | 2 +- test.scm | 95 ++++++++++++----------- 4 files changed, 80 insertions(+), 61 deletions(-) diff --git a/Makefile b/Makefile index 3084a97..58a910f 100644 --- a/Makefile +++ b/Makefile @@ -18,7 +18,7 @@ test-tier1: \ test-sagittarius \ test-racket -test-tier2: +test-tier2: \ test-cyclone \ test-gambit \ test-stklos @@ -43,16 +43,17 @@ build-cyclone-libs: CYCLONE=cyclone -A . -A ./schubert test-cyclone: clean build build-cyclone-libs - ${SCHEME_RUNNER} cyclone "icyc -s test.scm" + ${SCHEME_RUNNER} cyclone "${CYCLONE} test.scm && icyc -s test.scm" -GAMBIT_LIB=gsc -:r7rs,search=.:./schubert -dynamic +GAMBIT_LIB=gsc -:r7rs -dynamic build-gambit-libs: - ${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/pffi/version/gambit.scm" - ${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/pffi/version/main.scm" + ${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/r7rs-pffi/version/gambit.scm" + ${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/r7rs-pffi/version/main.scm" GAMBIT=gsc -:r7rs,search=.:./schubert -ld-options -lcurl -exe test-gambit: clean build - ${SCHEME_RUNNER} gambit "${GAMBIT} test.scm && ./test" + #${SCHEME_RUNNER} gambit "${GAMBIT} test.scm && ./test" + ${GAMBIT} test.scm && ./test GUILE=guile -L . -L ./schubert test-guile: build diff --git a/retropikzel/r7rs-pffi/version/cyclone.scm b/retropikzel/r7rs-pffi/version/cyclone.scm index e728206..60811d8 100644 --- a/retropikzel/r7rs-pffi/version/cyclone.scm +++ b/retropikzel/r7rs-pffi/version/cyclone.scm @@ -45,7 +45,6 @@ ((equal? type 'float) float) ((equal? type 'double) double) ((equal? type 'pointer) opaque) - ((equal? type 'string) string) ((equal? type 'void) c-void) (else (error "pffi-type->native-type -- No such pffi type" type))))) @@ -78,7 +77,6 @@ ((equal? type 'float) 'float) ((equal? type 'double) 'double) ((equal? type 'pointer) 'c-pointer) - ((equal? type 'string) 'c-string) ((equal? type 'void) 'void) (else (error "pffi-type->native-type -- No such pffi type" type))))) (scheme-name (car (cdr expr))) @@ -94,10 +92,28 @@ `(c-define ,scheme-name ,return-type ,c-name ,@ argument-types)))))) - - (define pffi-size-of - (lambda (type) - (error "Not defined"))) + (define pffi-size-of + (lambda (type) + (cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int)) + ((equal? type 'uint8) (c-value "sizeof(uint8_t)" int)) + ((equal? type 'int16) (c-value "sizeof(int16_t)" int)) + ((equal? type 'uint16) (c-value "sizeof(uint16_t)" int)) + ((equal? type 'int32) (c-value "sizeof(int32_t)" int)) + ((equal? type 'uint32) (c-value "sizeof(uint32_t)" int)) + ((equal? type 'int64) (c-value "sizeof(int64_t)" int)) + ((equal? type 'uint64) (c-value "sizeof(uint64_t)" int)) + ((equal? type 'char) (c-value "sizeof(char)" int)) + ((equal? type 'unsigned-char) (c-value "sizeof(unsigned char)" int)) + ((equal? type 'short) (c-value "sizeof(short)" int)) + ((equal? type 'unsigned-short) (c-value "sizeof(unsigned short)" int)) + ((equal? type 'int) (c-value "sizeof(int)" int)) + ((equal? type 'unsigned-int) (c-value "sizeof(unsigned int)" int)) + ((equal? type 'long) (c-value "sizeof(long)" int)) + ((equal? type 'unsigned-long) (c-value "sizeof(unsigned long)" int)) + ((equal? type 'float) (c-value "sizeof(float)" int)) + ((equal? type 'double) (c-value "sizeof(double)" int)) + ((equal? type 'pointer) (c-value "sizeof(void*)" int)) + (else (error "pffi-size-of -- No such pffi type" type))))) (define pffi-pointer-allocate (lambda (size) @@ -109,7 +125,8 @@ (define pffi-string->pointer (lambda (string-content) - (error "Not defined"))) + (error "Not defined") + )) (define pffi-pointer->string (lambda (pointer) diff --git a/scheme_runner b/scheme_runner index 57bfbb2..44fd200 100755 --- a/scheme_runner +++ b/scheme_runner @@ -25,5 +25,5 @@ else -f ${DOCKERFILE} \ --tag ${tag}:latest \ . - docker run -v ${PWD}:/workdir:z ${tag}:latest ${cmd} + docker run -it -v ${PWD}:/workdir:z ${tag}:latest ${cmd} fi diff --git a/test.scm b/test.scm index 262edae..8425587 100644 --- a/test.scm +++ b/test.scm @@ -47,46 +47,6 @@ (write value) (newline))))) -;; pffi-init - -(print-header 'pffi-init) - -(pffi-init) - -;; pffi-shared-object-auto-load - -(print-header 'pffi-shared-object-auto-load) - -(define libc-stdlib - (if (string=? pffi-os-name "windows") - (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list "")) - (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" ".6")))) - -;; 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) -(assert equal? (pffi-pointer-null? string-pointer) #f) - -;; pffi-pointer->string - -(print-header 'pffi-pointer->string) - -(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 (print-header 'pffi-size-of) @@ -202,6 +162,47 @@ (assert equal? (number? size-pointer) #t) (assert = size-pointer 8) +;; pffi-init + +(print-header 'pffi-init) + +(pffi-init) + +;; pffi-shared-object-auto-load + +(print-header 'pffi-shared-object-auto-load) + +(define libc-stdlib + (if (string=? pffi-os-name "windows") + (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list "")) + (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" ".6")))) + +;; 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) +(assert equal? (pffi-pointer-null? string-pointer) #f) + +;; pffi-pointer->string + +(print-header 'pffi-pointer->string) + +(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-pointer-allocate @@ -334,10 +335,11 @@ (print-header 'pffi-define) -(pffi-define atoi-pointer libc-stdlib 'atoi 'int (list 'pointer)) -(assert = (atoi-pointer (pffi-string->pointer "100")) 100) +(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer)) +(assert = (atoi (pffi-string->pointer "100")) 100) + +(exit 0) -(exit) ;; pffi-define-callback (print-header 'pffi-define-callback) @@ -361,17 +363,16 @@ 'void (list 'pointer 'int 'int 'pointer) (lambda (pointer size nmemb client-pointer) - (set! result (string-append result (pffi-pointer->string pointer))))) + (set! result (string-append result (string-copy (pffi-pointer->string pointer)))))) (define handle (curl-easy-init)) (define url "https://scheme.org") -(define url-pointer (pffi-string->pointer url)) (debug url) -(define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION url-pointer)) +(define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION (pffi-string->pointer url))) (debug curl-code1) (assert = curl-code1 0) -(define curl-code2 (curl-easy-setopt handle CURLOPT-URL url-pointer)) +(define curl-code2 (curl-easy-setopt handle CURLOPT-URL (pffi-string->pointer url))) (debug curl-code2) (assert = curl-code2 0)