Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Rename pffi-define to pffi-define-function. Clean up repository.

This commit is contained in:
retropikzel 2025-04-20 07:02:57 +03:00
parent 21a30cd44c
commit facd9034a3
47 changed files with 408 additions and 1767 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -41,3 +41,4 @@ core
testfile.test testfile.test
tests/compliance tests/compliance
tests/retropikzel tests/retropikzel
*.rkt

3
Dockerfile
View File

@ -9,4 +9,5 @@ RUN apt-get update && apt-get install -y \
git make libffi8 libgc1 libssl3 libuv1 build-essential libffi-dev git make libffi8 libgc1 libssl3 libuv1 build-essential libffi-dev
COPY --from=build /usr/local-other/ /usr/local-other/ COPY --from=build /usr/local-other/ /usr/local-other/
ENV PATH=${PATH}:/usr/local-other/bin ENV PATH=${PATH}:/usr/local-other/bin
RUN git clone https://git.sr.ht/~retropikzel/compile-r7rs && cd compile-r7rs && make && make install RUN git clone https://gitea.scheme.org/Retropikzel/compile-r7rs.git --depth=1
RUN cd compile-r7rs && make && make install

2
Makefile
View File

@ -5,7 +5,7 @@ DOCKER_INIT=cd /workdir && make clean &&
VERSION=$(shell grep "version:" README.md | awk '{split\($0,a\); print a[2];}') VERSION=$(shell grep "version:" README.md | awk '{split\($0,a\); print a[2];}')
# apt-get install pandoc weasyprint # apt-get install pandoc weasyprint
docs: documentation:
mkdir -p documentation mkdir -p documentation
pandoc --standalone \ pandoc --standalone \
--template templates/documentation.html README.md \ --template templates/documentation.html README.md \

13
README.md
View File

