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

Moved tests to their own files

This commit is contained in:
retropikzel 2024-05-18 15:25:02 +03:00
parent 0ad1417380
commit 21b6414420
19 changed files with 177 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -16,7 +16,8 @@ test/import
pffi-define
test/pffi-define
size-of
test/size-of
test/*
!test/*.scm
retropikzel/pffi/*/*.c
retropikzel/pffi/*/*.o*
retropikzel/pffi/*/*.so

2
Makefile
View File

@ -36,7 +36,6 @@ clean:
rm -rf test/*.o*
rm -rf test/*.so
rm -rf test/*.meta
rm -rf test/import
rm -rf test/pffi-define
rm -rf test/*gambit*
rm -rf test/*.link
@ -45,3 +44,4 @@ clean:
rm -rf *.so
rm -rf *.a
rm -rf tmp
find ./test -type f -not -name "*.scm" -exec bash -c "test -x {} && rm {}" \;

91
retropikzel/pffi/v0-1-0/chicken.scm
View File

@ -5,7 +5,8 @@
(scheme file)
(scheme process-context)
(chicken foreign)
(chicken syntax))
(chicken syntax)
(chicken memory))
(export pffi-shared-object-load
pffi-define
pffi-size-of
@ -49,7 +50,7 @@
(define pffi-pointer?
(lambda (object)
(error "Not defined")))
(pointer? object)))
(define-syntax pffi-define
(er-macro-transformer
@ -92,13 +93,34 @@
`(define ,scheme-name
(foreign-lambda ,return-type ,c-name ,@ argument-types)))))))
(define pffi-size-of
(lambda (type)
(error "Not defined")))
(define-syntax pffi-size-of
(er-macro-transformer
(lambda (expr rename compare)
(let ((type (car (cdr (car (cdr expr))))))
(cond ((equal? type 'int8) `(foreign-value "sizeof(int8_t)" int))
((equal? type 'uint8) `(foreign-value "sizeof(uint8_t)" int))
((equal? type 'int16) `(foreign-value "sizeof(int16_t)" int))
((equal? type 'uint16) `(foreign-value "sizeof(uint16_t)" int))
((equal? type 'int32) `(foreign-value "sizeof(int32_t)" int))
((equal? type 'uint32) `(foreign-value "sizeof(uint32_t)" int))
((equal? type 'int64) `(foreign-value "sizeof(int64_t)" int))
((equal? type 'uint64) `(foreign-value "sizeof(uint64_t)" int))
((equal? type 'char) `(foreign-value "sizeof(char)" int))
((equal? type 'unsigned-char) `(foreign-value "sizeof(unsigned char)" int))
((equal? type 'short) `(foreign-value "sizeof(short)" int))
((equal? type 'unsigned-short) `(foreign-value "sizeof(unsigned short)" int))
((equal? type 'int) `(foreign-value "sizeof(int)" int))
((equal? type 'unsigned-int) `(foreign-value "sizeof(unsigned int)" int))
((equal? type 'long) `(foreign-value "sizeof(long)" int))
((equal? type 'unsigned-long) `(foreign-value "sizeof(unsigned long)" int))
((equal? type 'float) `(foreign-value "sizeof(float)" int))
((equal? type 'double) `(foreign-value "sizeof(double)" int))
((equal? type 'pointer) `(foreign-value "sizeof(int)" int))
(else `(error "pffi-size-of -- No such pffi type" type)))))))
(define pffi-pointer-allocate
(lambda (size)
(error "Not defined")))
(allocate size)))
(define pffi-pointer-null
(lambda ()
@ -106,11 +128,21 @@
(define pffi-string->pointer
(lambda (string-content)
(error "Not defined")))
(let* ((size (string-length string-content))
(pointer (pffi-pointer-allocate size)))
(move-memory! string-content pointer size 0)
pointer)))
(pffi-define strlen #f 'strlen 'int (list 'pointer))
(define pffi-pointer->string
(lambda (pointer)
pointer))
(if (string? pointer)
pointer
(let* ((size (strlen pointer))
(string-content (make-string size)))
(move-memory! pointer string-content size 0)
string-content))))
(define pffi-pointer->bytevector
(lambda (pointer size)
@ -128,7 +160,7 @@
(define pffi-pointer-free
(lambda (pointer)
(error "Not defined")))
(free pointer)))
(define pffi-pointer-null?
(lambda (pointer)
@ -136,12 +168,47 @@
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p pointer))
(error "Not defined"))))
(cond
((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value))
((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value))
((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value))
((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value))
((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value))
((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value))
((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value))
((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) value))
((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value))
((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value))
((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value))
((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value))
((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value))
((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value))
((equal? type 'float) (pointer-s32-set! (pointer+ pointer offset) value))
((equal? type 'double) (pointer-s32-set! (pointer+ pointer offset) value))
((equal? type 'pointer) (pointer-u32-set! (pointer+ pointer offset) value)))))
(define pffi-pointer-get
(lambda (pointer type offset)
(error "Not defined")))
(cond
((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset)))
((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset)))
((equal? type 'int16) (pointer-s16-ref (pointer+ pointer offset)))
((equal? type 'uint16) (pointer-u16-ref (pointer+ pointer offset)))
((equal? type 'int32) (pointer-s32-ref (pointer+ pointer offset)))
((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset)))
((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset)))
((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset)))
((equal? type 'char) (pointer-s8-ref (pointer+ pointer offset)))
((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset)))
((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset)))
((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset)))
((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset)))
((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset)))
((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset)))
((equal? type 'float) (pointer-s32-ref (pointer+ pointer offset)))
((equal? type 'double) (pointer-s32-ref (pointer+ pointer offset)))
((equal? type 'pointer) (pointer-u32-ref (pointer+ pointer offset))))))
(define pffi-pointer-deref
(lambda (pointer)

6
retropikzel/pffi/v0-1-0/sagittarius.scm
View File

@ -125,8 +125,6 @@
((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value))
((equal? type 'int64) (pointer-set-c-int64_t! p offset value))
((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value))
((equal? type 'intptr) (pointer-set-c-intptr_t! p offset value))
((equal? type 'uintptr) (pointer-set-c-uintptr_t! p offset value))
((equal? type 'char) (pointer-set-c-char! p offset value))
((equal? type 'short) (pointer-set-c-short! p offset value))
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value))
@ -136,7 +134,7 @@
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value))
((equal? type 'float) (pointer-set-c-float! p offset value))
((equal? type 'double) (pointer-set-c-double! p offset value))
((equal? type 'void) (pointer-set-c-void*! p offset value))))))
((equal? type 'void*) (pointer-set-c-void*! p offset value))))))
(define pffi-pointer-get
(lambda (pointer type offset)
@ -150,8 +148,6 @@
((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset))
((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset))
((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset))
((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset))
((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset))
((equal? native-type 'char) (pointer-ref-c-char p offset))
((equal? native-type 'short) (pointer-set-c-short p offset value))
((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))

11
scripts/test-runs-compilers.sh
View File

@ -1,6 +1,7 @@
${SCHEME} ./test/import.scm
./test/import
${SCHEME} ./test/pffi-define.scm
./test/pffi-define
for file in ./test/*.scm
do
echo "Testing ${file}"
${SCHEME} ${file}
${file//.scm/}
done

11
scripts/test-runs-dynamic.sh
View File

@ -1,7 +1,6 @@
${SCHEME} ./test/hello.scm
${SCHEME} ./test/import.scm
${SCHEME} ./test/size-of.scm
${SCHEME} ./test/pointer-set-get.scm
${SCHEME} ./test/string-to-pointer-to-string.scm
${SCHEME} ./test/pffi-define.scm
for file in ./test/*.scm
do
echo "Testing ${file}"
${SCHEME} ${file}
done

0
test/hello.scm → test/100_hello.scm
View File

0
test/import.scm → test/200_import.scm
View File

0
test/size-of.scm → test/300_size-of.scm
View File

14
test/39_pointer-allocate.scm Normal file
View File

@ -0,0 +1,14 @@
(import (scheme base)
(scheme write)
(retropikzel pffi v0-1-0 main))
(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3)
(* (pffi-size-of 'uint8) 4)
(pffi-size-of 'int))))
(write p)
(newline)
(pffi-pointer-free p)

14
test/400_pointer-allocate-free.scm Normal file
View File

@ -0,0 +1,14 @@
(import (scheme base)
(scheme write)
(retropikzel pffi v0-1-0 main))
(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3)
(* (pffi-size-of 'uint8) 4)
(pffi-size-of 'int))))
(write p)
(newline)
(pffi-pointer-free p)

12
test/401_is-pointer.scm Normal file
View File

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

15
test/pointer-set-get.scm → test/410_pointer-set-get.scm
View File

@ -18,11 +18,14 @@
(write p)
(newline)
(write (pffi-pointer-get p
'uint8
(+ (* (pffi-size-of 'uint32))
(* (pffi-size-of 'uint8) 2))
))
(newline)
(let ((result(pffi-pointer-get p
'uint8
(+ (* (pffi-size-of 'uint32))
(* (pffi-size-of 'uint8) 2)))))
(if (not (= result 42))
(error "pffi-pointer-get did not return 42"))
(write result)
(newline))

17
test/500_string-to-pointer-to-string.scm Normal file
View File

@ -0,0 +1,17 @@
(import (scheme base)
(scheme write)
(retropikzel pffi v0-1-0 main))
(define original "Hello world")
(define p (pffi-string->pointer original))
(write p)
(newline)
(define s (pffi-pointer->string p))
(if (not (string=? original s))
(error (string-append "string from pointer is not " original) s))
(write s)
(newline)

0
test/pffi-define.scm → test/600_pffi_define.scm
View File

17
test/600_string-to_pointer_to_string.scm Normal file
View File

@ -0,0 +1,17 @@
(import (scheme base)
(scheme write)
(retropikzel pffi v0-1-0 main))
(define original "Hello world")
(define p (pffi-string->pointer original))
(write p)
(newline)
(define s (pffi-pointer->string p))
(if (not (string=? original s))
(error (string-append "string from pointer is not " original) s))
(write s)
(newline)

11
test/pffi-lambda.scm
View File

@ -1,11 +0,0 @@
(import (scheme base)
(scheme write)
(retropikzel pffi v0.1.0 main))
(define libcurl (pffi-shared-object-auto-load "curl" (list)))
(define curl-version (pffi-lambda libcurl 'curl_version 'string (list)))
(write (pffi-pointer->string (curl-version)))
(newline)

32
test/sdl2.scm
View File

@ -1,32 +0,0 @@
(import (scheme base)
(scheme write)
(scheme read)
(retropikzel pffi v0.1.0 main))
(define sdl2 (pffi-shared-object-auto-load "SDL2" (list)))
(pffi-call sdl2 'SDL_Init 'int '((int . 32)))
(define window (pffi-call sdl2
'SDL_CreateWindow
'pointer
(list (cons 'pointer (pffi-string->pointer "Testing pffi"))
(cons 'int 1)
(cons 'int 1)
(cons 'int 400)
(cons 'int 400)
(cons 'int 4))))
(define renderer (pffi-call sdl2
'SDL_CreateRenderer
'pointer
(list (cons 'pointer window)
(cons 'int -1)
(cons 'int 2))))
(pffi-call sdl2 'SDL_RenderClear 'int (list (cons 'pointer renderer)))
(pffi-call sdl2 'SDL_RenderPresent 'int (list (cons 'pointer renderer)))
(display (pffi-call sdl2 'SDL_Delay 'void '((int . 2000))))

14
test/string-to-pointer-to-string.scm
View File

@ -1,14 +0,0 @@
(import (scheme base)
(scheme write)
(retropikzel pffi v0-1-0 main))
(define p (pffi-string->pointer "Hello world"))
(write p)
(newline)
(define s (pffi-pointer->string p))
(write s)
(newline)