From eec2f40c440af8b0a2b53826b45163efeb068e35 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Mon, 24 Mar 2025 21:30:09 +0200 Subject: [PATCH] Fixes for moving to '() form of argument passing --- ' | 986 +++++++++++++++++++++++++++++++ README.md | 12 +- retropikzel/pffi.sld | 8 +- retropikzel/pffi/chibi.scm | 4 +- retropikzel/pffi/chicken5.scm | 34 +- retropikzel/pffi/gauche.scm | 2 +- retropikzel/pffi/racket.scm | 4 +- retropikzel/pffi/sagittarius.scm | 4 +- retropikzel/pffi/shared/main.scm | 5 +- tests/compliance.scm | 62 +- 10 files changed, 1051 insertions(+), 70 deletions(-) create mode 100644 ' diff --git a/' b/' new file mode 100644 index 0000000..e0eb69b --- /dev/null +++ b/' @@ -0,0 +1,986 @@ +(import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (retropikzel pffi)) + +(define header-count 1) + +(define print-header + (lambda (title) + (set-tag title) + (display "=========================================") + (newline) + (display header-count) + (display " ") + (display title) + (newline) + (display "=========================================") + (newline) + (set! header-count (+ header-count 1)))) + +(define count 0) +(define assert-tag 'none) + +(define set-tag + (lambda (tag) + (set! assert-tag tag) + (set! count 0))) + +(cond-expand + (gambit + (define assert + (lambda (check value-a value-b) + (let ((result (apply check (list value-a value-b)))) + (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)))))) + (else + (define-syntax assert + (syntax-rules () + ((_ check value-a value-b) + (let ((result (apply check (list value-a value-b)))) + (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)))))))) + +(define-syntax debug + (syntax-rules () + ((_ value) + (begin + (display 'value) + (display ": ") + (write value) + (newline))))) + +;; pffi-init + +(print-header 'pffi-init) + +(pffi-init) + +;; pffi-type? + +(print-header 'pffi-type?) + +(debug (pffi-type? 'int8)) +(assert equal? (pffi-type? 'int8) #t) +(debug (pffi-type? 'uint8)) +(assert equal? (pffi-type? 'uint8) #t) +(debug (pffi-type? 'int16)) +(assert equal? (pffi-type? 'int16) #t) +(debug (pffi-type? 'uint16)) +(assert equal? (pffi-type? 'uint16) #t) +(debug (pffi-type? 'int32)) +(assert equal? (pffi-type? 'int32) #t) +(debug (pffi-type? 'uint32)) +(assert equal? (pffi-type? 'uint32) #t) +(debug (pffi-type? 'int64)) +(assert equal? (pffi-type? 'int64) #t) +(debug (pffi-type? 'uint64)) +(assert equal? (pffi-type? 'uint64) #t) +(debug (pffi-type? 'char)) +(assert equal? (pffi-type? 'char) #t) +(debug (pffi-type? 'unsigned-char)) +(assert equal? (pffi-type? 'unsigned-char) #t) +(debug (pffi-type? 'short)) +(assert equal? (pffi-type? 'short) #t) +(debug (pffi-type? 'unsigned-short)) +(assert equal? (pffi-type? 'unsigned-short) #t) +(debug (pffi-type? 'int)) +(assert equal? (pffi-type? 'int) #t) +(debug (pffi-type? 'unsigned-int)) +(assert equal? (pffi-type? 'unsigned-int) #t) +(debug (pffi-type? 'long)) +(assert equal? (pffi-type? 'long) #t) +(debug (pffi-type? 'unsigned-long)) +(assert equal? (pffi-type? 'unsigned-long) #t) +(debug (pffi-type? 'float)) +(assert equal? (pffi-type? 'float) #t) +(debug (pffi-type? 'double)) +(assert equal? (pffi-type? 'double) #t) +(debug (pffi-type? 'pointer)) +(assert equal? (pffi-type? 'pointer) #t) +(debug (pffi-type? 'void)) +(assert equal? (pffi-type? 'void) #t) +(debug (pffi-type? 'callback)) +(assert equal? (pffi-type? 'callback) #t) + +;; pffi-size-of + +(print-header 'pffi-size-of) + +(define size-int8 (pffi-size-of 'int8)) +(debug size-int8) +(assert equal? (number? size-int8) #t) +(assert = size-int8 1) + +(define size-uint8 (pffi-size-of 'uint8)) +(debug size-uint8) +(assert equal? (number? size-uint8) #t) +(assert = size-uint8 1) + +(assert equal? (number? (pffi-size-of 'uint8)) #t) +(define size-int16 (pffi-size-of 'int16)) +(debug size-int16) +(assert equal? (number? size-int16) #t) +(assert = size-int16 2) + +(assert equal? (number? (pffi-size-of 'int16)) #t) +(define size-uint16 (pffi-size-of 'uint16)) +(debug size-uint16) +(assert equal? (number? size-uint16) #t) +(assert = size-uint16 2) + +(assert equal? (number? (pffi-size-of 'uint16)) #t) +(define size-int32 (pffi-size-of 'int32)) +(debug size-int32) +(assert equal? (number? size-int32) #t) +(assert = size-int32 4) + +(assert equal? (number? (pffi-size-of 'int32)) #t) +(define size-uint32 (pffi-size-of 'uint32)) +(debug size-uint32) +(assert equal? (number? size-uint32) #t) +(assert = size-uint32 4) + +(assert equal? (number? (pffi-size-of 'uint32)) #t) +(define size-int64 (pffi-size-of 'int64)) +(debug size-int64) +(assert equal? (number? size-int64) #t) +(assert = size-int64 8) + +(assert equal? (number? (pffi-size-of 'int64)) #t) +(define size-uint64 (pffi-size-of 'uint64)) +(debug size-uint64) +(assert equal? (number? size-uint64) #t) +(assert = size-uint64 8) + +(assert equal? (number? (pffi-size-of 'uint64)) #t) +(define size-char (pffi-size-of 'char)) +(debug size-char) +(assert equal? (number? size-char) #t) +(assert = size-char 1) + +(assert equal? (number? (pffi-size-of 'char)) #t) +(define size-unsigned-char (pffi-size-of 'unsigned-char)) +(debug size-unsigned-char) +(assert equal? (number? size-unsigned-char) #t) +(assert = size-unsigned-char 1) + +(assert equal? (number? (pffi-size-of 'unsigned-char)) #t) +(define size-short (pffi-size-of 'short)) +(debug size-short) +(assert equal? (number? size-short) #t) +(assert = size-short 2) + +(assert equal? (number? (pffi-size-of 'short)) #t) +(define size-unsigned-short (pffi-size-of 'unsigned-short)) +(debug size-unsigned-short) +(assert equal? (number? size-unsigned-short) #t) +(assert = size-unsigned-short 2) + +(assert equal? (number? (pffi-size-of 'unsigned-short)) #t) +(define size-int (pffi-size-of 'int)) +(debug size-int) +(assert equal? (number? size-int) #t) +(assert = size-int 4) + +(assert equal? (number? (pffi-size-of 'int)) #t) +(define size-unsigned-int (pffi-size-of 'unsigned-int)) +(debug size-unsigned-int) +(assert equal? (number? size-unsigned-int) #t) +(assert = size-unsigned-int 4) + +(cond-expand + (i386 + (assert equal? (number? (pffi-size-of 'long)) #t) + (define size-long (pffi-size-of 'long)) + (debug size-long) + (assert equal? (number? size-long) #t) + (assert = size-long 4)) + (else + (assert equal? (number? (pffi-size-of 'long)) #t) + (define size-long (pffi-size-of 'long)) + (debug size-long) + (assert equal? (number? size-long) #t) + (assert = size-long 8))) + +(cond-expand + (i386 + (assert equal? (number? (pffi-size-of 'unsigned-long)) #t) + (define size-unsigned-long (pffi-size-of 'unsigned-long)) + (debug size-unsigned-long) + (assert equal? (number? size-unsigned-long) #t) + (assert = size-unsigned-long 4)) + (else + (assert equal? (number? (pffi-size-of 'long)) #t) + (define size-unsigned-long (pffi-size-of 'unsigned-long)) + (debug size-unsigned-long) + (assert equal? (number? size-unsigned-long) #t) + (assert = size-unsigned-long 8))) + +(assert equal? (number? (pffi-size-of 'float)) #t) +(define size-float (pffi-size-of 'float)) +(debug size-float) +(assert equal? (number? size-float) #t) +(assert = size-float 4) + +(assert equal? (number? (pffi-size-of 'double)) #t) +(define size-double (pffi-size-of 'double)) +(debug size-double) +(assert equal? (number? size-double) #t) +(assert = size-double 8) + +(cond-expand + (i386 + (define size-pointer (pffi-size-of 'pointer)) + (debug size-pointer) + (assert equal? (number? size-pointer) #t) + (assert = size-pointer 4)) + (else + (define size-pointer (pffi-size-of 'pointer)) + (debug size-pointer) + (assert equal? (number? size-pointer) #t) + (assert = size-pointer 8))) + +;; pffi-align-of + +(print-header 'pffi-align-of) + +(define align-int8 (pffi-align-of 'int8)) +(debug align-int8) +(assert equal? (number? align-int8) #t) +(assert = align-int8 1) + +(define align-uint8 (pffi-align-of 'uint8)) +(debug align-uint8) +(assert equal? (number? align-uint8) #t) +(assert = align-uint8 1) + +(assert equal? (number? (pffi-align-of 'uint8)) #t) +(define align-int16 (pffi-align-of 'int16)) +(debug align-int16) +(assert equal? (number? align-int16) #t) +(assert = align-int16 2) + +(assert equal? (number? (pffi-align-of 'int16)) #t) +(define align-uint16 (pffi-align-of 'uint16)) +(debug align-uint16) +(assert equal? (number? align-uint16) #t) +(assert = align-uint16 2) + +(assert equal? (number? (pffi-align-of 'uint16)) #t) +(define align-int32 (pffi-align-of 'int32)) +(debug align-int32) +(assert equal? (number? align-int32) #t) +(assert = align-int32 4) + +(assert equal? (number? (pffi-align-of 'int32)) #t) +(define align-uint32 (pffi-align-of 'uint32)) +(debug align-uint32) +(assert equal? (number? align-uint32) #t) +(assert = align-uint32 4) + +(assert equal? (number? (pffi-align-of 'uint32)) #t) +(define align-int64 (pffi-align-of 'int64)) +(debug align-int64) +(assert equal? (number? align-int64) #t) +(assert = align-int64 8) + +(assert equal? (number? (pffi-align-of 'int64)) #t) +(define align-uint64 (pffi-align-of 'uint64)) +(debug align-uint64) +(assert equal? (number? align-uint64) #t) +(assert = align-uint64 8) + +(assert equal? (number? (pffi-align-of 'uint64)) #t) +(define align-char (pffi-align-of 'char)) +(debug align-char) +(assert equal? (number? align-char) #t) +(assert = align-char 1) + +(assert equal? (number? (pffi-align-of 'char)) #t) +(define align-unsigned-char (pffi-align-of 'unsigned-char)) +(debug align-unsigned-char) +(assert equal? (number? align-unsigned-char) #t) +(assert = align-unsigned-char 1) + +(assert equal? (number? (pffi-align-of 'unsigned-char)) #t) +(define align-short (pffi-align-of 'short)) +(debug align-short) +(assert equal? (number? align-short) #t) +(assert = align-short 2) + +(assert equal? (number? (pffi-align-of 'short)) #t) +(define align-unsigned-short (pffi-align-of 'unsigned-short)) +(debug align-unsigned-short) +(assert equal? (number? align-unsigned-short) #t) +(assert = align-unsigned-short 2) + +(assert equal? (number? (pffi-align-of 'unsigned-short)) #t) +(define align-int (pffi-align-of 'int)) +(debug align-int) +(assert equal? (number? align-int) #t) +(assert = align-int 4) + +(assert equal? (number? (pffi-align-of 'int)) #t) +(define align-unsigned-int (pffi-align-of 'unsigned-int)) +(debug align-unsigned-int) +(assert equal? (number? align-unsigned-int) #t) +(assert = align-unsigned-int 4) + +(cond-expand + (i386 + (assert equal? (number? (pffi-align-of 'long)) #t) + (define align-long (pffi-align-of 'long)) + (debug align-long) + (assert equal? (number? align-long) #t) + (assert = align-long 4)) + (else + (assert equal? (number? (pffi-align-of 'long)) #t) + (define align-long (pffi-align-of 'long)) + (debug align-long) + (assert equal? (number? align-long) #t) + (assert = align-long 8))) + +(cond-expand + (i386 + (assert equal? (number? (pffi-align-of 'unsigned-long)) #t) + (define align-unsigned-long (pffi-align-of 'unsigned-long)) + (debug align-unsigned-long) + (assert equal? (number? align-unsigned-long) #t) + (assert = align-unsigned-long 4)) + (else + (assert equal? (number? (pffi-align-of 'long)) #t) + (define align-unsigned-long (pffi-align-of 'unsigned-long)) + (debug align-unsigned-long) + (assert equal? (number? align-unsigned-long) #t) + (assert = align-unsigned-long 8))) + +(assert equal? (number? (pffi-align-of 'float)) #t) +(define align-float (pffi-align-of 'float)) +(debug align-float) +(assert equal? (number? align-float) #t) +(assert = align-float 4) + +(assert equal? (number? (pffi-align-of 'double)) #t) +(define align-double (pffi-align-of 'double)) +(debug align-double) +(assert equal? (number? align-double) #t) +(assert = align-double 8) + +(cond-expand + (i386 + (define align-pointer (pffi-align-of 'pointer)) + (debug align-pointer) + (assert equal? (number? align-pointer) #t) + (assert = align-pointer 4)) + (else + (define align-pointer (pffi-align-of 'pointer)) + (debug align-pointer) + (assert equal? (number? align-pointer) #t) + (assert = align-pointer 8))) + +;; pffi-define-library + +(print-header 'pffi-define-library) + +(cond-expand + (windows (pffi-define-library libc-stdlib + '("stdlib.h") + "ucrtbase" + '((additional-versions ("0" "6"))))) + (else (pffi-define-library libc-stdlib + '("stdlib.h") + "c" + '((additional-versions ("0" "6")))))) + +(debug libc-stdlib) + +(cond-expand + (windows (pffi-define-library libc-stdio + '("stdio.h") + "ucrtbase" + '((additional-versions ("0" "6"))))) + (else (pffi-define-library libc-stdio + '("stdio.h") + "c" + '((additional-versions ("0" "6")))))) + +(debug libc-stdio) + +(pffi-define-library c-testlib + '("libtest.h") + "test" + '((additional-paths ("." "./tests")))) + +(debug c-testlib) + +;; pffi-pointer-null + +(print-header 'pffi-pointer-null) + +(define null-pointer (pffi-pointer-null)) +(debug null-pointer) +(assert equal? (pffi-pointer-null? null-pointer) #t) + +;; pffi-pointer-null? + +(print-header 'pffi-pointer-null?) + +(define is-null-pointer (pffi-pointer-null)) +(debug is-null-pointer) +(assert equal? (pffi-pointer-null? is-null-pointer) #t) +(assert equal? (pffi-pointer-null? 100) #f) +(assert equal? (pffi-pointer-null? 'bar) #f) + +;; pffi-pointer-allocate + +(print-header 'pffi-pointer-allocate) + +(define test-pointer (pffi-pointer-allocate 100)) +(debug test-pointer) +(assert equal? (pffi-pointer? test-pointer) #t) +;(assert equal? (pffi-pointer? 0) #f) +;(assert equal? (pffi-pointer? #t) #f) +;(assert equal? (pffi-pointer? "Hello world") #f) +(assert equal? (pffi-pointer-null? test-pointer) #f) + +;; pffi-pointer-address + +(print-header 'pffi-pointer-allocate) + +(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) +;(assert equal? (> (pffi-pointer-address test-pointer1) 0) #t) + +;; pffi-pointer? + +(print-header 'pffi-pointer?) + +(define is-pointer (pffi-pointer-allocate 100)) +(debug is-pointer) +(assert equal? (pffi-pointer? is-pointer) #t) +;(assert equal? (pffi-pointer? 100) #f) +(assert equal? (pffi-pointer? 'bar) #f) + +;; pffi-pointer-free + +(print-header 'pffi-pointer-free) + +(define pointer-to-be-freed (pffi-pointer-allocate 100)) +(debug pointer-to-be-freed) +(pffi-pointer-free pointer-to-be-freed) +(debug pointer-to-be-freed) + +;; pffi-pointer-set! and pffi-pointer-get 1/2 + +(print-header "pffi-pointer-set! and pffi-pointer-get 1/2") + +(define set-pointer (pffi-pointer-allocate 256)) +(define offset 64) +(define value 1) +(debug set-pointer) +(debug offset) +(debug value) + +(cond-expand + (gambit + (define test-type + (lambda (type) + (begin + (pffi-pointer-set! set-pointer type offset value) + (assert = (pffi-pointer-get set-pointer type offset) value))))) + (else + (define-syntax test-type + (syntax-rules () + ((_ type) + (begin + (pffi-pointer-set! set-pointer type offset value) + (assert = (pffi-pointer-get set-pointer type offset) value))))))) + +(test-type 'int8) +(test-type 'uint8) +(test-type 'int16) +(test-type 'uint16) +(test-type 'int32) +(test-type 'uint32) +(test-type 'int64) +(test-type 'uint64) +(test-type 'short) +(test-type 'unsigned-short) +(test-type 'int) +(test-type 'unsigned-int) +(test-type 'long) +(test-type 'unsigned-long) + +(pffi-pointer-set! set-pointer 'char offset #\X) +(debug (pffi-pointer-get set-pointer 'char offset)) +(assert char=? (pffi-pointer-get set-pointer 'char offset) #\X) + +(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) + +; pffi-struct-make + +(print-header "pffi-struct") + +(define struct1 (pffi-struct-make 'test '((int . r) (int . g) (int . b)))) +(debug struct1) +(debug (pffi-size-of struct1)) +(assert = (pffi-size-of struct1) 12) + +(define struct2 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) +(debug struct2) +(debug (pffi-size-of struct2)) +(assert = (pffi-size-of struct2) 8) + +(define struct3 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) +(debug struct3) +(debug (pffi-size-of struct3)) +(assert = (pffi-size-of struct3) 8) + +(define struct4 (pffi-struct-make 'test '((int8 . r) (pointer . a) (int8 . g) (int . b)))) +(debug struct4) +(debug (pffi-size-of struct4)) +(assert = (pffi-size-of struct4) 24) + +(define struct5 (pffi-struct-make 'test '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b)))) +(debug struct5) +(debug (pffi-size-of struct5)) +(assert = (pffi-size-of struct5) 24) + +(define struct6 (pffi-struct-make 'test '((int8 . a) + (char . b) + (double . c) + (char . d) + (pointer . e) + (float . f) + (pointer . g) + (int8 . h) + (pointer . i) + (int . j) + (int . k) + (int . l) + (double . m) + (float . n)))) +(debug struct6) +(debug (pffi-size-of struct6)) +(assert = (pffi-size-of struct6) 96) + +;; pffi-string->pointer + +(print-header 'pffi-string->pointer) + +(define string-pointer (pffi-string->pointer "Hello world")) +(debug string-pointer) +(debug (pffi-pointer->string string-pointer)) +(assert equal? (pffi-pointer? string-pointer) #t) +(assert equal? (pffi-pointer-null? string-pointer) #f) +(debug (pffi-pointer-get string-pointer 'char 0)) +(assert char=? (pffi-pointer-get string-pointer 'char 0) #\H) +(debug (pffi-pointer-get string-pointer 'char 1)) +(assert char=? (pffi-pointer-get string-pointer 'char 1) #\e) +(debug (pffi-pointer-get string-pointer 'char 2)) +(assert char=? (pffi-pointer-get string-pointer 'char 2) #\l) +(debug (pffi-pointer-get string-pointer 'char 3)) +(assert char=? (pffi-pointer-get string-pointer 'char 3) #\l) +(debug (pffi-pointer-get string-pointer 'char 4)) +(assert char=? (pffi-pointer-get string-pointer 'char 4) #\o) +(debug (pffi-pointer-get string-pointer 'char 10)) +(assert char=? (pffi-pointer-get string-pointer 'char 10) #\d) + +;; 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-get + +(print-header "pffi-pointer-get") + +(define hello-string "hello") +(define hello-string-pointer (pffi-string->pointer hello-string)) + +(debug (pffi-pointer-get hello-string-pointer 'char 0)) +(assert char=? (pffi-pointer-get hello-string-pointer 'char 0) #\h) +(debug (pffi-pointer-get hello-string-pointer 'char 1)) +(assert char=? (pffi-pointer-get hello-string-pointer 'char 1) #\e) +(debug (pffi-pointer-get hello-string-pointer 'char 4)) +(assert char=? (pffi-pointer-get hello-string-pointer 'char 4) #\o) + +;; pffi-pointer-set! and pffi-pointer-get 2/2 + +(print-header "pffi-pointer-set! and pffi-pointer-get 2/2") + +(define pointer-to-be-set (pffi-string->pointer "FOOBAR")) +(debug pointer-to-be-set) +(debug (pffi-pointer->string 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) +(debug (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))) +(assert equal? + (string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") + #t) + +(define string-to-be-set "FOOBAR") +(debug string-to-be-set) +(pffi-pointer-set! set-pointer 'pointer offset (pffi-string->pointer string-to-be-set)) +(assert string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") + +;; pffi-define + +(print-header 'pffi-define) + +(pffi-define c-abs libc-stdlib 'abs 'int '(int)) +(debug c-abs) +(define absoluted (c-abs -2)) +(debug absoluted) +(assert = absoluted 2) + +(pffi-define c-puts libc-stdlib 'puts 'int '(pointer)) +(debug c-puts) +(define chars-written (c-puts (pffi-string->pointer "puts: Hello from testing, I am C function puts"))) +(debug chars-written) +(assert = chars-written 47) + +(pffi-define c-atoi libc-stdlib 'atoi 'int '(pointer)) +(assert = (c-atoi (pffi-string->pointer "100")) 100) + +(pffi-define c-fopen libc-stdio 'fopen 'pointer '(pointer pointer)) +(define output-file (c-fopen (pffi-string->pointer "testfile.test") + (pffi-string->pointer "w"))) +(debug output-file) +(pffi-define c-fprintf libc-stdio 'fprintf 'int '(pointer pointer)) +(define characters-written + (c-fprintf output-file (pffi-string->pointer "Hello world"))) +(debug characters-written) +(assert equal? (= characters-written 11) #t) +(pffi-define c-fclose libc-stdio 'fclose 'int '(pointer)) +(define closed-status (c-fclose output-file)) +(debug closed-status) +(assert equal? (= closed-status 0) #t) +(assert equal? (file-exists? "testfile.test") #t) +(assert equal? (string=? (with-input-from-file "testfile.test" + (lambda () (read-line))) + "Hello world") #t) + +(pffi-define c-takes-no-args c-testlib 'takes_no_args 'void '()) +(debug c-takes-no-args) +(c-takes-no-args) + +(pffi-define c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int (list)) +(debug c-takes-no-args) +(define takes-no-args-returns-int-result (c-takes-no-args-returns-int)) +(assert equal? (= takes-no-args-returns-int-result 0) #t) + +;; pffi-struct-get + +(print-header 'pffi-struct-get) + +(pffi-define c-init-struct c-testlib 'init_struct 'pointer (list 'pointer)) +(pffi-define c-check-offset c-testlib 'check_offset 'void (list 'int 'int)) +(define struct-test (pffi-struct-make 'test + '((int8 . a) + (char . b) + (double . c) + (char . d) + (pointer . e) + (float . f) + (pointer . g) + (int8 . h) + (pointer . i) + (int . j) + (int . k) + (int . l) + (double . m) + (float . n)))) +(c-check-offset 1 (pffi-struct-offset-get struct-test 'a)) +(c-check-offset 2 (pffi-struct-offset-get struct-test 'b)) +(c-check-offset 3 (pffi-struct-offset-get struct-test 'c)) +(c-check-offset 4 (pffi-struct-offset-get struct-test 'd)) +(c-check-offset 5 (pffi-struct-offset-get struct-test 'e)) +(c-check-offset 6 (pffi-struct-offset-get struct-test 'f)) +(c-check-offset 7 (pffi-struct-offset-get struct-test 'g)) +(c-check-offset 8 (pffi-struct-offset-get struct-test 'h)) +(c-check-offset 9 (pffi-struct-offset-get struct-test 'i)) +(c-check-offset 10 (pffi-struct-offset-get struct-test 'j)) +(c-check-offset 11 (pffi-struct-offset-get struct-test 'k)) +(c-check-offset 12 (pffi-struct-offset-get struct-test 'l)) +(c-check-offset 13 (pffi-struct-offset-get struct-test 'm)) +(c-check-offset 14 (pffi-struct-offset-get struct-test 'n)) +(debug struct-test) +(c-init-struct (pffi-struct-pointer struct-test)) +(debug struct-test) + +(debug (pffi-struct-get struct-test 'a)) +(assert = (pffi-struct-get struct-test 'a) 1) +(debug (pffi-struct-get struct-test 'b)) +(assert char=? (pffi-struct-get struct-test 'b) #\b) +(debug (pffi-struct-get struct-test 'c)) +(assert = (pffi-struct-get struct-test 'c) 3.0) +(debug (pffi-struct-get struct-test 'd)) +(assert char=? (pffi-struct-get struct-test 'd) #\d) +(debug (pffi-struct-get struct-test 'e)) +(debug (pffi-pointer-null? (pffi-struct-get struct-test 'e))) +(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'e)) #t) +(debug (pffi-struct-get struct-test 'f)) +(assert = (pffi-struct-get struct-test 'f) 6.0) +(debug (pffi-struct-get struct-test 'g)) +(debug (pffi-pointer->string (pffi-struct-get struct-test 'g))) +(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t) +(debug (pffi-struct-get struct-test 'h)) +(assert = (pffi-struct-get struct-test 'h) 8) +(debug (pffi-struct-get struct-test 'i)) +(debug (pffi-pointer-null? (pffi-struct-get struct-test 'i))) +(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'i)) #t) +(debug (pffi-struct-get struct-test 'j)) +(assert = (pffi-struct-get struct-test 'j) 10) +(debug (pffi-struct-get struct-test 'k)) +(assert = (pffi-struct-get struct-test 'k) 11) +(debug (pffi-struct-get struct-test 'l)) +(assert = (pffi-struct-get struct-test 'l) 12) +(debug (pffi-struct-get struct-test 'm)) +(assert = (pffi-struct-get struct-test 'm) 13.0) +(debug (pffi-struct-get struct-test 'n)) +(assert = (pffi-struct-get struct-test 'n) 14.0) + +;; pffi-struct-set! 1 + +(print-header "pffi-struct-set! 1") + +(pffi-define c-test-check c-testlib 'test_check 'int (list 'pointer)) +(define struct-test1 (pffi-struct-make 'test + '((int8 . a) + (char . b) + (double . c) + (char . d) + (pointer . e) + (float . f) + (pointer . g) + (int8 . h) + (pointer . i) + (int . j) + (int . k) + (int . l) + (double . m) + (float . n)))) +(pffi-struct-set! struct-test1 'a 1) +(pffi-struct-set! struct-test1 'b #\b) +(pffi-struct-set! struct-test1 'c 3.0) +(pffi-struct-set! struct-test1 'd #\d) +(pffi-struct-set! struct-test1 'e (pffi-pointer-null)) +(pffi-struct-set! struct-test1 'f 6.0) +(pffi-struct-set! struct-test1 'g (pffi-string->pointer "foo")) +(pffi-struct-set! struct-test1 'h 8) +(pffi-struct-set! struct-test1 'i (pffi-pointer-null)) +(pffi-struct-set! struct-test1 'j 10) +(pffi-struct-set! struct-test1 'k 11) +(pffi-struct-set! struct-test1 'l 12) +(pffi-struct-set! struct-test1 'm 13.0) +(pffi-struct-set! struct-test1 'n 14.0) +(c-test-check (pffi-struct-pointer struct-test1)) + +;; pffi-struct-make with pointer + +(print-header "pffi-struct-make with pointer") + +(pffi-define c-test-new c-testlib 'test_new 'pointer (list)) +(define struct-test2-pointer (c-test-new)) +(define struct-test2 (pffi-struct-make 'test + '((int8 . a) + (char . b) + (double . c) + (char . d) + (pointer . e) + (float . f) + (pointer . g) + (int8 . h) + (pointer . i) + (int . j) + (int . k) + (int . l) + (double . m) + (float . n)) + struct-test2-pointer)) +(debug struct-test2) + +(debug (pffi-pointer-get struct-test2-pointer 'int8 0)) +(debug (pffi-struct-get struct-test2 'a)) +(assert = (pffi-struct-get struct-test2 'a) 1) +(debug (pffi-pointer-get struct-test2-pointer 'char 1)) +(debug (pffi-struct-get struct-test2 'b)) +(assert char=? (pffi-struct-get struct-test2 'b) #\b) +(debug (pffi-struct-get struct-test2 'c)) +(assert = (pffi-struct-get struct-test2 'c) 3) +(debug (pffi-struct-get struct-test2 'd)) +(assert char=? (pffi-struct-get struct-test2 'd) #\d) +(debug (pffi-struct-get struct-test2 'e)) +(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'e))) +(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test2 'e)) #t) +(debug (pffi-struct-get struct-test2 'f)) +(assert = (pffi-struct-get struct-test2 'f) 6.0) +(debug (pffi-pointer->string (pffi-struct-get struct-test2 'g))) +(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t) +(debug (pffi-struct-get struct-test2 'h)) +(assert = (pffi-struct-get struct-test2 'h) 8) +(debug (pffi-struct-get struct-test2 'i)) +(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'i))) +(assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test2 'i) #t) +(debug (pffi-struct-get struct-test2 'j)) +(assert = (pffi-struct-get struct-test2 'j) 10) +(debug (pffi-struct-get struct-test2 'k)) +(assert = (pffi-struct-get struct-test2 'k) 11) +(debug (pffi-struct-get struct-test2 'l)) +(assert = (pffi-struct-get struct-test2 'l) 12) +(debug (pffi-struct-get struct-test2 'm)) +(assert = (pffi-struct-get struct-test2 'm) 13.0) +(debug (pffi-struct-get struct-test2 'n)) +(assert = (pffi-struct-get struct-test2 'n) 14.0) + +;; pffi-struct-dereference + +;(print-header "pffi-struct-dereference 1") +;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int (list 'struct)) +#;(define struct-color (pffi-struct-make 'color '((int8 . r) + (int8 . g) + (int8 . b) + (int8 . a)))) +;(debug (pffi-struct-set! struct-color 'r 100)) +;(debug (pffi-struct-set! struct-color 'g 101)) +;(debug (pffi-struct-set! struct-color 'b 102)) +;(debug (pffi-struct-set! struct-color 'a 103)) +;(assert = (c-color-check-by-value (pffi-struct-dereference struct-color)) 0) + +;(print-header "pffi-struct-dereference 2") + +;(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int (list 'struct)) +#;(define struct-test3 (pffi-struct-make 'test + '((int8 . a) + (char . b) + (double . c) + (char . d) + (pointer . e) + (float . f) + (pointer . g) + (int8 . h) + (pointer . i) + (int . j) + (int . k) + (int . l) + (double . m) + (float . n)))) +;(debug (pffi-struct-set! struct-test3 'a 1)) +;(debug (pffi-struct-set! struct-test3 'b #\b)) +;(debug (pffi-struct-set! struct-test3 'c 3.0)) +;(debug (pffi-struct-set! struct-test3 'd #\d)) +;(debug (pffi-struct-set! struct-test3 'e (pffi-pointer-null))) +;(debug (pffi-struct-set! struct-test3 'f 6.0)) +;(debug (pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo"))) +;(debug (pffi-struct-set! struct-test3 'h 8)) +;(debug (pffi-struct-set! struct-test3 'i (pffi-pointer-null))) +;(debug (pffi-struct-set! struct-test3 'j 10)) +;(debug (pffi-struct-set! struct-test3 'k 11)) +;(debug (pffi-struct-set! struct-test3 'l 12)) +;(debug (pffi-struct-set! struct-test3 'm 13.0)) +;(debug (pffi-struct-set! struct-test3 'n 14.0)) +;(debug (pffi-struct-get struct-test3 'a)) +;(debug (pffi-struct-get struct-test3 'b)) +;(debug (pffi-struct-get struct-test3 'c)) +;(debug (pffi-struct-get struct-test3 'd)) +;(debug (pffi-struct-get struct-test3 'e)) +;(debug (pffi-struct-get struct-test3 'f)) +;(debug (pffi-struct-get struct-test3 'g)) +;(debug (pffi-struct-get struct-test3 'h)) +;(debug (pffi-struct-get struct-test3 'i)) +;(debug (pffi-struct-get struct-test3 'j)) +;(debug (pffi-struct-get struct-test3 'k)) +;(debug (pffi-struct-get struct-test3 'l)) +;(debug (pffi-struct-get struct-test3 'm)) +;(debug (pffi-struct-get struct-test3 'n)) +;(c-test-check-by-value (pffi-struct-dereference struct-test3)) + +;; pffi-define-callback + +(print-header 'pffi-define-callback) + +(define array (pffi-pointer-allocate (* (pffi-size-of 'int) 3))) +(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 0) 3) +(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2) +(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1) + +(pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback)) + +(pffi-define-callback compare + 'int + (list 'pointer 'pointer) + (lambda (pointer-a pointer-b) + (let ((a (pffi-pointer-get pointer-a 'int 0)) + (b (pffi-pointer-get pointer-b 'int 0))) + (cond ((> a b) 1) + ((= a b) 0) + ((< a b) -1))))) +(write compare) +(newline) + +(define unsorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) + (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) + (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) +(debug unsorted) +(assert equal? unsorted (list 3 2 1)) + +(qsort array 3 (pffi-size-of 'int) compare) + +(define sorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) + (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) + (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) +(debug sorted) +(assert equal? sorted (list 1 2 3)) + +(exit 0) diff --git a/README.md b/README.md index eac63fb..f503c34 100644 --- a/README.md +++ b/README.md @@ -98,8 +98,8 @@ changing anymore and some implementations are in **beta**. - No way to pass structs by value - Most implementations are missing callback support -- Always pass arguments to pffi functions/macros as (list 1 2 3) and not '(1 2 3) -- Always pass pffi-define-callback procedure as lambda on place +- Always pass arguments to pffi functions/macros as '(1 2 3) and not (list 1 2 3) +- Always pass pffi-define-callback procedure as lambda in place ## Roadmap @@ -292,7 +292,7 @@ Example: (cond-expand (windows (pffi-define-library libc-stdlib - (list "stdlib.h") + '("stdlib.h") "ucrtbase" '((additional-versions ("0" "6")) (additiona-paths ("."))))) @@ -433,7 +433,7 @@ Defines a new foreign function to be used from Scheme code. For example: (cond-expand (windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '(""))) (else (pffi-define-library libc-stdlib '("stdlib.h") "c" '("" "6")))) - (pffi-define c-puts libc-stdlib 'puts 'int (list 'pointer)) + (pffi-define c-puts libc-stdlib 'puts 'int '(pointer)) (c-puts "Message brought to you by FFI!") #### pffi-define-callback @@ -448,12 +448,12 @@ Defines a new Sceme function to be used as callback to C code. For example: (else (pffi-define-library '("stdlib.h") "c" '("" "6")))) ; Define C function that takes a callback - (pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback)) + (pffi-define qsort libc-stdlib 'qsort 'void '(pointer int int callback)) ; Define our callback (pffi-define-callback compare 'int - (list 'pointer 'pointer) + '(pointer pointer) (lambda (pointer-a pointer-b) (let ((a (pffi-pointer-get pointer-a 'int 0)) (b (pffi-pointer-get pointer-b 'int 0))) diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index 069b2fe..b91734c 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -66,7 +66,8 @@ pffi-struct-get pffi-struct-set! pffi-define - pffi-define-callback)) + ;pffi-define-callback + )) (chicken6 (import (scheme base) (scheme write) @@ -403,7 +404,8 @@ pffi-struct-get pffi-struct-set! pffi-define - pffi-define-callback)) + ;pffi-define-callback + )) (skint (import (scheme base) (scheme write) @@ -541,6 +543,6 @@ (stklos (include "pffi/stklos.scm")) (tr7 (include "pffi/tr7.scm")) (ypsilon (include "pffi/ypsilon.scm"))) + ;(include "pffi/shared/union.scm") (include "pffi/shared/struct.scm") - (include "pffi/shared/union.scm") (include "pffi/shared/main.scm")) diff --git a/retropikzel/pffi/chibi.scm b/retropikzel/pffi/chibi.scm index e6bef02..890bed5 100644 --- a/retropikzel/pffi/chibi.scm +++ b/retropikzel/pffi/chibi.scm @@ -26,7 +26,7 @@ (else #f)))) (define pffi-shared-object-load - (lambda (headers path . options) + (lambda (path options) (let ((shared-object (dlopen path RTLD-NOW)) (maybe-error (dlerror))) (when (not (pffi-pointer-null? maybe-error)) @@ -210,4 +210,4 @@ (syntax-rules () ((pffi-define scheme-name return-type argument-types procedure) (define scheme-name - (make-c-callback return-type argument-types procedure))))) + (make-c-callback return-type 'argument-types procedure))))) diff --git a/retropikzel/pffi/chicken5.scm b/retropikzel/pffi/chicken5.scm index 1e9afbf..05bfa22 100644 --- a/retropikzel/pffi/chicken5.scm +++ b/retropikzel/pffi/chicken5.scm @@ -57,24 +57,24 @@ ((equal? type 'callback) 'c-pointer) ((equal? type 'struct) 'c-pointer) (else (error "pffi-type->native-type -- No such pffi type" type))))) - (scheme-name (car (cdr expr))) - (c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr)))))))) - (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))) - (argument-types - (let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr))))))))) - (if (null? types) - '() - (map pffi-type->native-type (map car (map cdr types))))))) + (scheme-name (list-ref expr 1)) + (c-name (symbol->string (cadr (list-ref expr 3)))) + (return-type (pffi-type->native-type (cadr (list-ref expr 4)))) + (argument-types (map pffi-type->native-type (cadr (list-ref expr 5))))) (if (null? argument-types) `(define ,scheme-name (foreign-safe-lambda ,return-type ,c-name)) `(define ,scheme-name (foreign-safe-lambda ,return-type ,c-name ,@ argument-types))))))) -(define-syntax pffi-define-callback +#;(define-syntax pffi-define-callback (er-macro-transformer (lambda (expr rename compare) - (let* ((pffi-type->native-type ; Chicken has this procedure in three places + (let* ((debug (begin + (write (list-ref expr 4)) + (newline) + )) + (pffi-type->native-type ; Chicken has this procedure in three places (lambda (type) (cond ((equal? type 'int8) 'byte) ((equal? type 'uint8) 'unsigned-byte) @@ -99,19 +99,15 @@ ((equal? type 'callback) 'c-pointer) ((equal? type 'struct) 'c-pointer) (else (error "pffi-type->native-type -- No such pffi type" type))))) - (scheme-name (car (cdr expr))) - (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr expr))))))) - (argument-types - (let ((types (cdr (car (cdr (cdr (cdr expr))))))) - (if (null? types) - '() - (map pffi-type->native-type (map car (map cdr types)))))) - (argument-names (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))) + (scheme-name (list-ref expr 1)) + (return-type (pffi-type->native-type (cadr (list-ref expr 2)))) + (argument-types (map pffi-type->native-type (cadr (list-ref expr 3)))) + (argument-names (cadr (list-ref expr 4))) (arguments (map (lambda (name type) `(,name ,type)) argument-types argument-names)) - (procedure-body (cdr (cdr (car (cdr (cdr (cdr (cdr expr))))))))) + (procedure-body (cadr (cdr (list-ref expr 4))))) `(begin (define-external ,(cons 'external_123456789 arguments) ,return-type (begin ,@ procedure-body)) diff --git a/retropikzel/pffi/gauche.scm b/retropikzel/pffi/gauche.scm index 08a8745..ff60457 100644 --- a/retropikzel/pffi/gauche.scm +++ b/retropikzel/pffi/gauche.scm @@ -42,7 +42,7 @@ ((equal? type 'void) (size-of-void))))) (define pffi-shared-object-load - (lambda (headers path . options) + (lambda (path options) (shared-object-load path))) (define pffi-pointer-null diff --git a/retropikzel/pffi/racket.scm b/retropikzel/pffi/racket.scm index 6abd4ff..78e7b1e 100644 --- a/retropikzel/pffi/racket.scm +++ b/retropikzel/pffi/racket.scm @@ -79,9 +79,7 @@ (string-copy (cast pointer _pointer _string)))) (define pffi-shared-object-load - (lambda (header path options) - (write (cadr (assoc 'additional-versions options))) - (newline) + (lambda (path options) (if (and (not (null? options)) (assoc 'additional-versions options)) (ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions diff --git a/retropikzel/pffi/sagittarius.scm b/retropikzel/pffi/sagittarius.scm index de726ac..4ea7fd0 100644 --- a/retropikzel/pffi/sagittarius.scm +++ b/retropikzel/pffi/sagittarius.scm @@ -39,7 +39,7 @@ c-name (map pffi-type->native-type argument-types)))))) -(define-syntax pffi-define-callback +#;(define-syntax pffi-define-callback (syntax-rules () ((_ scheme-name return-type argument-types procedure) (define scheme-name @@ -102,7 +102,7 @@ (pointer->string pointer))) (define pffi-shared-object-load - (lambda (headers path options) + (lambda (path options) (open-shared-library path))) (define pffi-pointer-free diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index 192cb09..553693f 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -18,7 +18,7 @@ (define pffi-size-of (lambda (object) (cond ((pffi-struct? object) (pffi-struct-size object)) - ((pffi-union? object) (pffi-union-size object)) + ;((pffi-union? object) (pffi-union-size object)) ((pffi-type? object) (size-of-type object)) (else (error "Not pffi-struct, pffi-enum of pffi-type" object))))) @@ -222,6 +222,5 @@ (write searched-paths) (newline) (exit 1)) - (pffi-shared-object-load headers - shared-object + (pffi-shared-object-load shared-object `((additional-versions ,additional-versions))))))))))) diff --git a/tests/compliance.scm b/tests/compliance.scm index 8b7c635..25e49a0 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -678,31 +678,31 @@ (print-header 'pffi-define) -(pffi-define c-abs libc-stdlib 'abs 'int (list 'int)) +(pffi-define c-abs libc-stdlib 'abs 'int '(int)) (debug c-abs) (define absoluted (c-abs -2)) (debug absoluted) (assert = absoluted 2) -(pffi-define c-puts libc-stdlib 'puts 'int (list 'pointer)) +(pffi-define c-puts libc-stdlib 'puts 'int '(pointer)) (debug c-puts) (define chars-written (c-puts (pffi-string->pointer "puts: Hello from testing, I am C function puts"))) (debug chars-written) (assert = chars-written 47) -(pffi-define c-atoi libc-stdlib 'atoi 'int (list 'pointer)) +(pffi-define c-atoi libc-stdlib 'atoi 'int '(pointer)) (assert = (c-atoi (pffi-string->pointer "100")) 100) -(pffi-define c-fopen libc-stdio 'fopen 'pointer (list 'pointer 'pointer)) +(pffi-define c-fopen libc-stdio 'fopen 'pointer '(pointer pointer)) (define output-file (c-fopen (pffi-string->pointer "testfile.test") (pffi-string->pointer "w"))) (debug output-file) -(pffi-define c-fprintf libc-stdio 'fprintf 'int (list 'pointer 'pointer)) +(pffi-define c-fprintf libc-stdio 'fprintf 'int '(pointer pointer)) (define characters-written (c-fprintf output-file (pffi-string->pointer "Hello world"))) (debug characters-written) (assert equal? (= characters-written 11) #t) -(pffi-define c-fclose libc-stdio 'fclose 'int (list 'pointer)) +(pffi-define c-fclose libc-stdio 'fclose 'int '(pointer)) (define closed-status (c-fclose output-file)) (debug closed-status) (assert equal? (= closed-status 0) #t) @@ -711,11 +711,11 @@ (lambda () (read-line))) "Hello world") #t) -(pffi-define c-takes-no-args c-testlib 'takes_no_args 'void (list)) +(pffi-define c-takes-no-args c-testlib 'takes_no_args 'void '()) (debug c-takes-no-args) (c-takes-no-args) -(pffi-define c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int (list)) +(pffi-define c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int '()) (debug c-takes-no-args) (define takes-no-args-returns-int-result (c-takes-no-args-returns-int)) (assert equal? (= takes-no-args-returns-int-result 0) #t) @@ -724,8 +724,8 @@ (print-header 'pffi-struct-get) -(pffi-define c-init-struct c-testlib 'init_struct 'pointer (list 'pointer)) -(pffi-define c-check-offset c-testlib 'check_offset 'void (list 'int 'int)) +(pffi-define c-init-struct c-testlib 'init_struct 'pointer '(pointer)) +(pffi-define c-check-offset c-testlib 'check_offset 'void '(int int)) (define struct-test (pffi-struct-make 'test '((int8 . a) (char . b) @@ -795,7 +795,7 @@ (print-header "pffi-struct-set! 1") -(pffi-define c-test-check c-testlib 'test_check 'int (list 'pointer)) +(pffi-define c-test-check c-testlib 'test_check 'int '(pointer)) (define struct-test1 (pffi-struct-make 'test '((int8 . a) (char . b) @@ -831,7 +831,7 @@ (print-header "pffi-struct-make with pointer") -(pffi-define c-test-new c-testlib 'test_new 'pointer (list)) +(pffi-define c-test-new c-testlib 'test_new 'pointer '()) (define struct-test2-pointer (c-test-new)) (define struct-test2 (pffi-struct-make 'test '((int8 . a) @@ -887,7 +887,7 @@ ;; pffi-struct-dereference ;(print-header "pffi-struct-dereference 1") -;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int (list 'struct)) +;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int '(struct)) #;(define struct-color (pffi-struct-make 'color '((int8 . r) (int8 . g) (int8 . b) @@ -900,7 +900,7 @@ ;(print-header "pffi-struct-dereference 2") -;(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int (list 'struct)) +;(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int '(struct)) #;(define struct-test3 (pffi-struct-make 'test '((int8 . a) (char . b) @@ -948,39 +948,39 @@ ;; pffi-define-callback -(print-header 'pffi-define-callback) +;(print-header 'pffi-define-callback) -(define array (pffi-pointer-allocate (* (pffi-size-of 'int) 3))) -(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 0) 3) -(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2) -(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1) +;(define array (pffi-pointer-allocate (* (pffi-size-of 'int) 3))) +;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 0) 3) +;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2) +;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1) -(pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback)) +;(pffi-define qsort libc-stdlib 'qsort 'void '(pointer int int callback)) -(pffi-define-callback compare +#;(pffi-define-callback compare 'int - (list 'pointer 'pointer) + '(pointer pointer) (lambda (pointer-a pointer-b) (let ((a (pffi-pointer-get pointer-a 'int 0)) (b (pffi-pointer-get pointer-b 'int 0))) (cond ((> a b) 1) ((= a b) 0) ((< a b) -1))))) -(write compare) -(newline) +;(write compare) +;(newline) -(define unsorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) +#;(define unsorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) -(debug unsorted) -(assert equal? unsorted (list 3 2 1)) +;(debug unsorted) +;(assert equal? unsorted (list 3 2 1)) -(qsort array 3 (pffi-size-of 'int) compare) +;(qsort array 3 (pffi-size-of 'int) compare) -(define sorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) +#;(define sorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) -(debug sorted) -(assert equal? sorted (list 1 2 3)) +;(debug sorted) +;(assert equal? sorted (list 1 2 3)) (exit 0)