diff --git a/.gitignore b/.gitignore index 565d599..bf94be3 100644 --- a/.gitignore +++ b/.gitignore @@ -16,7 +16,8 @@ test/import pffi-define test/pffi-define size-of -test/size-of +test/* +!test/*.scm retropikzel/pffi/*/*.c retropikzel/pffi/*/*.o* retropikzel/pffi/*/*.so diff --git a/Makefile b/Makefile index 8253548..282a6f1 100644 --- a/Makefile +++ b/Makefile @@ -36,7 +36,6 @@ clean: rm -rf test/*.o* rm -rf test/*.so rm -rf test/*.meta - rm -rf test/import rm -rf test/pffi-define rm -rf test/*gambit* rm -rf test/*.link @@ -45,3 +44,4 @@ clean: rm -rf *.so rm -rf *.a rm -rf tmp + find ./test -type f -not -name "*.scm" -exec bash -c "test -x {} && rm {}" \; diff --git a/retropikzel/pffi/v0-1-0/chicken.scm b/retropikzel/pffi/v0-1-0/chicken.scm index 5b62b8c..9e59917 100644 --- a/retropikzel/pffi/v0-1-0/chicken.scm +++ b/retropikzel/pffi/v0-1-0/chicken.scm @@ -5,7 +5,8 @@ (scheme file) (scheme process-context) (chicken foreign) - (chicken syntax)) + (chicken syntax) + (chicken memory)) (export pffi-shared-object-load pffi-define pffi-size-of @@ -49,7 +50,7 @@ (define pffi-pointer? (lambda (object) - (error "Not defined"))) + (pointer? object))) (define-syntax pffi-define (er-macro-transformer @@ -92,13 +93,34 @@ `(define ,scheme-name (foreign-lambda ,return-type ,c-name ,@ argument-types))))))) - (define pffi-size-of - (lambda (type) - (error "Not defined"))) + (define-syntax pffi-size-of + (er-macro-transformer + (lambda (expr rename compare) + (let ((type (car (cdr (car (cdr expr)))))) + (cond ((equal? type 'int8) `(foreign-value "sizeof(int8_t)" int)) + ((equal? type 'uint8) `(foreign-value "sizeof(uint8_t)" int)) + ((equal? type 'int16) `(foreign-value "sizeof(int16_t)" int)) + ((equal? type 'uint16) `(foreign-value "sizeof(uint16_t)" int)) + ((equal? type 'int32) `(foreign-value "sizeof(int32_t)" int)) + ((equal? type 'uint32) `(foreign-value "sizeof(uint32_t)" int)) + ((equal? type 'int64) `(foreign-value "sizeof(int64_t)" int)) + ((equal? type 'uint64) `(foreign-value "sizeof(uint64_t)" int)) + ((equal? type 'char) `(foreign-value "sizeof(char)" int)) + ((equal? type 'unsigned-char) `(foreign-value "sizeof(unsigned char)" int)) + ((equal? type 'short) `(foreign-value "sizeof(short)" int)) + ((equal? type 'unsigned-short) `(foreign-value "sizeof(unsigned short)" int)) + ((equal? type 'int) `(foreign-value "sizeof(int)" int)) + ((equal? type 'unsigned-int) `(foreign-value "sizeof(unsigned int)" int)) + ((equal? type 'long) `(foreign-value "sizeof(long)" int)) + ((equal? type 'unsigned-long) `(foreign-value "sizeof(unsigned long)" int)) + ((equal? type 'float) `(foreign-value "sizeof(float)" int)) + ((equal? type 'double) `(foreign-value "sizeof(double)" int)) + ((equal? type 'pointer) `(foreign-value "sizeof(int)" int)) + (else `(error "pffi-size-of -- No such pffi type" type))))))) (define pffi-pointer-allocate (lambda (size) - (error "Not defined"))) + (allocate size))) (define pffi-pointer-null (lambda () @@ -106,11 +128,21 @@ (define pffi-string->pointer (lambda (string-content) - (error "Not defined"))) + (let* ((size (string-length string-content)) + (pointer (pffi-pointer-allocate size))) + (move-memory! string-content pointer size 0) + pointer))) + + (pffi-define strlen #f 'strlen 'int (list 'pointer)) (define pffi-pointer->string (lambda (pointer) - pointer)) + (if (string? pointer) + pointer + (let* ((size (strlen pointer)) + (string-content (make-string size))) + (move-memory! pointer string-content size 0) + string-content)))) (define pffi-pointer->bytevector (lambda (pointer size) @@ -128,7 +160,7 @@ (define pffi-pointer-free (lambda (pointer) - (error "Not defined"))) + (free pointer))) (define pffi-pointer-null? (lambda (pointer) @@ -136,12 +168,47 @@ (define pffi-pointer-set! (lambda (pointer type offset value) - (let ((p pointer)) - (error "Not defined")))) + (cond + ((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value)) + ((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value)) + ((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value)) + ((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value)) + ((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value)) + ((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value)) + ((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value)) + ((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value)) + ((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) value)) + ((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value)) + ((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value)) + ((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value)) + ((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-u32-set! (pointer+ pointer offset) value))))) (define pffi-pointer-get (lambda (pointer type offset) - (error "Not defined"))) + (cond + ((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset))) + ((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset))) + ((equal? type 'int16) (pointer-s16-ref (pointer+ pointer offset))) + ((equal? type 'uint16) (pointer-u16-ref (pointer+ pointer offset))) + ((equal? type 'int32) (pointer-s32-ref (pointer+ pointer offset))) + ((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset))) + ((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset))) + ((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset))) + ((equal? type 'char) (pointer-s8-ref (pointer+ pointer offset))) + ((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset))) + ((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset))) + ((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset))) + ((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-s32-ref (pointer+ pointer offset))) + ((equal? type 'pointer) (pointer-u32-ref (pointer+ pointer offset)))))) (define pffi-pointer-deref (lambda (pointer) diff --git a/retropikzel/pffi/v0-1-0/sagittarius.scm b/retropikzel/pffi/v0-1-0/sagittarius.scm index d20d9f2..f4c8e82 100644 --- a/retropikzel/pffi/v0-1-0/sagittarius.scm +++ b/retropikzel/pffi/v0-1-0/sagittarius.scm @@ -125,8 +125,6 @@ ((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 'intptr) (pointer-set-c-intptr_t! p offset value)) - ((equal? type 'uintptr) (pointer-set-c-uintptr_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)) @@ -136,7 +134,7 @@ ((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-void*! p offset value)))))) + ((equal? type 'void*) (pointer-set-c-void*! p offset value)))))) (define pffi-pointer-get (lambda (pointer type offset) @@ -150,8 +148,6 @@ ((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 'intptr_t) (pointer-ref-c-intptr_t p offset)) - ((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset)) ((equal? native-type 'char) (pointer-ref-c-char p offset)) ((equal? native-type 'short) (pointer-set-c-short p offset value)) ((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset)) diff --git a/scripts/test-runs-compilers.sh b/scripts/test-runs-compilers.sh index 28371bf..cd64492 100644 --- a/scripts/test-runs-compilers.sh +++ b/scripts/test-runs-compilers.sh @@ -1,6 +1,7 @@ -${SCHEME} ./test/import.scm -./test/import - -${SCHEME} ./test/pffi-define.scm -./test/pffi-define +for file in ./test/*.scm +do + echo "Testing ${file}" + ${SCHEME} ${file} + ${file//.scm/} +done diff --git a/scripts/test-runs-dynamic.sh b/scripts/test-runs-dynamic.sh index 7c7c7c4..70fb946 100644 --- a/scripts/test-runs-dynamic.sh +++ b/scripts/test-runs-dynamic.sh @@ -1,7 +1,6 @@ -${SCHEME} ./test/hello.scm -${SCHEME} ./test/import.scm -${SCHEME} ./test/size-of.scm -${SCHEME} ./test/pointer-set-get.scm -${SCHEME} ./test/string-to-pointer-to-string.scm -${SCHEME} ./test/pffi-define.scm +for file in ./test/*.scm +do + echo "Testing ${file}" + ${SCHEME} ${file} +done diff --git a/test/hello.scm b/test/100_hello.scm similarity index 100% rename from test/hello.scm rename to test/100_hello.scm diff --git a/test/import.scm b/test/200_import.scm similarity index 100% rename from test/import.scm rename to test/200_import.scm diff --git a/test/size-of.scm b/test/300_size-of.scm similarity index 100% rename from test/size-of.scm rename to test/300_size-of.scm diff --git a/test/39_pointer-allocate.scm b/test/39_pointer-allocate.scm new file mode 100644 index 0000000..9f6669c --- /dev/null +++ b/test/39_pointer-allocate.scm @@ -0,0 +1,14 @@ +(import (scheme base) + (scheme write) + (retropikzel pffi v0-1-0 main)) + +(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3) + (* (pffi-size-of 'uint8) 4) + (pffi-size-of 'int)))) + +(write p) +(newline) + +(pffi-pointer-free p) + + diff --git a/test/400_pointer-allocate-free.scm b/test/400_pointer-allocate-free.scm new file mode 100644 index 0000000..9f6669c --- /dev/null +++ b/test/400_pointer-allocate-free.scm @@ -0,0 +1,14 @@ +(import (scheme base) + (scheme write) + (retropikzel pffi v0-1-0 main)) + +(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3) + (* (pffi-size-of 'uint8) 4) + (pffi-size-of 'int)))) + +(write p) +(newline) + +(pffi-pointer-free p) + + diff --git a/test/401_is-pointer.scm b/test/401_is-pointer.scm new file mode 100644 index 0000000..1268e69 --- /dev/null +++ b/test/401_is-pointer.scm @@ -0,0 +1,12 @@ +(import (scheme base) + (scheme write) + (retropikzel pffi v0-1-0 main)) + +(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3) + (* (pffi-size-of 'uint8) 4) + (pffi-size-of 'int)))) + +(if (not (pffi-pointer? p)) (error "pffi-pointer? returned false when given pointer")) +(if (pffi-pointer? "Hello") (error "pffi-pointer? returned true when given not a pointer")) + + diff --git a/test/pointer-set-get.scm b/test/410_pointer-set-get.scm similarity index 61% rename from test/pointer-set-get.scm rename to test/410_pointer-set-get.scm index d040fe5..29cfa5d 100644 --- a/test/pointer-set-get.scm +++ b/test/410_pointer-set-get.scm @@ -18,11 +18,14 @@ (write p) (newline) -(write (pffi-pointer-get p - 'uint8 - (+ (* (pffi-size-of 'uint32)) - (* (pffi-size-of 'uint8) 2)) - )) -(newline) +(let ((result(pffi-pointer-get p + 'uint8 + (+ (* (pffi-size-of 'uint32)) + (* (pffi-size-of 'uint8) 2))))) + (if (not (= result 42)) + (error "pffi-pointer-get did not return 42")) + + (write result) + (newline)) diff --git a/test/500_string-to-pointer-to-string.scm b/test/500_string-to-pointer-to-string.scm new file mode 100644 index 0000000..56fb07d --- /dev/null +++ b/test/500_string-to-pointer-to-string.scm @@ -0,0 +1,17 @@ +(import (scheme base) + (scheme write) + (retropikzel pffi v0-1-0 main)) + +(define original "Hello world") + +(define p (pffi-string->pointer original)) +(write p) +(newline) + +(define s (pffi-pointer->string p)) +(if (not (string=? original s)) + (error (string-append "string from pointer is not " original) s)) +(write s) +(newline) + + diff --git a/test/pffi-define.scm b/test/600_pffi_define.scm similarity index 100% rename from test/pffi-define.scm rename to test/600_pffi_define.scm diff --git a/test/600_string-to_pointer_to_string.scm b/test/600_string-to_pointer_to_string.scm new file mode 100644 index 0000000..56fb07d --- /dev/null +++ b/test/600_string-to_pointer_to_string.scm @@ -0,0 +1,17 @@ +(import (scheme base) + (scheme write) + (retropikzel pffi v0-1-0 main)) + +(define original "Hello world") + +(define p (pffi-string->pointer original)) +(write p) +(newline) + +(define s (pffi-pointer->string p)) +(if (not (string=? original s)) + (error (string-append "string from pointer is not " original) s)) +(write s) +(newline) + + diff --git a/test/pffi-lambda.scm b/test/pffi-lambda.scm deleted file mode 100644 index b727ea4..0000000 --- a/test/pffi-lambda.scm +++ /dev/null @@ -1,11 +0,0 @@ -(import (scheme base) - (scheme write) - (retropikzel pffi v0.1.0 main)) - -(define libcurl (pffi-shared-object-auto-load "curl" (list))) - -(define curl-version (pffi-lambda libcurl 'curl_version 'string (list))) - - -(write (pffi-pointer->string (curl-version))) -(newline) diff --git a/test/sdl2.scm b/test/sdl2.scm deleted file mode 100644 index f91aed1..0000000 --- a/test/sdl2.scm +++ /dev/null @@ -1,32 +0,0 @@ -(import (scheme base) - (scheme write) - (scheme read) - (retropikzel pffi v0.1.0 main)) - - -(define sdl2 (pffi-shared-object-auto-load "SDL2" (list))) - -(pffi-call sdl2 'SDL_Init 'int '((int . 32))) - -(define window (pffi-call sdl2 - 'SDL_CreateWindow - 'pointer - (list (cons 'pointer (pffi-string->pointer "Testing pffi")) - (cons 'int 1) - (cons 'int 1) - (cons 'int 400) - (cons 'int 400) - (cons 'int 4)))) - -(define renderer (pffi-call sdl2 - 'SDL_CreateRenderer - 'pointer - (list (cons 'pointer window) - (cons 'int -1) - (cons 'int 2)))) - -(pffi-call sdl2 'SDL_RenderClear 'int (list (cons 'pointer renderer))) -(pffi-call sdl2 'SDL_RenderPresent 'int (list (cons 'pointer renderer))) - -(display (pffi-call sdl2 'SDL_Delay 'void '((int . 2000)))) - diff --git a/test/string-to-pointer-to-string.scm b/test/string-to-pointer-to-string.scm deleted file mode 100644 index e7c96e0..0000000 --- a/test/string-to-pointer-to-string.scm +++ /dev/null @@ -1,14 +0,0 @@ -(import (scheme base) - (scheme write) - (retropikzel pffi v0-1-0 main)) - - -(define p (pffi-string->pointer "Hello world")) -(write p) -(newline) - -(define s (pffi-pointer->string p)) -(write s) -(newline) - -