First tests to write Gambit implementation
This commit is contained in:
parent
dca27d47f1
commit
2282862f09
10
Makefile
10
Makefile
|
|
@ -31,15 +31,15 @@ test-cyclone: clean
|
|||
${CYCLONE} test.scm
|
||||
./test
|
||||
|
||||
GAMBIT_LIB=gsc -dynamic
|
||||
GAMBIT_CC=gsc -exe . -nopreload
|
||||
GAMBIT_LIB=gsc -:search=.
|
||||
GAMBIT_CC=gsc -exe ./ -nopreload
|
||||
test-gambit-podman-amd64: clean
|
||||
podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ${GAMBIT_LIB} retropikzel/r7rs-pffi.sld; echo $$?"
|
||||
podman run --arch=amd64 run -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ${GAMBIT_CC} test.scm; echo $$?"
|
||||
podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ${GAMBIT_LIB} retropikzel/r7rs-pffi; echo $$?"
|
||||
podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ${GAMBIT_CC} test.scm; echo $$?"
|
||||
podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gambit bash -c "cd /workdir && ./test -:search=.; echo $$?"
|
||||
|
||||
test-gambit: clean
|
||||
${GAMBIT_LIB} retropikzel/r7rs-pffi.sld; echo $$?
|
||||
${GAMBIT_LIB} retropikzel/r7rs-pffi; echo $$?
|
||||
${GAMBIT_CC} test.scm; echo $$?
|
||||
./test -:search=.; echo $$?
|
||||
|
||||
|
|
|
|||
|
|
@ -34,7 +34,8 @@
|
|||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)))
|
||||
(scheme process-context)
|
||||
(only (gambit) c-declare c-lambda c-define)))
|
||||
(gauche
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
|
|
@ -112,17 +113,17 @@
|
|||
pffi-size-of
|
||||
pffi-shared-object-auto-load
|
||||
pffi-shared-object-load
|
||||
pffi-pointer-null
|
||||
pffi-pointer-null?
|
||||
pffi-pointer-allocate
|
||||
pffi-pointer?
|
||||
pffi-pointer-free
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-string->pointer
|
||||
pffi-pointer->string
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
;pffi-pointer-null
|
||||
;pffi-pointer-null?
|
||||
;pffi-pointer-allocate
|
||||
;pffi-pointer?
|
||||
;pffi-pointer-free
|
||||
;pffi-pointer-set!
|
||||
;pffi-pointer-get
|
||||
;pffi-string->pointer
|
||||
;pffi-pointer->string
|
||||
;pffi-define
|
||||
;pffi-define-callback
|
||||
;pffi-pointer-address
|
||||
;pffi-pointer-dereference
|
||||
)
|
||||
|
|
|
|||
|
|
@ -2,105 +2,54 @@
|
|||
|
||||
(define pffi-init (lambda () #t))
|
||||
|
||||
#|
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) int8)
|
||||
((equal? type 'uint8) unsigned-int8)
|
||||
((equal? type 'int16) int16)
|
||||
((equal? type 'uint16) unsigned-int16)
|
||||
((equal? type 'int32) int32)
|
||||
((equal? type 'uint32) unsigned-int32)
|
||||
((equal? type 'int64) int64)
|
||||
((equal? type 'uint64) unsigned-int64)
|
||||
((equal? type 'char) char)
|
||||
((equal? type 'unsigned-char) unsigned-char)
|
||||
((equal? type 'short) short)
|
||||
((equal? type 'unsigned-short) unsigned-short)
|
||||
((equal? type 'int) int)
|
||||
((equal? type 'unsigned-int) unsigned-int)
|
||||
((equal? type 'long) long)
|
||||
((equal? type 'unsigned-long) unsigned-long)
|
||||
((equal? type 'float) float)
|
||||
((equal? type 'double) double)
|
||||
((equal? type 'pointer) pointer)
|
||||
((equal? type 'void) void)
|
||||
((equal? type 'callback) pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(error "Not defined")))
|
||||
|
||||
#;(define-syntax pffi-define
|
||||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(define scheme-name
|
||||
#f
|
||||
#;(c-lambda argument-types return-type c-name)
|
||||
|
||||
))))
|
||||
|
||||
(define pffi-define-callback
|
||||
(lambda (scheme-name shared-object c-name return-type argument-types)
|
||||
(error "Not defined")))
|
||||
|
||||
;(c-declare "int size_of_int8() { return sizeof(int8_t);}")
|
||||
;(define size-of-int8 (c-lambda () int "__return(sizeof(int8_t));"))
|
||||
;(define int8-size ((c-lambda () int "__return(sizeof(int8_t));")))
|
||||
;(define int8-size (c-lambda () int "__return(1);"))
|
||||
|
||||
|#
|
||||
(define size-of-int8_t (c-lambda () int "___return(sizeof(int8_t));"))
|
||||
(define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_t));"))
|
||||
(define size-of-int16_t (c-lambda () int "___return(sizeof(int16_t));"))
|
||||
(define size-of-uint16_t (c-lambda () int "___return(sizeof(uint16_t));"))
|
||||
(define size-of-int32_t (c-lambda () int "___return(sizeof(int32_t));"))
|
||||
(define size-of-uint32_t (c-lambda () int "___return(sizeof(uint32_t));"))
|
||||
(define size-of-int64_t (c-lambda () int "___return(sizeof(int64_t));"))
|
||||
(define size-of-uint64_t (c-lambda () int "___return(sizeof(uint64_t));"))
|
||||
(define size-of-char (c-lambda () int "___return(sizeof(char));"))
|
||||
(define size-of-unsigned-char (c-lambda () int "___return(sizeof(unsigned char));"))
|
||||
(define size-of-short (c-lambda () int "___return(sizeof(short));"))
|
||||
(define size-of-unsigned-short (c-lambda () int "___return(sizeof(unsigned short));"))
|
||||
(define size-of-int (c-lambda () int "___return(sizeof(int));"))
|
||||
(define size-of-unsigned-int (c-lambda () int "___return(sizeof(unsigned int));"))
|
||||
(define size-of-long (c-lambda () int "___return(sizeof(long));"))
|
||||
(define size-of-unsigned-long (c-lambda () int "___return(sizeof(unsigned long));"))
|
||||
(define size-of-float (c-lambda () int "___return(sizeof(float));"))
|
||||
(define size-of-double (c-lambda () int "___return(sizeof(double));"))
|
||||
(define size-of-void* (c-lambda () int "___return(sizeof(void*));"))
|
||||
|
||||
|
||||
(define pffi-size-of
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) (c-lambda () int "___return(sizeof(int8_t));"))
|
||||
(else (error "pffi-size-of -- No such pffi type" type)))))
|
||||
(cond ((eq? type 'int8) (size-of-int8_t))
|
||||
((eq? type 'uint8) (size-of-uint8_t))
|
||||
((eq? type 'int16) (size-of-int16_t))
|
||||
((eq? type 'uint16) (size-of-uint16_t))
|
||||
((eq? type 'int32) (size-of-int32_t))
|
||||
((eq? type 'uint32) (size-of-uint32_t))
|
||||
((eq? type 'int64) (size-of-int64_t))
|
||||
((eq? type 'uint64) (size-of-uint64_t))
|
||||
((eq? type 'char) (size-of-char))
|
||||
((eq? type 'unsigned-char) (size-of-char))
|
||||
((eq? type 'short) (size-of-short))
|
||||
((eq? type 'unsigned-short) (size-of-unsigned-short))
|
||||
((eq? type 'int) (size-of-int))
|
||||
((eq? type 'unsigned-int) (size-of-unsigned-int))
|
||||
((eq? type 'long) (size-of-long))
|
||||
((eq? type 'unsigned-long) (size-of-unsigned-long))
|
||||
((eq? type 'float) (size-of-float))
|
||||
((eq? type 'double) (size-of-double))
|
||||
((eq? type 'pointer) (size-of-void*))
|
||||
(else (error "Can not get size of unknown type" type)))))
|
||||
|
||||
|
||||
#|
|
||||
#;(define-syntax pffi-pointer-allocate
|
||||
(syntax-rules
|
||||
((pffi-pointer-allocate size)
|
||||
(c-declare (string-append "malloc(" (number->string size) ")")))))
|
||||
|
||||
#;(define-syntax pffi-pointer-null
|
||||
(syntax-rules
|
||||
((pffi-pointer-null)
|
||||
(c-declare "NULL"))))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
string-content))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
||||
#;(define-syntax pffi-shared-object-load
|
||||
(syntax-rules ()
|
||||
((pffi-shared-object-load headers)
|
||||
(c-declare (apply string-append
|
||||
(map (lambda (header)
|
||||
(string-append "#include <" header ">"))))))))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(let ((p pointer))
|
||||
(error "Not defined"))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(error "Not defined")))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(error "Not defined")))
|
||||
|#
|
||||
(define-macro (pffi-shared-object-load headers)
|
||||
`(c-declare ,(string-append "#include <stdint.h>")))
|
||||
|
|
|
|||
|
|
@ -96,7 +96,7 @@
|
|||
(pointer->string pointer)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(lambda (headers path)
|
||||
(open-shared-library path)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
|
|
|
|||
Loading…
Reference in New Issue