@ -73,7 +73,7 @@ conforming to some specification.
- [pffi-array-set!](#pffi-array-set!) - [pffi-array-set!](#pffi-array-set!)
- [pffi-list->array](#pffi-list->array) - [pffi-list->array](#pffi-list->array)
- [pffi-array->list](#pffi-array->list) - [pffi-array->list](#pffi-array->list)
- [pffi-define](#pffi-define) - [pffi-define-function](#pffi-define-function)
- [pffi-define-callback](#pffi-define-callback) - [pffi-define-callback](#pffi-define-callback)
</nav> </nav>
@ -92,7 +92,6 @@ conforming to some specification.
## Non goals ## Non goals
<a name="non-goals"></a> <a name="non-goals"></a>
- To have every possible FFI feature
- Compiling of used library C code at any point - Compiling of used library C code at any point
- That is no stubs, no C code generated by the library and so on - That is no stubs, no C code generated by the library and so on
- The pffi library itself may require compilation on installation - The pffi library itself may require compilation on installation
@ -582,17 +581,17 @@ Converts given list into C array of given type.
Converts given C array into list of given type and length. Converts given C array into list of given type and length.
#### pffi-define #### pffi-define-function
<a name="pffi-define"></a> <a name="pffi-define-function"></a>
**pffi-define** scheme-name shared-object c-name return-type argument-types **pffi-define-function** scheme-name shared-object c-name return-type argument-types
Defines a new foreign function to be used from Scheme code. For example: Defines a new foreign function to be used from Scheme code. For example:
(cond-expand (cond-expand
(windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '(""))) (windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '("")))
(else (pffi-define-library libc-stdlib '("stdlib.h") "c" '("" "6")))) (else (pffi-define-library libc-stdlib '("stdlib.h") "c" '("" "6"))))
(pffi-define c-puts libc-stdlib 'puts 'int '(pointer)) (pffi-define-function c-puts libc-stdlib 'puts 'int '(pointer))
(c-puts "Message brought to you by FFI!") (c-puts "Message brought to you by FFI!")
#### pffi-define-callback #### pffi-define-callback
@ -608,7 +607,7 @@ Defines a new Sceme function to be used as callback to C code. For example:
(else (pffi-define-library '("stdlib.h") "c" '("" "6")))) (else (pffi-define-library '("stdlib.h") "c" '("" "6"))))
; Define C function that takes a callback ; Define C function that takes a callback
(pffi-define qsort libc-stdlib 'qsort 'void '(pointer int int callback)) (pffi-define-function qsort libc-stdlib 'qsort 'void '(pointer int int callback))
; Define our callback ; Define our callback
(pffi-define-callback compare (pffi-define-callback compare

813
documentation/R7RS-PFFI.html
View File

File diff suppressed because it is too large Load Diff

BIN
documentation/R7RS-PFFI.pdf
View File

Binary file not shown.

BIN
old-tests/100_hello
View File

Binary file not shown.

7
old-tests/100_hello.scm
View File

@ -1,7 +0,0 @@
(import (scheme base)
(scheme write))
(display "Hello")
(newline)

BIN
old-tests/200_import
View File

Binary file not shown.

8
old-tests/200_import.scm
View File

@ -1,8 +0,0 @@
(import (scheme base)
(scheme write)
(retropikzel r7rs-pffi version main))
(display "Hello from import.scm")
(newline)

BIN
old-tests/300_size-of
View File

Binary file not shown.

80
old-tests/300_size-of.scm
View File

@ -1,80 +0,0 @@
(import (scheme base)
(scheme write)
(retropikzel r7rs-pffi version main))
(display 'int8)
(display " ")
(display (pffi-size-of 'int8))
(newline)
(display 'uint8)
(display " ")
(display (pffi-size-of 'uint8))
(newline)
(display 'int16)
(display " ")
(display (pffi-size-of 'int16))
(newline)
(display 'uint16)
(display " ")
(display (pffi-size-of 'uint16))
(newline)
(display 'int32)
(display " ")
(display (pffi-size-of 'int32))
(newline)
(display 'uint32)
(display " ")
(display (pffi-size-of 'uint32))
(newline)
(display 'int64)
(display " ")
(display (pffi-size-of 'int64))
(newline)
(display 'uint64)
(display " ")
(display (pffi-size-of 'uint64))
(newline)
(display 'char)
(display " ")
(display (pffi-size-of 'char))
(newline)
(display 'unsigned-char)
(display " ")
(display (pffi-size-of 'unsigned-char))
(newline)
(display 'short)
(display " ")
(display (pffi-size-of 'short))
(newline)
(display 'unsigned-short)
(display " ")
(display (pffi-size-of 'unsigned-short))
(newline)
(display 'int)
(display " ")
(display (pffi-size-of 'int))
(newline)
(display 'unsigned-int)
(display " ")
(display (pffi-size-of 'unsigned-int))
(newline)
(display 'long)
(display " ")
(display (pffi-size-of 'long))
(newline)
(display 'unsigned-long)
(display " ")
(display (pffi-size-of 'unsigned-long))
(newline)
(display 'float)
(display " ")
(display (pffi-size-of 'float))
(newline)
(display 'double)
(display " ")
(display (pffi-size-of 'double))
(newline)
(display 'pointer)
(display " ")
(display (pffi-size-of 'pointer))
(newline)

14
old-tests/400_pointer-allocate-free.scm
View File

@ -1,14 +0,0 @@
(import (scheme base)
(scheme write)
(retropikzel r7rs-pffi version 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)

12
old-tests/401_is-pointer.scm
View File

@ -1,12 +0,0 @@
(import (scheme base)
(scheme write)
(retropikzel r7rs-pffi version 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"))

14
old-tests/402_null-pointer.scm
View File

@ -1,14 +0,0 @@
(import (scheme base)
(scheme write)
(retropikzel r7rs-pffi version main))
(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3)
(* (pffi-size-of 'uint8) 4)
(pffi-size-of 'int))))
(define n (pffi-pointer-null))
(if (not (pffi-pointer-null? n)) (error "pffi-pointer-null? returned false when given null pointer"))
(if (pffi-pointer-null? p) (error "pffi-pointer-null? returned true when given not a null pointer"))
(if (pffi-pointer-null? "Hello") (error "pffi-pointer-null? returned true when given not a pointer"))

31
old-tests/410_pointer-set-get.scm
View File

@ -1,31 +0,0 @@
(import (scheme base)
(scheme write)
(retropikzel r7rs-pffi version 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-set! p
'uint8
(+ (* (pffi-size-of 'uint32))
(* (pffi-size-of 'uint8) 2))
42)
(write p)
(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))

17
old-tests/500_string-to-pointer-to-string.scm
View File

@ -1,17 +0,0 @@
(import (scheme base)
(scheme write)
(retropikzel r7rs-pffi version 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)

21
old-tests/600_libc.scm
View File

@ -1,21 +0,0 @@
(import (scheme base)
(scheme write)
(scheme process-context)
(scheme eval)
(retropikzel r7rs-pffi version main))
(define libc
(if (string=? pffi-os-name "windows")
(pffi-shared-object-auto-load (list "stdio.h") (list) "ucrtbase" (list ""))
(pffi-shared-object-auto-load (list "stdio.h") (list) "c" (list "" ".6"))))
(pffi-define puts libc 'puts 'int (list 'pointer))
(display "=================")
(newline)
(puts (pffi-string->pointer "This is from C"))
(newline)
(display "=================")
(newline)

21
old-tests/700_pffi-define.scm
View File

@ -1,21 +0,0 @@
(import (scheme base)
(scheme write)
(scheme process-context)
(scheme eval)
(retropikzel r7rs-pffi version main))
(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h")
(list)
"curl"
(list ".4")))
(pffi-define curl-version libcurl 'curl_version 'string (list))
(display "=================")
(newline)
(display (pffi-pointer->string (curl-version)))
(newline)
(display "=================")
(newline)

56
old-tests/800_libcurl.scm
View File

@ -1,56 +0,0 @@
(import (scheme base)
(scheme write)
(scheme process-context)
(retropikzel r7rs-pffi version main))
(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"))) ;Additional versions to search
(pffi-define curl-easy-init libcurl 'curl_easy_init 'pointer (list))
; Define the curl-easy-setopt twice since some implementations (Sagittarius) complain if you pass
; callback type instead of pointer type
(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-perform libcurl 'curl_easy_perform 'int (list 'pointer))
;These values need to be get from c file like this:
; #include <curl/curl.h>
; int main() {
; printf("Value: %d", CURLOPT_WRITEFUNCTION);
; }
; many times you can get them from .h files directly
(define CURLOPT-WRITEFUNCTION 20011)
(define CURLOPT-FOLLOWLOCATION 52)
(define CURLOPT-URL 10002)
(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))
(define curl-code2 (curl-easy-setopt handle CURLOPT-URL url))
(define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result))
(display "Curl code 1: ")
(display curl-code1)
(newline)
(display "Curl code 2: ")
(display curl-code2)
(newline)
(display "Curl code 3: ")
(display curl-code3)
(newline)
(display "Perform: ")
(write (curl-easy-perform handle))
(newline)
(display "Response length: ")
(display (string-length result))
(newline)

3
retropikzel/pffi.rkt
View File

@ -1,3 +0,0 @@
#lang r7rs
(import (scheme base))
(include "pffi.sld")

2
retropikzel/pffi.sld
View File

@ -164,7 +164,7 @@
pffi-array-set! pffi-array-set!
pffi-list->array pffi-list->array
pffi-array->list pffi-array->list
pffi-define pffi-define-function
pffi-define-callback) pffi-define-callback)
(cond-expand (cond-expand
(chibi (include "pffi/chibi.scm")) (chibi (include "pffi/chibi.scm"))

2
retropikzel/pffi/chibi-src/pffi.stub
View File

@ -186,7 +186,7 @@
;(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }") ;(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }")
;(define-c string (pointer-to-string pointer_to_string) ((maybe-null pointer void*))) ;(define-c string (pointer-to-string pointer_to_string) ((maybe-null pointer void*)))
;; pffi-define ;; pffi-define-function
(c-declare "ffi_cif cif;") (c-declare "ffi_cif cif;")
(define-c (pointer void*) dlsym ((maybe-null pointer void*) string)) (define-c (pointer void*) dlsym ((maybe-null pointer void*) string))

8
retropikzel/pffi/chibi.scm
View File

@ -136,7 +136,7 @@
((equal? type 'callback) '(maybe-null void*)) ((equal? type 'callback) '(maybe-null void*))
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))
;; pffi-define ;; pffi-define-function
(define pffi-type->libffi-type (define pffi-type->libffi-type
(lambda (type) (lambda (type)
@ -193,9 +193,9 @@
(cond ((not (equal? return-type 'void)) (cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0)))))))) (pffi-pointer-get return-value return-type 0))))))))
(define-syntax pffi-define (define-syntax pffi-define-function
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
(make-c-function shared-object (make-c-function shared-object
(symbol->string c-name) (symbol->string c-name)
@ -208,6 +208,6 @@
(define-syntax pffi-define-callback (define-syntax pffi-define-callback
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name return-type argument-types procedure) ((_ scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name
(make-c-callback return-type 'argument-types procedure))))) (make-c-callback return-type 'argument-types procedure)))))

29
retropikzel/pffi/chicken.scm
View File

@ -29,7 +29,7 @@
(lambda (object) (lambda (object)
(pointer? object))) (pointer? object)))
(define-syntax pffi-define (define-syntax pffi-define-function
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let* ((pffi-type->native-type ; Chicken has this procedure in three places (let* ((pffi-type->native-type ; Chicken has this procedure in three places
@ -148,33 +148,6 @@
(lambda () (lambda ()
(address->pointer 0))) (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))
(pointer (pffi-pointer-allocate (+ size 1))))
(memset pointer 0 (+ size 1))
(strncpy-ps pointer (location string-content) size)
;(puts pointer)
pointer)))
#;(define pffi-string->pointer
(foreign-lambda* c-pointer
((c-string str))
"C_return((void*)str);"))
;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
;(pffi-define strlen #f 'strlen 'int (list 'pointer))
#;(define pffi-pointer->string
(foreign-lambda* c-string
((c-pointer p))
"C_return((char*)p);"))
(define-syntax pffi-shared-object-load (define-syntax pffi-shared-object-load
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)

2
retropikzel/pffi/cyclone.scm
View File

@ -27,7 +27,7 @@
(lambda (object) (lambda (object)
(opaque? object))) (opaque? object)))
(define-syntax pffi-define (define-syntax pffi-define-function
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let* ((pffi-type->native-type (let* ((pffi-type->native-type

2
retropikzel/pffi/gambit.scm
View File

@ -167,7 +167,7 @@
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
(define-macro (define-macro
(pffi-define scheme-name shared-object c-name return-type argument-types) (pffi-define-function scheme-name shared-object c-name return-type argument-types)
(letrec* ((native-argument-types (letrec* ((native-argument-types
(if (equal? '(list) argument-types) (if (equal? '(list) argument-types)
(list) (list)

6
retropikzel/pffi/gauche.scm
View File

@ -168,9 +168,9 @@
(cond ((not (equal? return-type 'void)) (cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0)))))))) (pffi-pointer-get return-value return-type 0))))))))
(define-syntax pffi-define (define-syntax pffi-define-function
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
(make-c-function shared-object (make-c-function shared-object
(symbol->string c-name) (symbol->string c-name)
@ -183,6 +183,6 @@
(define-syntax pffi-define-callback (define-syntax pffi-define-callback
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name return-type argument-types procedure) ((_ scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name
(make-c-callback return-type 'argument-types procedure))))) (make-c-callback return-type 'argument-types procedure)))))

4
retropikzel/pffi/gerbil.scm
View File

@ -6,9 +6,9 @@
(lambda (object) (lambda (object)
(error "Not defined"))) (error "Not defined")))
(define-syntax pffi-define (define-syntax pffi-define-function
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(error "Not defined")))) (error "Not defined"))))
(define size-of-type (define size-of-type

6
retropikzel/pffi/guile.scm
View File

@ -29,9 +29,9 @@
(lambda (object) (lambda (object)
(pointer? object))) (pointer? object)))
(define-syntax pffi-define (define-syntax pffi-define-function
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
(foreign-library-function shared-object (foreign-library-function shared-object
(symbol->string c-name) (symbol->string c-name)
@ -40,7 +40,7 @@
(define-syntax pffi-define-callback (define-syntax pffi-define-callback
(syntax-rules () (syntax-rules ()
((pffi-define-callback scheme-name return-type argument-types procedure) ((_ scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name
(procedure->pointer (pffi-type->native-type return-type) (procedure->pointer (pffi-type->native-type return-type)
procedure procedure

4
retropikzel/pffi/kawa.scm
View File

@ -59,9 +59,9 @@
(string=? (invoke (invoke object 'getClass) 'getName) (string=? (invoke (invoke object 'getClass) 'getName)
"jdk.internal.foreign.NativeMemorySegmentImpl"))) "jdk.internal.foreign.NativeMemorySegmentImpl")))
(define-syntax pffi-define (define-syntax pffi-define-function
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types) ((pffi-define-function scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
(lambda vals (lambda vals
(invoke (invoke (cdr (assoc 'linker shared-object)) (invoke (invoke (cdr (assoc 'linker shared-object))

6
retropikzel/pffi/larceny.scm
View File

@ -122,9 +122,9 @@
((equal? type 'void) (%peek-pointer (+ pointer offset))) ((equal? type 'void) (%peek-pointer (+ pointer offset)))
((equal? type 'pointer) (%peek-pointer (+ pointer offset)))))) ((equal? type 'pointer) (%peek-pointer (+ pointer offset))))))
(define-syntax pffi-define (define-syntax pffi-define-function
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
0 0
@ -135,7 +135,7 @@
(define-syntax pffi-define-callback (define-syntax pffi-define-callback
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name return-type argument-types procedure) ((_ scheme-name return-type argument-types procedure)
(define scheme-name (define scheme-name
0 0
#;(make-c-callback return-type argument-types procedure))))) #;(make-c-callback return-type argument-types procedure)))))

4
retropikzel/pffi/mosh.scm
View File

@ -139,9 +139,9 @@
((equal? type 'struct) 'void*) ((equal? type 'struct) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))
(define-syntax pffi-define (define-syntax pffi-define-function
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
(make-c-function shared-object (make-c-function shared-object
(pffi-type->native-type return-type) (pffi-type->native-type return-type)

4
retropikzel/pffi/racket.scm
View File

@ -29,9 +29,9 @@
(lambda (object) (lambda (object)
(cpointer? object))) (cpointer? object)))
(define-syntax pffi-define (define-syntax pffi-define-function
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name
(get-ffi-obj c-name (get-ffi-obj c-name
shared-object shared-object

2
retropikzel/pffi/sagittarius.scm
View File

@ -30,7 +30,7 @@
(or (pointer? object) (or (pointer? object)
(string? object)))) (string? object))))
(define-syntax pffi-define (define-syntax pffi-define-function
(syntax-rules () (syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name (define scheme-name

7
retropikzel/pffi/shared/pointer.scm
View File

@ -10,11 +10,10 @@
(cond-expand (cond-expand
(chibi #t) ; FIXME (chibi #t) ; FIXME
(else (pffi-define pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int)))) (else (pffi-define-function pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int))))
;(pffi-define pffi-pointer-allocate-aligned pffi-libc-stdlib 'aligned_alloc 'pointer '(int int)) (pffi-define-function pffi-pointer-allocate-calloc pffi-libc-stdlib 'calloc 'pointer '(int int))
(pffi-define pffi-pointer-allocate-calloc pffi-libc-stdlib 'calloc 'pointer '(int int))
(cond-expand (cond-expand
(chibi #t) ; FIXME (chibi #t) ; FIXME
(else (pffi-define pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer)))) (else (pffi-define-function pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer))))

4
retropikzel/pffi/stklos.scm
View File

@ -33,9 +33,9 @@
(newline) (newline)
(cpointer? object))) (cpointer? object)))
(define-syntax pffi-define (define-syntax pffi-define-function
(syntax-rules () (syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types) ((_ scheme-name shared-object c-name return-type argument-types)
(begin (begin
(define pffi-type->native-type (define pffi-type->native-type
(lambda (type) (lambda (type)

2
retropikzel/pffi/ypsilon.scm
View File

@ -144,7 +144,7 @@
(else (error "pffi-type->native-type -- No such pffi type" ,type)))) (else (error "pffi-type->native-type -- No such pffi type" ,type))))
(define-macro (define-macro
(pffi-define scheme-name shared-object c-name return-type argument-types) (pffi-define-function scheme-name shared-object c-name return-type argument-types)
`(define ,scheme-name `(define ,scheme-name
(c-function ,(pffi-type->native-type return-type) (c-function ,(pffi-type->native-type return-type)
,(cadr c-name) ,(cadr c-name)

3
snow/arvyy/mustache-test.rkt
View File

@ -1,3 +0,0 @@
#lang r7rs
(import (scheme base))
(include "mustache-test.sld")

3
snow/arvyy/mustache.rkt
View File

@ -1,3 +0,0 @@
#lang r7rs
(import (scheme base))
(include "mustache.sld")

3
snow/arvyy/mustache/collection.rkt
View File

@ -1,3 +0,0 @@
#lang r7rs
(import (scheme base))
(include "collection.sld")

3
snow/arvyy/mustache/executor.rkt
View File

@ -1,3 +0,0 @@
#lang r7rs
(import (scheme base))
(include "executor.sld")

3
snow/arvyy/mustache/lookup.rkt
View File

@ -1,3 +0,0 @@
#lang r7rs
(import (scheme base))
(include "lookup.sld")

3
snow/arvyy/mustache/parser.rkt
View File

@ -1,3 +0,0 @@
#lang r7rs
(import (scheme base))
(include "parser.sld")

3
snow/arvyy/mustache/tokenizer.rkt
View File

@ -1,3 +0,0 @@
#lang r7rs
(import (scheme base))
(include "tokenizer.sld")

914
test.rkt
View File

@ -1,914 +0,0 @@
#lang r7rs
(import (scheme base)
(scheme write)
(scheme char)
(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)))
(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? 'string))
(assert equal? (pffi-type? 'string) #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-init)
;; 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-shared-object-auto-load
(print-header 'pffi-shared-object-auto-load)
(define libc-stdlib
(cond-expand
(windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase"))
(else (pffi-shared-object-auto-load (list "stdlib.h")
"c"
'(additional-versions . ("0" "6"))))))
(debug libc-stdlib)
(define c-testlib
(cond-expand
(windows (pffi-shared-object-auto-load (list "libtest.h")
"test"
'(additional-paths . ("."))))
(else (pffi-shared-object-auto-load (list "libtest.h")
"test"
'(additional-paths . ("."))))))
(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-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)
;; 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)
(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-puts libc-stdlib 'puts 'int (list 'pointer))
(define chars-written (c-puts (pffi-string->pointer "Hello from testing, I am C function puts")))
(assert = chars-written 41)
(pffi-define c-atoi libc-stdlib 'atoi 'int (list 'pointer))
(assert = (c-atoi (pffi-string->pointer "100")) 100)
;; 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)

30
tests/compliance.scm
View File

@ -684,31 +684,31 @@
(print-header 'pffi-define) (print-header 'pffi-define)
(pffi-define c-abs libc-stdlib 'abs 'int '(int)) (pffi-define-function c-abs libc-stdlib 'abs 'int '(int))
(debug c-abs) (debug c-abs)
(define absoluted (c-abs -2)) (define absoluted (c-abs -2))
(debug absoluted) (debug absoluted)
(assert = absoluted 2) (assert = absoluted 2)
(pffi-define c-puts libc-stdlib 'puts 'int '(pointer)) (pffi-define-function c-puts libc-stdlib 'puts 'int '(pointer))
(debug c-puts) (debug c-puts)
(define chars-written (c-puts (pffi-string->pointer "puts: Hello from testing, I am C function puts"))) (define chars-written (c-puts (pffi-string->pointer "puts: Hello from testing, I am C function puts")))
(debug chars-written) (debug chars-written)
(assert = chars-written 47) (assert = chars-written 47)
(pffi-define c-atoi libc-stdlib 'atoi 'int '(pointer)) (pffi-define-function c-atoi libc-stdlib 'atoi 'int '(pointer))
(assert = (c-atoi (pffi-string->pointer "100")) 100) (assert = (c-atoi (pffi-string->pointer "100")) 100)
(pffi-define c-fopen libc-stdio 'fopen 'pointer '(pointer pointer)) (pffi-define-function c-fopen libc-stdio 'fopen 'pointer '(pointer pointer))
(define output-file (c-fopen (pffi-string->pointer "testfile.test") (define output-file (c-fopen (pffi-string->pointer "testfile.test")
(pffi-string->pointer "w"))) (pffi-string->pointer "w")))
(debug output-file) (debug output-file)
(pffi-define c-fprintf libc-stdio 'fprintf 'int '(pointer pointer)) (pffi-define-function c-fprintf libc-stdio 'fprintf 'int '(pointer pointer))
(define characters-written (define characters-written
(c-fprintf output-file (pffi-string->pointer "Hello world"))) (c-fprintf output-file (pffi-string->pointer "Hello world")))
(debug characters-written) (debug characters-written)
(assert equal? (= characters-written 11) #t) (assert equal? (= characters-written 11) #t)
(pffi-define c-fclose libc-stdio 'fclose 'int '(pointer)) (pffi-define-function c-fclose libc-stdio 'fclose 'int '(pointer))
(define closed-status (c-fclose output-file)) (define closed-status (c-fclose output-file))
(debug closed-status) (debug closed-status)
(assert equal? (= closed-status 0) #t) (assert equal? (= closed-status 0) #t)
@ -717,11 +717,11 @@
(lambda () (read-line))) (lambda () (read-line)))
"Hello world") #t) "Hello world") #t)
(pffi-define c-takes-no-args c-testlib 'takes_no_args 'void '()) (pffi-define-function c-takes-no-args c-testlib 'takes_no_args 'void '())
(debug c-takes-no-args) (debug c-takes-no-args)
(c-takes-no-args) (c-takes-no-args)
(pffi-define c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int '()) (pffi-define-function c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int '())
(debug c-takes-no-args) (debug c-takes-no-args)
(define takes-no-args-returns-int-result (c-takes-no-args-returns-int)) (define takes-no-args-returns-int-result (c-takes-no-args-returns-int))
(assert equal? (= takes-no-args-returns-int-result 0) #t) (assert equal? (= takes-no-args-returns-int-result 0) #t)
@ -730,8 +730,8 @@
(print-header 'pffi-struct-get) (print-header 'pffi-struct-get)
(pffi-define c-init-struct c-testlib 'init_struct 'pointer '(pointer)) (pffi-define-function c-init-struct c-testlib 'init_struct 'pointer '(pointer))
(pffi-define c-check-offset c-testlib 'check_offset 'void '(int int)) (pffi-define-function c-check-offset c-testlib 'check_offset 'void '(int int))
(pffi-define-struct struct-test-get1 'test_get1 (pffi-define-struct struct-test-get1 'test_get1
'((int8 . a) '((int8 . a)
(char . b) (char . b)
@ -802,7 +802,7 @@
(print-header "pffi-struct-set! 1") (print-header "pffi-struct-set! 1")
(pffi-define c-test-check c-testlib 'test_check 'int '(pointer)) (pffi-define-function c-test-check c-testlib 'test_check 'int '(pointer))
(pffi-define-struct struct-test-set1 'test_set1 (pffi-define-struct struct-test-set1 'test_set1
'((int8 . a) '((int8 . a)
(char . b) (char . b)
@ -839,7 +839,7 @@
;(print-header "pffi-struct constructor with pointer") ;(print-header "pffi-struct constructor with pointer")
;(pffi-define c-test-new c-testlib 'test_new 'pointer '()) ;(pffi-define-function c-test-new c-testlib 'test_new 'pointer '())
;(define struct-test2-pointer (c-test-new)) ;(define struct-test2-pointer (c-test-new))
#;(define struct-test2 (pffi-struct-make 'test #;(define struct-test2 (pffi-struct-make 'test
'((int8 . a) '((int8 . a)
@ -923,7 +923,7 @@
;; pffi-struct-dereference 1 ;; pffi-struct-dereference 1
;(print-header "pffi-struct-dereference 1") ;(print-header "pffi-struct-dereference 1")
;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int '((struct . color))) ;(pffi-define-function c-color-check-by-value c-testlib 'color_check_by_value 'int '((struct . color)))
#;(pffi-define-struct make-struct-color 'color '((int8 . r) #;(pffi-define-struct make-struct-color 'color '((int8 . r)
(int8 . g) (int8 . g)
(int8 . b) (int8 . b)
@ -939,7 +939,7 @@
;(print-header "pffi-struct-dereference 2") ;(print-header "pffi-struct-dereference 2")
;(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int '((struct . test))) ;(pffi-define-function c-test-check-by-value c-testlib 'test_check_by_value 'int '((struct . test)))
#;(pffi-define-struct make-struct-test-dereference2 #;(pffi-define-struct make-struct-test-dereference2
'test 'test
'((int8 . a) '((int8 . a)
@ -996,7 +996,7 @@
;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2) ;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2)
;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1) ;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1)
;(pffi-define qsort libc-stdlib 'qsort 'void '(pointer int int callback)) ;(pffi-define-function qsort libc-stdlib 'qsort 'void '(pointer int int callback))
#;(pffi-define-callback compare #;(pffi-define-callback compare
'int 'int