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

Library is bit cleaner now

This commit is contained in:
retropikzel 2025-10-24 11:51:23 +03:00
parent 2710603c16
commit dd8880c9e6
10 changed files with 2589 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -42,3 +42,5 @@ README.html
foreign/c/primitives/chibi/foreign-c.c
*.pdf
.*
foreign/c.c
*.tmp

18
Makefile
View File

@ -19,6 +19,7 @@ MITLIBDIR=$(shell echo "(display (->namestring (system-library-directory-pathnam
build:
rm -rf *.tgz
echo "<pre>$$(cat README.md)</pre>" > README.html
snow-chibi package \
--version=${VERSION} \
@ -26,17 +27,7 @@ build:
--doc=README.html \
--foreign-depends=ffi \
--description="Portable foreign function interface for R7RS Schemes" \
--test=test.scm \
foreign/c.sld \
foreign/c/array.sld \
foreign/c/struct.sld \
foreign/c/chibi-primitives.sld \
foreign/c/chicken-primitives.sld \
foreign/c/guile-primitives.sld \
foreign/c/mosh-primitives.sld \
foreign/c/racket-primitives.sld \
foreign/c/sagittarius-primitives.sld \
foreign/c/ypsilon-primitives.sld
foreign/c.sld
build-gauche:
snow-chibi package \
@ -48,7 +39,7 @@ build-gauche:
foreign/c/gauche-primitives.stub
install:
snow-chibi --impls=${SCHEME} ${SNOW_CHIBI_ARGS} install ${PKG}
snow-chibi --impls=${SCHEME} --always-yes install ${PKG}
install-gauche:
if [ "${SCHEME}" = "gauche" ]; then \
@ -70,9 +61,6 @@ test: libtest.o libtest.so libtest.a
COMPILE_R7RS=${SCHEME} compile-r7rs -I . -o test test.scm
LD_LIBRARY_PATH=. ./test
test-no: package libtest.o libtest.so libtest.a
COMPILE_R7RS=${SCHEME} test-snowball --apt-pkgs "libffi-dev" ${PKG}
test-docker:
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=retropikzel-foreign-c-test-${SCHEME} -f Dockerfile.test .
docker run -v "${PWD}:/workdir" -w /workdir -t retropikzel-foreign-c-test-${SCHEME} sh -c "make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes build install test"

4
foreign/c.scm
View File

@ -190,7 +190,7 @@
(define libc-name "ucrtbase"))
(else
(define libc-name
(cond ((get-environment-variable "BE_HOST_CPU") "root") ; Haiku
(cond ;((get-environment-variable "BE_HOST_CPU") "root") ; Haiku
(else "c")))))
@ -315,7 +315,7 @@
(kawa
(define c-null?
(lambda (pointer)
(invoke pointer 'equals null-pointer))))
(invoke pointer 'equals (make-c-null)))))
;; FIXME
(chibi #t) ;; In chibi-primitives.stub
(gauche (define c-null? pointer-null?))

12
foreign/c.sld
View File

@ -8,22 +8,24 @@
(scheme inexact))
(cond-expand
(chibi (import (foreign c chibi-primitives)))
(chicken (import ;(chicken memory) ;; FIXME
(foreign c chicken-primitives)))
(chicken (import (foreign c chicken-primitives)))
;(cyclone (import (foreign c cyclone-primitives)))
;(gambit (import (foreign c gambit-primitives)))
;(gauche (import (foreign c gauche-primitives)))
(guile (import (foreign c guile-primitives)))
;(kawa (import (foreign c kawa-primitives)))
(kawa (import (foreign c kawa-primitives)))
;(mit-scheme (import (foreign c mit-scheme-primitives)))
;(larceny (import (foreign c larceny-primitives)))
(mosh (import (foreign c mosh-primitives)))
(racket (import (foreign c racket-primitives)))
(sagittarius (import (foreign c sagittarius-primitives)))
(stklos (import (foreign c stklos-primitives))
;; FIXME
(export foreign-c:string-split))
;(ypsilon (import (foreign c ypsilon-primitives)) (export int))
(ypsilon (import (foreign c ypsilon-primitives))
(export c-function
c-callback
bytevector-c-int8-set!
bytevector-c-uint8-ref))
)
(export ;;;; Primitives 1
c-type-size

10
foreign/c/chibi-primitives.scm
View File

@ -14,7 +14,7 @@
((equal? type 'unsigned-short) (c-bytevector-sint-ref pointer offset (native-endianness) (size-of-type 'unsigned-short)))
((equal? type 'int) (c-bytevector-sint-ref pointer offset (native-endianness) (size-of-type 'int)))
((equal? type 'unsigned-int) (c-bytevector-sint-ref pointer offset (native-endianness) (size-of-type 'unsigned-int)))
((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (sife-of-type 'long)))
((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (size-of-type 'long)))
((equal? type 'unsigned-long) (c-bytevector-sint-ref pointer offset (native-endianness) (size-of-type 'unsigned-long)))
((equal? type 'float) (c-bytevector-ieee-single-native-ref pointer offset))
((equal? type 'double) (c-bytevector-ieee-double-native-ref pointer offset))
@ -104,7 +104,8 @@
(define shared-object-load
(lambda (path options)
(let ((shared-object (dlopen path RTLD-NOW))
(maybe-error (dlerror)))
;(maybe-error (dlerror))
)
shared-object)))
(define c-bytevector?
@ -142,9 +143,10 @@
(define make-c-function
(lambda (shared-object c-name return-type argument-types)
(dlerror) ;; Clean all previous errors
;(dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror)))
;(maybe-dlerror (dlerror))
)
(lambda arguments
(let* ((return-pointer
(internal-ffi-call (length argument-types)

2533
foreign/c/cyclone-primitives.c Normal file
View File

File diff suppressed because it is too large Load Diff

13
foreign/c/cyclones-primitives.scm → foreign/c/cyclone-primitives.scm
View File

@ -93,6 +93,9 @@
((equal? type 'double) (c-value "sizeof(double)" int))
((equal? type 'pointer) (c-value "sizeof(void*)" int)))))
;; FIXME
(define align-of-type size-of-type)
(define-c pointer-address
"(void *data, int argc, closure _, object k, object pointer)"
"make_c_opaque(opq, &(void*)opaque_ptr(pointer));
@ -226,13 +229,13 @@
*p = double_value(value);
return_closcall1(data, k, make_boolean(boolean_t));")
(define-c pointer-pointer-set!
(define-c c-bytevector-pointer-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"uintptr_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = (uintptr_t)&opaque_ptr(value);
return_closcall1(data, k, make_boolean(boolean_t));")
(define pointer-set!
#;(define pointer-set!
(lambda (pointer type offset value)
(cond
((equal? type 'int8) (pointer-int8-set! pointer offset value))
@ -341,15 +344,15 @@
alloca_double(d, *p);
return_closcall1(data, k, d);")
(define-c pointer-pointer-get
(define-c c-bytevector-pointer-ref
"(void *data, int argc, closure _, object k, object pointer, object offset)"
"make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset));
return_closcall1(data, k, &opq);")
#;(define c-bytevector-u8-set! pointer-uint8-set!)
(define c-bytevector-u8-set! pointer-uint8-set!)
(define c-bytevector-u8-ref pointer-uint8-get)
(define pointer-get
#;(define pointer-get
(lambda (pointer type offset)
(cond
((equal? type 'int8) (pointer-int8-get pointer offset))

4
foreign/c/cyclone-primitives.sld
View File

@ -7,7 +7,7 @@
(scheme inexact)
(scheme process-context)
(cyclone foreign)
(scheme cyclone primitives)))
(scheme cyclone primitives))
(export size-of-type
align-of-type
shared-object-load
@ -18,4 +18,4 @@
c-bytevector-u8-set!
c-bytevector-pointer-ref
c-bytevector-pointer-set!)
(include "primitives-cyclone.scm"))
(include "cyclone-primitives.scm"))

26
foreign/c/gauche-primitives.scm Normal file
View File

@ -0,0 +1,26 @@
;;;; This file is dependent on content of other files added trough (include...)
;;;; And that's why it is separated
(define make-c-function
(lambda (shared-object c-name return-type argument-types)
(dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror)))
(lambda arguments
(let ((return-pointer (internal-ffi-call (length argument-types)
(type->libffi-type-number return-type)
(map type->libffi-type-number argument-types)
c-function
(size-of-type return-type)
arguments)))
(c-bytevector-get return-pointer return-type 0))))))
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-c-function shared-object
(symbol->string c-name)
return-type
argument-types)))))

1
foreign/c/kawa-primitives.scm
View File

@ -155,7 +155,6 @@
(list (cons 'linker linker)
(cons 'lookup lookup)))))
(define null-pointer (make-c-null))
(define u8-value-layout
(invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE)
'withByteAlignment