diff --git a/Jenkinsfile b/Jenkinsfile index 6ac2db2..edef2d3 100644 --- a/Jenkinsfile +++ b/Jenkinsfile @@ -1,10 +1,6 @@ pipeline { agent { - dockerfile { - label 'docker-x86_64' - filename 'Dockerfile.jenkins' - args '--user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock' - } + label 'docker-x86_64' } options { @@ -14,17 +10,39 @@ pipeline { parameters { //string(name: 'SCHEMES', defaultValue: 'chibi chicken gauche kawa racket sagittarius stklos', description: '') - string(name: 'SCHEMES', defaultValue: 'chibi', description: '') + string(name: 'SCHEMES', defaultValue: 'sagittarius', description: '') } stages { + stage('Build compile-r7rs') { + docker { + image "schemers/chicken:5" + label "docker-x86_64" + } + steps { + sh "git clone https://gitea.scheme.org/Retropikzel/compile-r7rs.git" + dir("compile-r7rs") { + sh "make build-chicken" + } + } + } + stage('Tests x86_64 Debian') { steps { script { params.SCHEMES.split().each { SCHEME -> + def IMG="${SCHEME}:head" + if("${SCHEME}" == "chicken") { + IMG="${SCHEME}:5" + } stage("${SCHEME}") { + docker { + image "schemers/${IMG}" + label "docker-x86_64" + args "--user=root" + } catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') { - sh "make package" + sh "COMPILE_R7RS=${SCHEME} compile-r7rs/compile-r7rs -I . test.scm" sh "make SCHEME=${SCHEME} test" } } diff --git a/Makefile b/Makefile index 4052752..758d973 100644 --- a/Makefile +++ b/Makefile @@ -1,17 +1,25 @@ .PHONY: package test libtest.o tests/libtest.so libtest.a documentation README.html +.SILENT: build install test test-docker clean SCHEME=chibi DOCKERIMG=${SCHEME}:head VERSION=0.10.9 +PKG=foreign-c-${VERSION}.tgz +GAUCHE_PKG=foreign-c-gauche-primitives-${VERSION}.tgz +GAUCHE_TAR=foreign-c-gauche-primitives-${VERSION}.tar CC=gcc PKG=foreign-c-${VERSION}.tgz - ifeq "${SCHEME}" "chicken" DOCKERIMG=${SCHEME}:5 endif -all: package +# Mit scheme specific +MITCMD=mit-scheme --batch-mode +MITDIR=${PWD}/foreign/c/primitives/mit-scheme +MITLIBDIR=$(shell echo "(display (->namestring (system-library-directory-pathname)))" | mit-scheme --batch-mode 2> /dev/null | tail -1) -package: README.html + +build: + echo "
$$(cat README.md)
" > README.html snow-chibi package \ --version=${VERSION} \ --authors="Retropikzel" \ @@ -19,28 +27,48 @@ package: README.html --foreign-depends=ffi \ --description="Portable foreign function interface for R7RS Schemes" \ --test=test.scm \ - foreign/c.sld + 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 -README.html: README.md - echo "
$$(cat README.md)
" > README.html +build-gauche: + snow-chibi package \ + --version=${VERSION} \ + --authors="Retropikzel" \ + --foreign-depends="libgauche ffi" \ + --description="Portable foreign function interface for R7RS Schemes - Gauche primitives" \ + foreign/c/gauche-primitives.sld \ + foreign/c/gauche-primitives.stub install: - snow-chibi --impls=${SCHEME} ${SNOW_CHIBI_ARGS} install foreign-c-${VERSION}.tgz; \ + snow-chibi --impls=${SCHEME} ${SNOW_CHIBI_ARGS} install ${PKG} + +install-gauche: if [ "${SCHEME}" = "gauche" ]; then \ - make gauche; \ - sudo cp foreign/c/primitives/gauche.scm $(shell gauche-config --sitelibdir)/foreign/c/primitives/;\ - sudo mkdir -p $(shell gauche-config --sitearchdir)/foreign/c/lib/; \ - sudo cp -r foreign/c/lib/gauche.so $(shell gauche-config --sitearchdir)/foreign/c/lib/; \ + snow-chibi --impls=${SCHEME} ${SNOW_CHIBI_ARGS} install ${GAUCHE_PKG}; \ fi + #make gauche; \ + #sudo cp foreign/c/primitives/gauche.scm $(shell gauche-config --sitelibdir)/foreign/c/primitives/;\ + #sudo mkdir -p $(shell gauche-config --sitearchdir)/foreign/c/lib/; \ + #sudo cp -r foreign/c/lib/gauche.so $(shell gauche-config --sitearchdir)/foreign/c/lib/; \ + #fi + uninstall: snow-chibi --impls=${SCHEME} remove "(foreign c)" test: libtest.o libtest.so libtest.a rm -rf test - COMPILE_R7RS_CHICKEN="-L -ltest -I. -L." \ - COMPILE_R7RS=${SCHEME} compile-r7rs -o test test.scm - ./test + COMPILE_R7RS_CHICKEN="-L -ltest -I./tests/c-include -L." \ + 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} @@ -58,40 +86,104 @@ libtest.so: tests/c-src/libtest.c libtest.a: libtest.o tests/c-src/libtest.c ar rcs libtest.a libtest.o ${LDFLAGS} -chibi: foreign/c/primitives/chibi/foreign-c.stub - chibi-ffi foreign/c/primitives/chibi/foreign-c.stub - ${CC} \ - ${CFLAGS} \ - -g3 \ - -o foreign/c/primitives/chibi/foreign-c.so \ - foreign/c/primitives/chibi/foreign-c.c \ - -fPIC \ - -lffi \ - -shared +chibi: foreign/c/chibi-primitives.stub + chibi-ffi foreign/c/chibi-primitives.stub + #${CC} ${CFLAGS} -g3 -o foreign/c/primitives/chibi/foreign-c.so foreign/c/primitives/chibi/foreign-c.c -fPIC -lffi -shared gauche: gauche-package compile \ - --srcdir=foreign/c/primitives/gauche \ - --cc=${CC} \ - --cflags="${CFLAGS} -I.foreign/c/primitives/gauche" \ - --libs=-lffi \ - foreign-c-primitives-gauche foreign-c-primitives-gauche.c gauchelib.scm - mkdir -p foreign/c/lib - mv foreign-c-primitives-gauche.so foreign/c/lib/gauche.so - mv foreign-c-primitives-gauche.o foreign/c/lib/gauche.o + --srcdir=foreign/c \ + --keep-c-files \ + gauche-primitives \ + gauche-primitives.gauche.scm + #gcc -shared -o foreign/c/gauche-primitives.so gauche-primitives.so + #--verbose \ + #--keep-c-files \ + #--srcdir=foreign/c/gauche \ + #--cc=${CC} \ + #--cflags="${CFLAGS} -I.foreign/c/gauche" \ + #--libs=-lffi \ + #foreign-c-gauche-primitives foreign-c-gauche-primitives.c gauchelib.scm + #mkdir -p foreign/c/lib + #mv foreign-c-gauche-primitives.so foreign/c/lib/gauche.so + #mv foreign-c-gauche-primitives.o foreign/c/lib/gauche.o + +mit-scheme: + cd ${MITDIR} && echo "(load-option 'ffi) (c-generate \"mit-scheme-foreign-c\" \"#include \n#include \") " | ${MITCMD} + cd ${MITDIR} && ${CC} -shared -Wall -fPIC -lffi -o mit-scheme-foreign-c-shim.so mit-scheme-foreign-c-shim.c -I${MITLIBDIR} + cd ${MITDIR} && ${CC} -Wall -fPIC -lffi -o mit-scheme-foreign-c-const mit-scheme-foreign-c-const.c -I$(shell mit-scheme --batch-mode --eval "(display (->namestring (system-library-directory-pathname)))" --eval "(exit 0)" | tail -1) + cd ${MITDIR} && ./mit-scheme-foreign-c-const + cd ${MITDIR} && echo "(sf \"mit-scheme-foreign-c-const\")" | ${MITCMD} + cd ${MITDIR} && echo "(generate-shim \"mit-scheme-foreign-c\" \"#include \n#include \")" | ${MITCMD} + sudo cp foreign/c/primitives/mit-scheme/mit-scheme-foreign-c-types.bin ${MITLIBDIR} + sudo cp foreign/c/primitives/mit-scheme/mit-scheme-foreign-c-const.bin ${MITLIBDIR} + sudo cp foreign/c/primitives/mit-scheme/mit-scheme-foreign-c-shim.so ${MITLIBDIR} + cd foreign && echo '(compile-file "c-mit-scheme.sld")' | ${MITCMD} + sudo mkdir -p ${MITLIBDIR}/libraries/foreign + sudo cp foreign/c-mit-scheme.binld ${MITLIBDIR} #/libraries/foreign/ + sudo cp foreign/c-mit-scheme.comld ${MITLIBDIR} #/libraries/foreign/ + #sudo cp foreign/c-mit-scheme.sld ${MITLIBDIR} #/libraries/foreign/ + + +test-mit-scheme: + LD_LIBRARY_PATH=${PWD}/foreign/c/primitives/mit-scheme \ + echo "(exit 0)" | mit-scheme --batch-mode --load test.scm --eval "(exit 0)" + + +mit-scheme-old: + cd foreign/c/primitives/mit-scheme \ + && ${CC} \ + -c -Wall -fPIC -lffi -o mit-scheme-foreign-c.o mit-scheme-foreign-c-shim.c \ + -I$(shell mit-scheme --batch-mode --eval "(display (->namestring (system-library-directory-pathname)))" --eval "(exit 0)" | tail -1) + cd foreign/c/primitives/mit-scheme \ + #&& ${CC} -shared -Wall -fPIC -o mit-scheme-foreign-c.so mit-scheme-foreign-c-shim.o + cd foreign/c/primitives/mit-scheme \ + && mit-scheme --batch-mode \ + --eval "(generate-shim \"mit-scheme-foreign-c\" \"#include \n#include \")" \ + --eval "(exit 0)" + cd foreign/c/primitives/mit-scheme \ + && ${CC} -c -o mit-scheme-foreign-c-const.o mit-scheme-foreign-c-const.c + cd foreign/c/primitives/mit-scheme \ + && ${CC} -o mit-scheme-foreign-c-const mit-scheme-foreign-c-const.o + cd foreign/c/primitives/mit-scheme \ + && ./mit-scheme-foreign-c-const + cd foreign/c/primitives/mit-scheme \ + && echo '(sf "mit-scheme-foreign-c-const")' | mit-scheme --batch-mode + cd foreign \ + && echo '(sf "c-mit-scheme.sld")' | mit-scheme --batch-mode clean: find . -name "*.meta" -delete find . -name "*.link" -delete find . -name "*.o" -delete + find . -name "*.bci" -delete + find . -name "*.com" -delete + find . -name "*.comld" -delete + find . -name "*.bin" -delete + find . -name "*.binld" -delete + find . -name "*.bcild" -delete find . -name "*.o[1-9]" -delete find . -name "*.so" -delete find . -name "*.a" -delete find . -name "*.class" -delete + find . -name "*.jar" -delete find . -name "core.1" -delete find . -name "*@gambit*" -delete + find . -name "*.import.scm" -delete + find . -name "*.cdecl" -delete + find . -name "*.log" -delete + find . -name "*.tgz" -delete + find . -name "*.rkt" -delete + find . -name "*.tar.gz" -delete + rm -rf MANIFEST.mf rm -rf tmp rm -rf foreign/c/primitives/chibi/foreign-c.c rm -rf foreign/c/lib + rm -rf foreign/c/primitives/mit-scheme/mit-scheme-foreign-c-shim.c + rm -rf foreign/c/primitives/mit-scheme/mit-scheme-foreign-c-const.c + rm -rf foreign/c/primitives/mit-scheme/mit-scheme-foreign-c-const + rm -rf foreign/c/primitives/mit-scheme/mit-scheme-foreign-c-const.scm rm -rf *.tgz rm -rf README.html + rm -rf test + rm -rf testfile.test diff --git a/OLD_README.md b/OLD/OLD_README.md similarity index 100% rename from OLD_README.md rename to OLD/OLD_README.md diff --git a/VERSION b/OLD/VERSION similarity index 100% rename from VERSION rename to OLD/VERSION diff --git a/OLD/c-mit-scheme.sld b/OLD/c-mit-scheme.sld new file mode 100644 index 0000000..f43d32a --- /dev/null +++ b/OLD/c-mit-scheme.sld @@ -0,0 +1,43 @@ +(define-library + (foreign c-mit-scheme) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + ;(scheme load) + (scheme process-context) + ;(only (mit legacy runtime) load-option all-packages) + (only (mit legacy runtime) + load + load-option + ->pathname + dld-load-file + call-alien + ;compile-file + make-alien-function + ;generate-shim + ) + ) + (export hello) +#;(begin +;(declare (usual-integrations)) + +;(C-include "mit-scheme-foreign-c") + +(define (hello) + ;(puts "Hello from puts") + (display "Not from puts") + (newline) + )) +;(C-call "puts" "Hello world") + ;(include "c/internal.scm") + (include "c/primitives/mit-scheme.scm") + ;(include "c/c-types.scm") + ;(include "c/main.scm") + ;(include "c/libc.scm") + ;(include "c/c-bytevectors.scm") + ;(include "c/pointer.scm") + ;(include "c/array.scm") + ;(include "c/struct.scm") + ) diff --git a/foreign/c/c-types.scm b/OLD/c-types.scm similarity index 100% rename from foreign/c/c-types.scm rename to OLD/c-types.scm diff --git a/documentation/foreign-c.html b/OLD/documentation/foreign-c.html similarity index 100% rename from documentation/foreign-c.html rename to OLD/documentation/foreign-c.html diff --git a/foreign/c/primitives/gauche/foreign-c-primitives-gauche.c b/OLD/gauche-old/gauche-primitives.c similarity index 99% rename from foreign/c/primitives/gauche/foreign-c-primitives-gauche.c rename to OLD/gauche-old/gauche-primitives.c index 6ae2d4f..5356aa1 100644 --- a/foreign/c/primitives/gauche/foreign-c-primitives-gauche.c +++ b/OLD/gauche-old/gauche-primitives.c @@ -6,7 +6,7 @@ #include #include #include -#include +#include #include #include @@ -830,6 +830,6 @@ ScmObj procedure_to_pointer(ScmObj procedure) { void Scm_Init_gauche(void) { SCM_INIT_EXTENSION(foreign.c.primitives.gauche); - module = SCM_MODULE(SCM_FIND_MODULE("foreign.c.primitives.gauche", TRUE)); - Scm_Init_gauchelib(); + module = SCM_MODULE(SCM_FIND_MODULE("foreign.c.gauche.primitives", TRUE)); + Scm_Init_foreign_c_gauche_primitives(); } diff --git a/OLD/gauche-old/gauche-primitives.gauche.c b/OLD/gauche-old/gauche-primitives.gauche.c new file mode 100644 index 0000000..b7708cf --- /dev/null +++ b/OLD/gauche-old/gauche-primitives.gauche.c @@ -0,0 +1,6 @@ +#include + + +int lol() { + return 1; +} diff --git a/foreign/c/primitives/gauche/foreign-c-primitives-gauche.h b/OLD/gauche-old/gauche-primitives.h similarity index 98% rename from foreign/c/primitives/gauche/foreign-c-primitives-gauche.h rename to OLD/gauche-old/gauche-primitives.h index d68d885..d7b8119 100644 --- a/foreign/c/primitives/gauche/foreign-c-primitives-gauche.h +++ b/OLD/gauche-old/gauche-primitives.h @@ -104,5 +104,5 @@ extern ScmObj get_ffi_type_double(); extern ScmObj get_ffi_type_void(); extern ScmObj get_ffi_type_pointer(); -extern void Scm_Init_gauchelib(void); +extern void Scm_Init_foreign_c_gauche_primitives(void); diff --git a/OLD/gauche-old/gauche-primitives.sci b/OLD/gauche-old/gauche-primitives.sci new file mode 100644 index 0000000..cf4d374 --- /dev/null +++ b/OLD/gauche-old/gauche-primitives.sci @@ -0,0 +1,5 @@ +;; generated automatically. DO NOT EDIT +#!no-fold-case +(define-module gauche.primitives (export hello)) +(select-module gauche.primitives) +(dynamic-load "gauche-primitives.so") diff --git a/OLD/gauche-old/gauche-primitives.scm b/OLD/gauche-old/gauche-primitives.scm new file mode 100644 index 0000000..3884299 --- /dev/null +++ b/OLD/gauche-old/gauche-primitives.scm @@ -0,0 +1,143 @@ +(define-module gauche.primitives + (export hello)) +(select-module gauche.primitives) + + +(define (hello) + (display "Hello world") + (newline)) + +(inline-stub +(declcode + (.include "math.h") + (.include "stdint.h") + (.include "gauche.h") + (.include "gauche/extend.h") + (.include "gauche/module.h") + (.include "gauche/load.h") + (.include "gauche/number.h") + (.include "gauche/string.h") + (.include "gauche-primitives.h") + (.include "ffi.h") + (.include "dlfcn.h")) + +(define-cproc size-of-int8 () size_of_int8) +(define-cproc size-of-uint8 () size_of_uint8) +(define-cproc size-of-int16 () size_of_int16) +(define-cproc size-of-uint16 () size_of_int16) +(define-cproc size-of-int32 () size_of_int32) +(define-cproc size-of-uint32 () size_of_int32) +(define-cproc size-of-int64 () size_of_int64) +(define-cproc size-of-uint64 () size_of_int64) +(define-cproc size-of-char () size_of_char) +(define-cproc size-of-unsigned-char () size_of_unsigned_char) +(define-cproc size-of-short () size_of_short) +(define-cproc size-of-unsigned-short () size_of_unsigned_short) +(define-cproc size-of-int () size_of_int) +(define-cproc size-of-unsigned-int () size_of_unsigned_int) +(define-cproc size-of-long () size_of_long) +(define-cproc size-of-unsigned-long () size_of_unsigned_long) +(define-cproc size-of-float () size_of_float) +(define-cproc size-of-double () size_of_double) +(define-cproc size-of-string () size_of_string) +(define-cproc size-of-pointer () size_of_pointer) +(define-cproc size-of-void () size_of_void) + +(define-cproc align-of-int8 () align_of_int8) +(define-cproc align-of-uint8 () align_of_uint8) +(define-cproc align-of-int16 () align_of_int16) +(define-cproc align-of-uint16 () align_of_int16) +(define-cproc align-of-int32 () align_of_int32) +(define-cproc align-of-uint32 () align_of_int32) +(define-cproc align-of-int64 () align_of_int64) +(define-cproc align-of-uint64 () align_of_int64) +(define-cproc align-of-char () align_of_char) +(define-cproc align-of-unsigned-char () align_of_unsigned_char) +(define-cproc align-of-short () align_of_short) +(define-cproc align-of-unsigned-short () align_of_unsigned_short) +(define-cproc align-of-int () align_of_int) +(define-cproc align-of-unsigned-int () align_of_unsigned_int) +(define-cproc align-of-long () align_of_long) +(define-cproc align-of-unsigned-long () align_of_unsigned_long) +(define-cproc align-of-float () align_of_float) +(define-cproc align-of-double () align_of_double) +(define-cproc align-of-string () align_of_string) +(define-cproc align-of-pointer () align_of_pointer) +(define-cproc align-of-void () align_of_void) + +(define-cproc shared-object-load (path:: options) shared_object_load) +;(define-cproc pointer-null () pointer_null) +(define-cproc pointer-null? (pointer) is_pointer_null) +;(define-cproc pointer-allocate (size::) pointer_allocate) +;(define-cproc pointer-address (object) pointer_address) +(define-cproc pointer? (pointer) is_pointer) +;(define-cproc pointer-free (pointer) pointer_free) + +;(define-cproc pointer-set-int8! (pointer offset:: value::) pointer_set_int8) +(define-cproc pointer-set-uint8! (pointer offset:: value::) pointer_set_uint8) +;(define-cproc pointer-set-int16! (pointer offset:: value::) pointer_set_int16) +;(define-cproc pointer-set-uint16! (pointer offset:: value::) pointer_set_uint16) +;(define-cproc pointer-set-int32! (pointer offset:: value::) pointer_set_int32) +;(define-cproc pointer-set-uint32! (pointer offset:: value::) pointer_set_uint32) +;(define-cproc pointer-set-int64! (pointer offset:: value::) pointer_set_int64) +;(define-cproc pointer-set-uint64! (pointer offset:: value::) pointer_set_uint64) +;(define-cproc pointer-set-char! (pointer offset:: value::) pointer_set_char) +;(define-cproc pointer-set-unsigned-char! (pointer offset:: value::) pointer_set_unsigned_char) +;(define-cproc pointer-set-short! (pointer offset:: value::) pointer_set_short) +;(define-cproc pointer-set-unsigned-short! (pointer offset:: value::) pointer_set_unsigned_short) +;(define-cproc pointer-set-int! (pointer offset:: value::) pointer_set_int) +;(define-cproc pointer-set-unsigned-int! (pointer offset:: value::) pointer_set_unsigned_int) +;(define-cproc pointer-set-long! (pointer offset:: value::) pointer_set_long) +;(define-cproc pointer-set-unsigned-long! (pointer offset:: value::) pointer_set_unsigned_long) +;(define-cproc pointer-set-float! (pointer offset:: value::) pointer_set_float) +;(define-cproc pointer-set-double! (pointer offset:: value::) pointer_set_double) +(define-cproc pointer-set-pointer! (pointer offset:: value) pointer_set_pointer) + +;(define-cproc pointer-get-int8 (pointer offset::) pointer_get_int8) +(define-cproc pointer-get-uint8 (pointer offset::) pointer_get_uint8) +;(define-cproc pointer-get-int16 (pointer offset::) pointer_get_int16) +;(define-cproc pointer-get-uint16 (pointer offset::) pointer_get_uint16) +;(define-cproc pointer-get-int32 (pointer offset::) pointer_get_int32) +;(define-cproc pointer-get-uint32 (pointer offset::) pointer_get_uint32) +;(define-cproc pointer-get-int64 (pointer offset::) pointer_get_int64) +;(define-cproc pointer-get-uint64 (pointer offset::) pointer_get_uint64) +;(define-cproc pointer-get-char (pointer offset::) pointer_get_char) +;(define-cproc pointer-get-unsigned-char (pointer offset::) pointer_get_unsigned_char) +;(define-cproc pointer-get-short (pointer offset::) pointer_get_short) +;(define-cproc pointer-get-unsigned-short (pointer offset::) pointer_get_unsigned_short) +;(define-cproc pointer-get-int (pointer offset::) pointer_get_int) +;(define-cproc pointer-get-unsigned-int (pointer offset::) pointer_get_unsigned_int) +;(define-cproc pointer-get-long (pointer offset::) pointer_get_long) +;(define-cproc pointer-get-unsigned-long (pointer offset::) pointer_get_unsigned_long) +;(define-cproc pointer-get-float (pointer offset::) pointer_get_float) +;(define-cproc pointer-get-double (pointer offset::) pointer_get_double) +(define-cproc pointer-get-pointer (pointer offset::) pointer_get_pointer) + +(define-cproc dlerror () internal_dlerror) +(define-cproc dlsym (shared-object c-name) internal_dlsym) +(define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call) +(define-cproc scheme-procedure-to-pointer (procedure) scheme_procedure_to_pointer) + +;(define-cproc get-ffi-type-int8 () get_ffi_type_int8) +;(define-cproc get-ffi-type-uint8 () get_ffi_type_uint8) +;(define-cproc get-ffi-type-int16 () get_ffi_type_int16) +;(define-cproc get-ffi-type-uint16 () get_ffi_type_uint16) +;(define-cproc get-ffi-type-int32 () get_ffi_type_int32) +;(define-cproc get-ffi-type-uint32 () get_ffi_type_uint32) +;(define-cproc get-ffi-type-int64 () get_ffi_type_int64) +;(define-cproc get-ffi-type-uint64 () get_ffi_type_uint64) +;(define-cproc get-ffi-type-char () get_ffi_type_char) +;(define-cproc get-ffi-type-unsigned-char () get_ffi_type_unsigned_char) +;(define-cproc get-ffi-type-short () get_ffi_type_short) +;(define-cproc get-ffi-type-unsigned-short () get_ffi_type_unsigned_short) +;(define-cproc get-ffi-type-int () get_ffi_type_int) +;(define-cproc get-ffi-type-unsigned-int () get_ffi_type_unsigned_int) +;(define-cproc get-ffi-type-long () get_ffi_type_long) +;(define-cproc get-ffi-type-unsigned-long () get_ffi_type_unsigned_long) +;(define-cproc get-ffi-type-float () get_ffi_type_float) +;(define-cproc get-ffi-type-double () get_ffi_type_double) +;(define-cproc get-ffi-type-void() get_ffi_type_void) +;(define-cproc get-ffi-type-pointer () get_ffi_type_pointer) + +;(define-cproc procedure-to-pointer (procedure) procedure_to_pointer) +) diff --git a/OLD/gauche-old/gauche-primitives.sld b/OLD/gauche-old/gauche-primitives.sld new file mode 100644 index 0000000..374a182 --- /dev/null +++ b/OLD/gauche-old/gauche-primitives.sld @@ -0,0 +1,179 @@ +(define-library + (foreign c primitives-gauche) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (gauche base)) + (export size-of-type + shared-object-load + c-bytevector-u8-set! + c-bytevector-u8-ref + c-bytevector-pointer-set! + c-bytevector-pointer-ref + ;pointer-null + pointer-null? + ;make-c-bytevector + ;pointer-address + c-bytevector? + c-free + ;pointer-set! + ;pointer-get + ;define-c-procedure + define-c-callback + dlerror + dlsym + internal-ffi-call)) + +;(select-module primitives.gauche) +(dynamic-load "foreign/c/gauche-primitives") + +(define size-of-type + (lambda (type) + (cond ((equal? type 'int8) (size-of-int8)) + ((equal? type 'uint8) (size-of-uint8)) + ((equal? type 'int16) (size-of-int16)) + ((equal? type 'uint16) (size-of-uint16)) + ((equal? type 'int32) (size-of-int32)) + ((equal? type 'uint32) (size-of-uint32)) + ((equal? type 'int64) (size-of-int64)) + ((equal? type 'uint64) (size-of-uint64)) + ((equal? type 'char) (size-of-char)) + ((equal? type 'unsigned-char) (size-of-unsigned-char)) + ((equal? type 'short) (size-of-short)) + ((equal? type 'unsigned-short) (size-of-unsigned-short)) + ((equal? type 'int) (size-of-int)) + ((equal? type 'unsigned-int) (size-of-unsigned-int)) + ((equal? type 'long) (size-of-long)) + ((equal? type 'unsigned-long) (size-of-unsigned-long)) + ((equal? type 'float) (size-of-float)) + ((equal? type 'double) (size-of-double)) + ((equal? type 'string) (size-of-string)) + ((equal? type 'pointer) (size-of-pointer)) + ((equal? type 'void) (size-of-void))))) + +(define align-of-type + (lambda (type) + (cond ((equal? type 'int8) (align-of-int8)) + ((equal? type 'uint8) (align-of-uint8)) + ((equal? type 'int16) (align-of-int16)) + ((equal? type 'uint16) (align-of-uint16)) + ((equal? type 'int32) (align-of-int32)) + ((equal? type 'uint32) (align-of-uint32)) + ((equal? type 'int64) (align-of-int64)) + ((equal? type 'uint64) (align-of-uint64)) + ((equal? type 'char) (align-of-char)) + ((equal? type 'unsigned-char) (align-of-unsigned-char)) + ((equal? type 'short) (align-of-short)) + ((equal? type 'unsigned-short) (align-of-unsigned-short)) + ((equal? type 'int) (align-of-int)) + ((equal? type 'unsigned-int) (align-of-unsigned-int)) + ((equal? type 'long) (align-of-long)) + ((equal? type 'unsigned-long) (align-of-unsigned-long)) + ((equal? type 'float) (align-of-float)) + ((equal? type 'double) (align-of-double)) + ((equal? type 'string) (align-of-string)) + ((equal? type 'pointer) (align-of-pointer)) + ((equal? type 'void) (align-of-void))))) + +#;(define shared-object-load +(lambda (path options) + (shared-object-load path))) + +#;(define make-c-bytevector +(lambda (size) + (pointer-allocate size))) + +(define c-bytevector? + (lambda (pointer) + (pointer? pointer))) + +#;(define c-free +(lambda (pointer) + (pointer-free pointer))) + +(define c-bytevector-u8-set! pointer-set-uint8!) +(define c-bytevector-u8-ref pointer-get-uint8) +(define c-bytevector-pointer-set! pointer-set-pointer!) +(define c-bytevector-pointer-ref pointer-get-pointer) + +#;(define pointer-set! +(lambda (pointer type offset value) + (cond ((equal? type 'int8) (pointer-set-int8! pointer offset value)) + ((equal? type 'uint8) (pointer-set-uint8! pointer offset value)) + ((equal? type 'int16) (pointer-set-int16! pointer offset value)) + ((equal? type 'uint16) (pointer-set-uint16! pointer offset value)) + ((equal? type 'int32) (pointer-set-int32! pointer offset value)) + ((equal? type 'uint32) (pointer-set-uint32! pointer offset value)) + ((equal? type 'int64) (pointer-set-int64! pointer offset value)) + ((equal? type 'uint64) (pointer-set-uint64! pointer offset value)) + ((equal? type 'char) (pointer-set-char! pointer offset value)) + ((equal? type 'short) (pointer-set-short! pointer offset value)) + ((equal? type 'unsigned-short) (pointer-set-unsigned-short! pointer offset value)) + ((equal? type 'int) (pointer-set-int! pointer offset value)) + ((equal? type 'unsigned-int) (pointer-set-unsigned-int! pointer offset value)) + ((equal? type 'long) (pointer-set-long! pointer offset value)) + ((equal? type 'unsigned-long) (pointer-set-unsigned-long! pointer offset value)) + ((equal? type 'float) (pointer-set-float! pointer offset value)) + ((equal? type 'double) (pointer-set-double! pointer offset value)) + ((equal? type 'void) (pointer-set-pointer! pointer offset value)) + ((equal? type 'pointer) (pointer-set-pointer! pointer offset value))))) + +#;(define pointer-get +(lambda (pointer type offset) + (cond ((equal? type 'int8) (pointer-get-int8 pointer offset)) + ((equal? type 'uint8) (pointer-get-uint8 pointer offset)) + ((equal? type 'int16) (pointer-get-int16 pointer offset)) + ((equal? type 'uint16) (pointer-get-uint16 pointer offset)) + ((equal? type 'int32) (pointer-get-int32 pointer offset)) + ((equal? type 'uint32) (pointer-get-uint32 pointer offset)) + ((equal? type 'int64) (pointer-get-int64 pointer offset)) + ((equal? type 'uint64) (pointer-get-uint64 pointer offset)) + ((equal? type 'char) (integer->char (pointer-get-char pointer offset))) + ((equal? type 'short) (pointer-get-short pointer offset)) + ((equal? type 'unsigned-short) (pointer-get-unsigned-short pointer offset)) + ((equal? type 'int) (pointer-get-int pointer offset)) + ((equal? type 'unsigned-int) (pointer-get-unsigned-int pointer offset)) + ((equal? type 'long) (pointer-get-long pointer offset)) + ((equal? type 'unsigned-long) (pointer-get-unsigned-long pointer offset)) + ((equal? type 'float) (pointer-get-float pointer offset)) + ((equal? type 'double) (pointer-get-double pointer offset)) + ((equal? type 'void) (pointer-get-pointer pointer offset)) + ((equal? type 'pointer) (pointer-get-pointer pointer offset))))) + +#;(define type->libffi-type +(lambda (type) + (cond ((equal? type 'int8) (get-ffi-type-int8)) + ((equal? type 'uint8) (get-ffi-type-uint8)) + ((equal? type 'int16) (get-ffi-type-int16)) + ((equal? type 'uint16) (get-ffi-type-uint16)) + ((equal? type 'int32) (get-ffi-type-int32)) + ((equal? type 'uint32) (get-ffi-type-uint32)) + ((equal? type 'int64) (get-ffi-type-int64)) + ((equal? type 'uint64) (get-ffi-type-uint64)) + ((equal? type 'char) (get-ffi-type-char)) + ((equal? type 'unsigned-char) (get-ffi-type-uchar)) + ((equal? type 'bool) (get-ffi-type-int8)) + ((equal? type 'short) (get-ffi-type-short)) + ((equal? type 'unsigned-short) (get-ffi-type-ushort)) + ((equal? type 'int) (get-ffi-type-int)) + ((equal? type 'unsigned-int) (get-ffi-type-uint)) + ((equal? type 'long) (get-ffi-type-long)) + ((equal? type 'unsigned-long) (get-ffi-type-ulong)) + ((equal? type 'float) (get-ffi-type-float)) + ((equal? type 'double) (get-ffi-type-double)) + ((equal? type 'void) (get-ffi-type-void)) + ((equal? type 'pointer) (get-ffi-type-pointer)) + ((equal? type 'callback) (get-ffi-type-pointer))))) + +(define make-c-callback + (lambda (return-type argument-types procedure) + (scheme-procedure-to-pointer procedure))) + +(define-syntax define-c-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name + (make-c-callback return-type 'argument-types procedure))))) diff --git a/OLD/gauche-old/gauche-primitives.stub b/OLD/gauche-old/gauche-primitives.stub new file mode 100644 index 0000000..65fd991 --- /dev/null +++ b/OLD/gauche-old/gauche-primitives.stub @@ -0,0 +1,120 @@ + +(define-cproc size-of-int8 () size_of_int8) +(define-cproc size-of-uint8 () size_of_uint8) +(define-cproc size-of-int16 () size_of_int16) +(define-cproc size-of-uint16 () size_of_int16) +(define-cproc size-of-int32 () size_of_int32) +(define-cproc size-of-uint32 () size_of_int32) +(define-cproc size-of-int64 () size_of_int64) +(define-cproc size-of-uint64 () size_of_int64) +(define-cproc size-of-char () size_of_char) +(define-cproc size-of-unsigned-char () size_of_unsigned_char) +(define-cproc size-of-short () size_of_short) +(define-cproc size-of-unsigned-short () size_of_unsigned_short) +(define-cproc size-of-int () size_of_int) +(define-cproc size-of-unsigned-int () size_of_unsigned_int) +(define-cproc size-of-long () size_of_long) +(define-cproc size-of-unsigned-long () size_of_unsigned_long) +(define-cproc size-of-float () size_of_float) +(define-cproc size-of-double () size_of_double) +(define-cproc size-of-string () size_of_string) +(define-cproc size-of-pointer () size_of_pointer) +(define-cproc size-of-void () size_of_void) + +(define-cproc align-of-int8 () align_of_int8) +(define-cproc align-of-uint8 () align_of_uint8) +(define-cproc align-of-int16 () align_of_int16) +(define-cproc align-of-uint16 () align_of_int16) +(define-cproc align-of-int32 () align_of_int32) +(define-cproc align-of-uint32 () align_of_int32) +(define-cproc align-of-int64 () align_of_int64) +(define-cproc align-of-uint64 () align_of_int64) +(define-cproc align-of-char () align_of_char) +(define-cproc align-of-unsigned-char () align_of_unsigned_char) +(define-cproc align-of-short () align_of_short) +(define-cproc align-of-unsigned-short () align_of_unsigned_short) +(define-cproc align-of-int () align_of_int) +(define-cproc align-of-unsigned-int () align_of_unsigned_int) +(define-cproc align-of-long () align_of_long) +(define-cproc align-of-unsigned-long () align_of_unsigned_long) +(define-cproc align-of-float () align_of_float) +(define-cproc align-of-double () align_of_double) +(define-cproc align-of-string () align_of_string) +(define-cproc align-of-pointer () align_of_pointer) +(define-cproc align-of-void () align_of_void) + +(define-cproc shared-object-load (path:: options) shared_object_load) +;(define-cproc pointer-null () pointer_null) +(define-cproc pointer-null? (pointer) is_pointer_null) +;(define-cproc pointer-allocate (size::) pointer_allocate) +;(define-cproc pointer-address (object) pointer_address) +(define-cproc pointer? (pointer) is_pointer) +;(define-cproc pointer-free (pointer) pointer_free) + +;(define-cproc pointer-set-int8! (pointer offset:: value::) pointer_set_int8) +(define-cproc pointer-set-uint8! (pointer offset:: value::) pointer_set_uint8) +;(define-cproc pointer-set-int16! (pointer offset:: value::) pointer_set_int16) +;(define-cproc pointer-set-uint16! (pointer offset:: value::) pointer_set_uint16) +;(define-cproc pointer-set-int32! (pointer offset:: value::) pointer_set_int32) +;(define-cproc pointer-set-uint32! (pointer offset:: value::) pointer_set_uint32) +;(define-cproc pointer-set-int64! (pointer offset:: value::) pointer_set_int64) +;(define-cproc pointer-set-uint64! (pointer offset:: value::) pointer_set_uint64) +;(define-cproc pointer-set-char! (pointer offset:: value::) pointer_set_char) +;(define-cproc pointer-set-unsigned-char! (pointer offset:: value::) pointer_set_unsigned_char) +;(define-cproc pointer-set-short! (pointer offset:: value::) pointer_set_short) +;(define-cproc pointer-set-unsigned-short! (pointer offset:: value::) pointer_set_unsigned_short) +;(define-cproc pointer-set-int! (pointer offset:: value::) pointer_set_int) +;(define-cproc pointer-set-unsigned-int! (pointer offset:: value::) pointer_set_unsigned_int) +;(define-cproc pointer-set-long! (pointer offset:: value::) pointer_set_long) +;(define-cproc pointer-set-unsigned-long! (pointer offset:: value::) pointer_set_unsigned_long) +;(define-cproc pointer-set-float! (pointer offset:: value::) pointer_set_float) +;(define-cproc pointer-set-double! (pointer offset:: value::) pointer_set_double) +(define-cproc pointer-set-pointer! (pointer offset:: value) pointer_set_pointer) + +;(define-cproc pointer-get-int8 (pointer offset::) pointer_get_int8) +(define-cproc pointer-get-uint8 (pointer offset::) pointer_get_uint8) +;(define-cproc pointer-get-int16 (pointer offset::) pointer_get_int16) +;(define-cproc pointer-get-uint16 (pointer offset::) pointer_get_uint16) +;(define-cproc pointer-get-int32 (pointer offset::) pointer_get_int32) +;(define-cproc pointer-get-uint32 (pointer offset::) pointer_get_uint32) +;(define-cproc pointer-get-int64 (pointer offset::) pointer_get_int64) +;(define-cproc pointer-get-uint64 (pointer offset::) pointer_get_uint64) +;(define-cproc pointer-get-char (pointer offset::) pointer_get_char) +;(define-cproc pointer-get-unsigned-char (pointer offset::) pointer_get_unsigned_char) +;(define-cproc pointer-get-short (pointer offset::) pointer_get_short) +;(define-cproc pointer-get-unsigned-short (pointer offset::) pointer_get_unsigned_short) +;(define-cproc pointer-get-int (pointer offset::) pointer_get_int) +;(define-cproc pointer-get-unsigned-int (pointer offset::) pointer_get_unsigned_int) +;(define-cproc pointer-get-long (pointer offset::) pointer_get_long) +;(define-cproc pointer-get-unsigned-long (pointer offset::) pointer_get_unsigned_long) +;(define-cproc pointer-get-float (pointer offset::) pointer_get_float) +;(define-cproc pointer-get-double (pointer offset::) pointer_get_double) +(define-cproc pointer-get-pointer (pointer offset::) pointer_get_pointer) + +(define-cproc dlerror () internal_dlerror) +(define-cproc dlsym (shared-object c-name) internal_dlsym) +(define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call) +(define-cproc scheme-procedure-to-pointer (procedure) scheme_procedure_to_pointer) + +;(define-cproc get-ffi-type-int8 () get_ffi_type_int8) +;(define-cproc get-ffi-type-uint8 () get_ffi_type_uint8) +;(define-cproc get-ffi-type-int16 () get_ffi_type_int16) +;(define-cproc get-ffi-type-uint16 () get_ffi_type_uint16) +;(define-cproc get-ffi-type-int32 () get_ffi_type_int32) +;(define-cproc get-ffi-type-uint32 () get_ffi_type_uint32) +;(define-cproc get-ffi-type-int64 () get_ffi_type_int64) +;(define-cproc get-ffi-type-uint64 () get_ffi_type_uint64) +;(define-cproc get-ffi-type-char () get_ffi_type_char) +;(define-cproc get-ffi-type-unsigned-char () get_ffi_type_unsigned_char) +;(define-cproc get-ffi-type-short () get_ffi_type_short) +;(define-cproc get-ffi-type-unsigned-short () get_ffi_type_unsigned_short) +;(define-cproc get-ffi-type-int () get_ffi_type_int) +;(define-cproc get-ffi-type-unsigned-int () get_ffi_type_unsigned_int) +;(define-cproc get-ffi-type-long () get_ffi_type_long) +;(define-cproc get-ffi-type-unsigned-long () get_ffi_type_unsigned_long) +;(define-cproc get-ffi-type-float () get_ffi_type_float) +;(define-cproc get-ffi-type-double () get_ffi_type_double) +;(define-cproc get-ffi-type-void() get_ffi_type_void) +;(define-cproc get-ffi-type-pointer () get_ffi_type_pointer) + +;(define-cproc procedure-to-pointer (procedure) procedure_to_pointer) diff --git a/OLD/gauche-old/gauche-tmp/gauche-primitives.sci b/OLD/gauche-old/gauche-tmp/gauche-primitives.sci new file mode 100644 index 0000000..8bc7dd4 --- /dev/null +++ b/OLD/gauche-old/gauche-tmp/gauche-primitives.sci @@ -0,0 +1,6 @@ +;; generated automatically. DO NOT EDIT +#!no-fold-case +(define-module foreign.c.primitives.gauche (export size-of-type shared-object-load c-bytevector-u8-set! c-bytevector-u8-ref c-bytevector-pointer-set! c-bytevector-pointer-ref pointer-null? c-bytevector? c-free define-c-callback dlerror dlsym internal-ffi-call)) +(select-module foreign.c.primitives.gauche) +(dynamic-load "gauche-primitives.so") +(define-syntax define-c-callback (syntax-rules () ((_ scheme-name return-type argument-types procedure) (define scheme-name (make-c-callback return-type 'argument-types procedure))))) diff --git a/foreign/c/primitives/gauche.scm b/OLD/gauche-old/gauche-tmp/gauche-primitives.scm similarity index 98% rename from foreign/c/primitives/gauche.scm rename to OLD/gauche-old/gauche-tmp/gauche-primitives.scm index 24279f7..047d367 100644 --- a/foreign/c/primitives/gauche.scm +++ b/OLD/gauche-old/gauche-tmp/gauche-primitives.scm @@ -19,8 +19,8 @@ dlsym internal-ffi-call)) -(select-module foreign.c.primitives.gauche) -(dynamic-load "foreign/c/lib/gauche") +;(select-module foreign.c.primitives.gauche) +;(dynamic-load "foreign/c/gauche-primitives") (define size-of-type (lambda (type) diff --git a/OLD/gauche-old/gauche-tmp/gauche-primitives.sld b/OLD/gauche-old/gauche-tmp/gauche-primitives.sld new file mode 100644 index 0000000..fdfba51 --- /dev/null +++ b/OLD/gauche-old/gauche-tmp/gauche-primitives.sld @@ -0,0 +1,21 @@ +(define-library + (foreign c gauche-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (gauche base) + (foreign c primitives gauche)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (include "gauche-primitives.scm")) diff --git a/OLD/gauche-old/gauche-tmp/gauche-primitives.stub b/OLD/gauche-old/gauche-tmp/gauche-primitives.stub new file mode 100644 index 0000000..26d671d --- /dev/null +++ b/OLD/gauche-old/gauche-tmp/gauche-primitives.stub @@ -0,0 +1 @@ +(declcode "ScmObj size_of_int8() { return Scm_MakeInteger(sizeof(int8_t)); }") diff --git a/foreign/c/primitives/gauche/define-c-procedure.scm b/OLD/gauche-old/gauche/define-c-procedure.scm similarity index 100% rename from foreign/c/primitives/gauche/define-c-procedure.scm rename to OLD/gauche-old/gauche/define-c-procedure.scm diff --git a/OLD/gauche-old/gauche/foreign-c-gauche-primitives.c b/OLD/gauche-old/gauche/foreign-c-gauche-primitives.c new file mode 100644 index 0000000..87370ae --- /dev/null +++ b/OLD/gauche-old/gauche/foreign-c-gauche-primitives.c @@ -0,0 +1,835 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +void print_pointer(ScmObj obj, ScmPort* sink, ScmWriteContext* G1788 SCM_UNUSED) { + void* p = SCM_FOREIGN_POINTER_REF(void*, obj); + if(p == NULL) { + Scm_Printf(sink, "\n"); + } else { + Scm_Printf(sink, "\n", &p); + } +} + +ScmObj size_of_int8() { return Scm_MakeInteger(sizeof(int8_t)); } +ScmObj size_of_uint8() { return Scm_MakeInteger(sizeof(uint8_t)); } +ScmObj size_of_int16() { return Scm_MakeInteger(sizeof(int16_t)); } +ScmObj size_of_uint16() { return Scm_MakeInteger(sizeof(uint16_t)); } +ScmObj size_of_int32() { return Scm_MakeInteger(sizeof(int32_t)); } +ScmObj size_of_uint32() { return Scm_MakeInteger(sizeof(uint32_t)); } +ScmObj size_of_int64() { return Scm_MakeInteger(sizeof(int64_t)); } +ScmObj size_of_uint64() { return Scm_MakeInteger(sizeof(uint64_t)); } +ScmObj size_of_char() { return Scm_MakeInteger(sizeof(char)); } +ScmObj size_of_unsigned_char() { return Scm_MakeInteger(sizeof(unsigned char)); } +ScmObj size_of_short() { return Scm_MakeInteger(sizeof(short)); } +ScmObj size_of_unsigned_short() { return Scm_MakeInteger(sizeof(unsigned short)); } +ScmObj size_of_int() { return Scm_MakeInteger(sizeof(int)); } +ScmObj size_of_unsigned_int() { return Scm_MakeInteger(sizeof(unsigned int)); } +ScmObj size_of_long() { return Scm_MakeInteger(sizeof(long)); } +ScmObj size_of_unsigned_long() { return Scm_MakeInteger(sizeof(unsigned long)); } +ScmObj size_of_float() { return Scm_MakeInteger(sizeof(float)); } +ScmObj size_of_double() { return Scm_MakeInteger(sizeof(double)); } +ScmObj size_of_string() { return Scm_MakeInteger(sizeof(char*)); } +ScmObj size_of_pointer() { return Scm_MakeInteger(sizeof(void*)); } +ScmObj size_of_void() { return Scm_MakeInteger(sizeof(void)); } + +ScmObj align_of_int8() { return Scm_MakeInteger(_Alignof(int8_t)); } +ScmObj align_of_uint8() { return Scm_MakeInteger(_Alignof(uint8_t)); } +ScmObj align_of_int16() { return Scm_MakeInteger(_Alignof(int16_t)); } +ScmObj align_of_uint16() { return Scm_MakeInteger(_Alignof(uint16_t)); } +ScmObj align_of_int32() { return Scm_MakeInteger(_Alignof(int32_t)); } +ScmObj align_of_uint32() { return Scm_MakeInteger(_Alignof(uint32_t)); } +ScmObj align_of_int64() { return Scm_MakeInteger(_Alignof(int64_t)); } +ScmObj align_of_uint64() { return Scm_MakeInteger(_Alignof(uint64_t)); } +ScmObj align_of_char() { return Scm_MakeInteger(_Alignof(char)); } +ScmObj align_of_unsigned_char() { return Scm_MakeInteger(_Alignof(unsigned char)); } +ScmObj align_of_short() { return Scm_MakeInteger(_Alignof(short)); } +ScmObj align_of_unsigned_short() { return Scm_MakeInteger(_Alignof(unsigned short)); } +ScmObj align_of_int() { return Scm_MakeInteger(_Alignof(int)); } +ScmObj align_of_unsigned_int() { return Scm_MakeInteger(_Alignof(unsigned int)); } +ScmObj align_of_long() { return Scm_MakeInteger(_Alignof(long)); } +ScmObj align_of_unsigned_long() { return Scm_MakeInteger(_Alignof(unsigned long)); } +ScmObj align_of_float() { return Scm_MakeInteger(_Alignof(float)); } +ScmObj align_of_double() { return Scm_MakeInteger(_Alignof(double)); } +ScmObj align_of_string() { return Scm_MakeInteger(_Alignof(char*)); } +ScmObj align_of_pointer() { return Scm_MakeInteger(_Alignof(void*)); } +ScmObj align_of_void() { return Scm_MakeInteger(_Alignof(void)); } + +ScmModule* module = NULL; + +ScmObj shared_object_load(ScmString* path, ScmObj options) { + const ScmStringBody* body = SCM_STRING_BODY(path); + const char* c_path = SCM_STRING_BODY_START(body); + void* shared_object = dlopen(c_path, RTLD_NOW); + ScmClass* shared_object_class = Scm_MakeForeignPointerClass(module, "shared-object", print_pointer, NULL, 0); + ScmObj scm_shared_object = Scm_MakeForeignPointer(shared_object_class, shared_object); + return scm_shared_object; +} + +/* +ScmObj pointer_null() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + ScmObj pointer = Scm_MakeForeignPointer(pointer_class, NULL); + return pointer; +} +*/ + +ScmObj is_pointer_null(ScmObj pointer) { + if(!Scm_TypeP(pointer, SCM_CLASS_FOREIGN_POINTER)) { + return SCM_FALSE; + } + if(SCM_FOREIGN_POINTER_REF(void*, pointer) == NULL) { + return SCM_TRUE; + } else { + return SCM_FALSE; + } +} + +/* +ScmObj pointer_allocate(int size) { + void* p = malloc(size); + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + ScmObj pointer = Scm_MakeForeignPointer(pointer_class, p); + return pointer; +} +*/ + +/* +ScmObj pointer_address(ScmObj pointer) { + if(!Scm_TypeP(pointer, SCM_CLASS_FOREIGN_POINTER)) { + Scm_Error("Can only get pointer address of a pointer"); + return SCM_UNDEFINED; + } + void* p = SCM_FOREIGN_POINTER_REF(void*, p); + //ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + //ScmObj address = Scm_MakeForeignPointer(pointer_class, p); + printf("HERE: %u", (uint64_t)&p); + return SCM_MAKE_INT((uint64_t)&p); +} +*/ + +ScmObj is_pointer(ScmObj pointer) { + if(Scm_TypeP(pointer, SCM_CLASS_FOREIGN_POINTER)) { + return SCM_TRUE; + } else { + return SCM_FALSE; + } +} + +/* +ScmObj pointer_free(ScmObj pointer) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + free(SCM_FOREIGN_POINTER_REF(void*, pointer)); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_int8(ScmObj pointer, int offset, int8_t value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(int8_t*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} +*/ + +ScmObj pointer_set_uint8(ScmObj pointer, int offset, uint8_t value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(uint8_t*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +/* +ScmObj pointer_set_int16(ScmObj pointer, int offset, int16_t value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(int16_t*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_uint16(ScmObj pointer, int offset, uint16_t value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(uint16_t*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_int32(ScmObj pointer, int offset, int32_t value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(int32_t*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_uint32(ScmObj pointer, int offset, uint32_t value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(uint32_t*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_int64(ScmObj pointer, int offset, int64_t value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(int64_t*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_uint64(ScmObj pointer, int offset, uint64_t value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(uint64_t*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_char(ScmObj pointer, int offset, char value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(char*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_unsigned_char(ScmObj pointer, int offset, unsigned char value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(unsigned char*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_short(ScmObj pointer, int offset, short value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(short*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_unsigned_short(ScmObj pointer, int offset, unsigned short value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(unsigned short*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_int(ScmObj pointer, int offset, int value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(int*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_unsigned_int(ScmObj pointer, int offset, unsigned int value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(unsigned int*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_long(ScmObj pointer, int offset, long value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(long*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_unsigned_long(ScmObj pointer, int offset, unsigned long value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(unsigned long*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_float(ScmObj pointer, int offset, float value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(float*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_set_double(ScmObj pointer, int offset, double value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + *(double*)((char*)p + offset) = value; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +*/ + +ScmObj pointer_set_pointer(ScmObj pointer, int offset, ScmObj value) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* v = SCM_FOREIGN_POINTER_REF(void*, value); + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + char* p1 = (char*)p + offset; + *(char**)p1 = v; + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +/* + +ScmObj pointer_get_int8(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(int8_t*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} +*/ + +ScmObj pointer_get_uint8(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(uint8_t*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +/* +ScmObj pointer_get_int16(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(int16_t*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_uint16(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(uint16_t*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_int32(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(int32_t*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_uint32(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(uint32_t*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_int64(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(int64_t*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_uint64(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(uint64_t*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_char(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(char*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_unsigned_char(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(unsigned char*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_short(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(short*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_unsigned_short(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(unsigned short*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_int(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(int*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_unsigned_int(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(unsigned int*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_long(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(long*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_unsigned_long(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return SCM_MAKE_INT(*(unsigned long*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_float(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return Scm_MakeFlonum(*(float*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_get_double(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + return Scm_MakeFlonum(*(double*)((char*)p + offset)); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} +*/ + +ScmObj pointer_get_pointer(ScmObj pointer, int offset) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + char* p1 = (char*)p + offset; + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, (void*)*(char**)p1); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} + +/* + +ScmObj string_to_pointer(ScmObj string) { + if(SCM_STRINGP(string)) { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, Scm_GetString(SCM_STRING(string))); + } else { + Scm_Error("Not a string: %S", string); + } + return SCM_UNDEFINED; +} + +ScmObj pointer_to_string(ScmObj pointer) { + if(SCM_FOREIGN_POINTER_P(pointer)) { + void* p = SCM_FOREIGN_POINTER_REF(void*, pointer); + void* string = (char*)p; + return Scm_MakeString(string, -1, -1, 0); + } else { + Scm_Error("Not a pointer: %S", pointer); + } + return SCM_UNDEFINED; +} +*/ + +ScmObj internal_dlerror() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + void* msg = dlerror(); + if(msg == NULL) { + return Scm_MakeForeignPointer(pointer_class, NULL); + } else { + return Scm_MakeForeignPointer(pointer_class, msg); + } +} + +ScmObj internal_dlsym(ScmObj shared_object, ScmObj c_name) { + + if(!SCM_FOREIGN_POINTER_P(shared_object)) { + Scm_Error("Not a shared object: %S", shared_object); + return SCM_UNDEFINED; + } + + if(!SCM_STRINGP(c_name)) { + Scm_Error("Not a string: %S", c_name); + return SCM_UNDEFINED; + } + + void* handle = SCM_FOREIGN_POINTER_REF(void*, shared_object); + const ScmStringBody* body = SCM_STRING_BODY(c_name); + const char* name = SCM_STRING_BODY_START(body); + void* symbol = dlsym(handle, name); + + if(symbol == NULL) { + Scm_Error("Could not find function %S", c_name); + return SCM_UNDEFINED; + } + + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, symbol); +} + +ScmObj get_ffi_type_int8() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint8); +} + +ScmObj get_ffi_type_uint8() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint8); +} + +ScmObj get_ffi_type_int16() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint16); +} + +ScmObj get_ffi_type_uint16() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint16); +} + +ScmObj get_ffi_type_int32() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint32); +} + +ScmObj get_ffi_type_uint32() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint32); +} + +ScmObj get_ffi_type_int64() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint64); +} + +ScmObj get_ffi_type_uint64() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint64); +} + +ScmObj get_ffi_type_char() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_schar); +} + +ScmObj get_ffi_type_unsigned_char() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_uchar); +} + +ScmObj get_ffi_type_short() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_sshort); +} + +ScmObj get_ffi_type_unsigned_short() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_ushort); +} + +ScmObj get_ffi_type_int() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint); +} + +ScmObj get_ffi_type_unsigned_int() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint); +} + +ScmObj get_ffi_type_long() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_slong); +} + +ScmObj get_ffi_type_unsigned_long() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_ulong); +} + +ScmObj get_ffi_type_float() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_float); +} + +ScmObj get_ffi_type_double() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_double); +} + +ScmObj get_ffi_type_void() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_void); +} + +ScmObj get_ffi_type_pointer() { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, &ffi_type_pointer); +} + +ScmObj internal_ffi_call( + ScmObj nargs, + ScmObj rtype, + ScmObj atypes, + ScmObj fn, + ScmObj rvalue_size, + ScmObj avalues) + { + + ffi_cif cif; + + /* + unsigned int c_nargs = SCM_INT_VALUE(nargs); + ffi_type* c_rtype = SCM_FOREIGN_POINTER_REF(ffi_type*, rtype); + int atypes_length = (int)Scm_Length(atypes); + ffi_type* c_atypes[atypes_length]; + for(int i = 0; i < atypes_length; i++) { + switch(atypes[i]) { + } + //c_atypes[i] = SCM_FOREIGN_POINTER_REF(ffi_type*, Scm_ListRef(atypes, i, SCM_UNDEFINED)); + } + */ + + unsigned int c_nargs = SCM_INT_VALUE(nargs); + ffi_type* c_atypes[c_nargs]; + void* c_avalues[c_nargs]; + uint8_t vals2[c_nargs]; + uint64_t vals8[c_nargs]; + int vals13[c_nargs]; + void* vals20[c_nargs]; + + for(int i = 0; i < c_nargs; i++) { + ScmObj type = Scm_ListRef(atypes, i, SCM_UNDEFINED); + ScmObj value = Scm_ListRef(avalues, i, SCM_UNDEFINED); + switch(SCM_INT_VALUE(type)) { + //case 1: c_atypes[i] = &ffi_type_sint8; arg = sexp_sint_value(avalues[i]); break; + case 2: + c_atypes[i] = &ffi_type_uint8; + vals2[i] = (uint8_t)SCM_INT_VALUE(value); + c_avalues[i] = &vals2[i]; + break; + //case 3: c_atypes[i] = &ffi_type_sint16; arg = sexp_sint_value(avalues[i]); break; + //case 4: c_atypes[i] = &ffi_type_uint16; arg = sexp_uint_value(avalues[i]); break; + //case 5: c_atypes[i] = &ffi_type_sint32; arg = sexp_sint_value(avalues[i]); break; + //case 6: c_atypes[i] = &ffi_type_uint32; arg = sexp_uint_value(avalues[i]); break; + //case 7: c_atypes[i] = &ffi_type_sint64; arg = sexp_sint_value(avalues[i]); break; + case 8: + c_atypes[i] = &ffi_type_uint64; + vals8[i] = (uint64_t)SCM_INT_VALUE(value); + c_avalues[i] = &vals8[i]; + break; + //case 9: c_atypes[i] = &ffi_type_schar; arg = sexp_sint_value(avalues[i]); break; + //case 10: c_atypes[i] = &ffi_type_uchar; arg = sexp_uint_value(avalues[i]); break; + //case 11: c_atypes[i] = &ffi_type_sshort; arg = sexp_sint_value(avalues[i]); break; + //case 12: c_atypes[i] = &ffi_type_ushort; arg = sexp_uint_value(avalues[i]); break; + case 13: + c_atypes[i] = &ffi_type_sint; + vals13[i] = (int)SCM_INT_VALUE(value); + c_avalues[i] = &vals13[i]; + break; + //case 14: c_atypes[i] = &ffi_type_uint; arg = sexp_uint_value(avalues[i]); break; + //case 15: c_atypes[i] = &ffi_type_slong; arg = sexp_sint_value(avalues[i]); break; + //case 16: c_atypes[i] = &ffi_type_ulong; arg = sexp_uint_value(avalues[i]); break; + // FIXME + //case 17: c_atypes[i] = &ffi_type_float; arg = sexp_flonum_value(avalues[i]); break; + // FIXME + //case 18: c_atypes[i] = &ffi_type_double; arg = sexp_flonum_value(avalues[i]); break; + //case 19: c_atypes[i] = &ffi_type_void; arg = NULL; break; + case 20: + //printf("Argument value: %s\n", SCM_FOREIGN_POINTER_REF(char*, value)); + c_atypes[i] = &ffi_type_pointer; + vals20[i] = SCM_FOREIGN_POINTER_REF(void*, value); + c_avalues[i] = &vals20[i]; + //printf("Argument value1: %s\n", *(char**)c_avalues[i]); + //printf("Pointer value: %s\n", sexp_cpointer_maybe_null_value(avalues[i])); + break; + default: + //printf("Undefined argument type: %i, index: %i\n", SCM_INT_VALUE(type), i); + //c_avalues[i] = sexp_cpointer_value(avalues[i]); + break; + } + } + + ffi_type* c_rtype = &ffi_type_void; + switch(SCM_INT_VALUE(rtype)) { + case 1: c_rtype = &ffi_type_sint8; break; + case 2: c_rtype = &ffi_type_uint8; break; + case 3: c_rtype = &ffi_type_sint16; break; + case 4: c_rtype = &ffi_type_uint16; break; + case 5: c_rtype = &ffi_type_sint32; break; + case 6: c_rtype = &ffi_type_uint32; break; + case 7: c_rtype = &ffi_type_sint64; break; + case 8: c_rtype = &ffi_type_uint64; break; + case 9: c_rtype = &ffi_type_schar; break; + case 10: c_rtype = &ffi_type_uchar; break; + case 11: c_rtype = &ffi_type_sshort; break; + case 12: c_rtype = &ffi_type_ushort; break; + case 13: c_rtype = &ffi_type_sint; break; + case 14: c_rtype = &ffi_type_uint; break; + case 15: c_rtype = &ffi_type_slong; break; + case 16: c_rtype = &ffi_type_ulong; break; + case 17: c_rtype = &ffi_type_float; break; + case 18: c_rtype = &ffi_type_double; break; + case 19: c_rtype = &ffi_type_void; break; + case 20: c_rtype = &ffi_type_pointer; break; + default: + printf("Undefined return type: %i\n", SCM_INT_VALUE(rtype)); + c_rtype = &ffi_type_pointer; + break; + } + + int prep_status = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, c_nargs, c_rtype, c_atypes); + + void* c_fn = SCM_FOREIGN_POINTER_REF(void*, fn); + void* rvalue = malloc(SCM_INT_VALUE(rvalue_size)); //SCM_FOREIGN_POINTER_REF(void*, rvalue); + /* + int avalues_length = (int)Scm_Length(avalues); + void* c_avalues[avalues_length]; + for(int i = 0; i < avalues_length; i++) { + ScmObj item = Scm_ListRef(avalues, i, SCM_UNDEFINED); + void* pp = SCM_FOREIGN_POINTER_REF(void*, item); + char* list_p = (char*)c_avalues + (sizeof(void) * i); + c_avalues[i] = pp; + }*/ + ffi_call(&cif, FFI_FN(c_fn), rvalue, c_avalues); + + //printf("Return value: %s\n", (char*)rvalue); + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pointer", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, rvalue); +} + +ScmObj scheme_procedure_to_pointer(ScmObj procedure) { + ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "callback", print_pointer, NULL, 0); + return Scm_MakeForeignPointer(pointer_class, procedure); +} + +/* +ScmObj procedure_to_pointer(ScmObj procedure) { + + return SCM_UNDEFINED; +}*/ + +void Scm_Init_gauche(void) +{ + SCM_INIT_EXTENSION(foreign.c.primitives.gauche); + module = SCM_MODULE(SCM_FIND_MODULE("foreign.c.gauche.primitives", TRUE)); + Scm_Init_foreign_c_gauche_primitives(); +} diff --git a/OLD/gauche-old/gauche/foreign-c-gauche-primitives.h b/OLD/gauche-old/gauche/foreign-c-gauche-primitives.h new file mode 100644 index 0000000..d7b8119 --- /dev/null +++ b/OLD/gauche-old/gauche/foreign-c-gauche-primitives.h @@ -0,0 +1,108 @@ +extern ScmObj size_of_int8(); +extern ScmObj size_of_uint8(); +extern ScmObj size_of_int16(); +extern ScmObj size_of_uint16(); +extern ScmObj size_of_int32(); +extern ScmObj size_of_uint32(); +extern ScmObj size_of_int64(); +extern ScmObj size_of_uint64(); +extern ScmObj size_of_char(); +extern ScmObj size_of_unsigned_char(); +extern ScmObj size_of_short(); +extern ScmObj size_of_unsigned_short(); +extern ScmObj size_of_int(); +extern ScmObj size_of_unsigned_int(); +extern ScmObj size_of_long(); +extern ScmObj size_of_unsigned_long(); +extern ScmObj size_of_float(); +extern ScmObj size_of_double(); +extern ScmObj size_of_string(); +extern ScmObj size_of_pointer(); +extern ScmObj size_of_void(); + +extern ScmObj align_of_int8(); +extern ScmObj align_of_uint8(); +extern ScmObj align_of_int16(); +extern ScmObj align_of_uint16(); +extern ScmObj align_of_int32(); +extern ScmObj align_of_uint32(); +extern ScmObj align_of_int64(); +extern ScmObj align_of_uint64(); +extern ScmObj align_of_char(); +extern ScmObj align_of_unsigned_char(); +extern ScmObj align_of_short(); +extern ScmObj align_of_unsigned_short(); +extern ScmObj align_of_int(); +extern ScmObj align_of_unsigned_int(); +extern ScmObj align_of_long(); +extern ScmObj align_of_unsigned_long(); +extern ScmObj align_of_float(); +extern ScmObj align_of_double(); +extern ScmObj align_of_string(); +extern ScmObj align_of_pointer(); +extern ScmObj align_of_void(); + +extern ScmObj shared_object_load(ScmString* path, ScmObj options); +//extern ScmObj pointer_null(); +extern ScmObj is_pointer_null(ScmObj pointer); +//extern ScmObj pointer_allocate(int size); +//extern ScmObj pointer_address(ScmObj pointer); +extern ScmObj is_pointer(ScmObj pointer); +//extern ScmObj pointer_free(ScmObj pointer); + + +//extern ScmObj pointer_set_int8(ScmObj pointer, int offset, int8_t value); +extern ScmObj pointer_set_uint8(ScmObj pointer, int offset, uint8_t value); +extern ScmObj pointer_get_uint8(ScmObj pointer, int offset); +/* + * extern ScmObj pointer_set_int16(ScmObj pointer, int offset, int16_t value); + * extern ScmObj pointer_set_uint16(ScmObj pointer, int offset, uint16_t value); + * extern ScmObj pointer_set_int32(ScmObj pointer, int offset, int32_t value); + * extern ScmObj pointer_set_uint32(ScmObj pointer, int offset, uint32_t value); + * extern ScmObj pointer_set_int64(ScmObj pointer, int offset, int64_t value); + * extern ScmObj pointer_set_uint64(ScmObj pointer, int offset, uint64_t value); + * extern ScmObj pointer_set_char(ScmObj pointer, int offset, char value); + * extern ScmObj pointer_set_unsigned_char(ScmObj pointer, int offset, unsigned char value); + * extern ScmObj pointer_set_short(ScmObj pointer, int offset, short value); + * extern ScmObj pointer_set_unsigned_short(ScmObj pointer, int offset, unsigned short value); + * extern ScmObj pointer_set_int(ScmObj pointer, int offset, int value); + * extern ScmObj pointer_set_unsigned_int(ScmObj pointer, int offset, unsigned int value); + * extern ScmObj pointer_set_long(ScmObj pointer, int offset, long value); + * extern ScmObj pointer_set_unsigned_long(ScmObj pointer, int offset, unsigned long value); + * extern ScmObj pointer_set_float(ScmObj pointer, int offset, float value); + * extern ScmObj pointer_set_double(ScmObj pointer, int offset, double value); + * */ + +extern ScmObj pointer_set_pointer(ScmObj pointer, int offset, ScmObj value); +extern ScmObj pointer_get_pointer(ScmObj pointer, int offset); +//extern ScmObj string_to_pointer(ScmObj string); +//extern ScmObj pointer_to_string(ScmObj pointer); + +extern ScmObj internal_dlerror(); +extern ScmObj internal_dlsym(ScmObj shared_object, ScmObj c_name); +extern ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, ScmObj rvalue, ScmObj avalues); +extern ScmObj scheme_procedure_to_pointer(ScmObj procedure); + +extern ScmObj get_ffi_type_int8(); +extern ScmObj get_ffi_type_uint8(); +extern ScmObj get_ffi_type_int16(); +extern ScmObj get_ffi_type_uint16(); +extern ScmObj get_ffi_type_int32(); +extern ScmObj get_ffi_type_uint32(); +extern ScmObj get_ffi_type_int64(); +extern ScmObj get_ffi_type_uint64(); +extern ScmObj get_ffi_type_char(); +extern ScmObj get_ffi_type_unsigned_char(); +extern ScmObj get_ffi_type_short(); +extern ScmObj get_ffi_type_unsigned_short(); +extern ScmObj get_ffi_type_int(); +extern ScmObj get_ffi_type_unsigned_int(); +extern ScmObj get_ffi_type_long(); +extern ScmObj get_ffi_type_unsigned_long(); +extern ScmObj get_ffi_type_float(); +extern ScmObj get_ffi_type_double(); +extern ScmObj get_ffi_type_void(); +extern ScmObj get_ffi_type_pointer(); + +extern void Scm_Init_foreign_c_gauche_primitives(void); + diff --git a/foreign/c/primitives/gauche/gauchelib.scm b/OLD/gauche-old/gauche/gauchelib.scm similarity index 98% rename from foreign/c/primitives/gauche/gauchelib.scm rename to OLD/gauche-old/gauche/gauchelib.scm index 419ddd2..f88ec51 100644 --- a/foreign/c/primitives/gauche/gauchelib.scm +++ b/OLD/gauche-old/gauche/gauchelib.scm @@ -1,7 +1,7 @@ -(in-module foreign.c.primitives.gauche) +(in-module foreign.c.gauche.primitives) (inline-stub - (.include "foreign-c-primitives-gauche.h") + (.include "foreign-c-gauche-primitives.h") (define-cproc size-of-int8 () size_of_int8) (define-cproc size-of-uint8 () size_of_uint8) diff --git a/OLD/gauche-primitives.gauche.c b/OLD/gauche-primitives.gauche.c new file mode 100644 index 0000000..004a46a --- /dev/null +++ b/OLD/gauche-primitives.gauche.c @@ -0,0 +1,80 @@ +/* Generated by genstub. Do not edit. */ +#include +#include +#include +void Scm_Init_gauche_primitives_gauche(void) { puts("Hello from init"); } +extern ScmObj hello() { return Scm_MakeInteger(1); } +static ScmObj gauche_primitives_2egauche_hello(ScmObj*, int, void*); +static SCM_DEFINE_SUBRX(gauche_primitives_2egauche_hello__STUB, 0, 0,0, SCM_FALSE,SCM_SUBR_IMMEDIATE_ARG, gauche_primitives_2egauche_hello, NULL, NULL); + +#if defined(__CYGWIN__) || defined(GAUCHE_WINDOWS) +#define SCM_CGEN_CONST /*empty*/ +#else +#define SCM_CGEN_CONST const +#endif +static SCM_CGEN_CONST struct scm__scRec { + ScmString d2840[5]; +} scm__sc SCM_UNUSED = { + { /* ScmString d2840 */ + SCM_STRING_CONST_INITIALIZER("hello", 5, 5), + SCM_STRING_CONST_INITIALIZER("source-info", 11, 11), + SCM_STRING_CONST_INITIALIZER("foreign/c/gauche-primitives.gauche.stub", 39, 39), + SCM_STRING_CONST_INITIALIZER("->", 2, 2), + SCM_STRING_CONST_INITIALIZER("", 5, 5), + }, +}; +static struct scm__rcRec { + ScmPair d2852[5] SCM_ALIGN_PAIR; + ScmObj d2851[11]; +} scm__rc SCM_UNUSED = { + { /* ScmPair d2852 */ + { SCM_NIL, SCM_NIL }, + { SCM_MAKE_INT(8U), SCM_NIL}, + { SCM_OBJ(&scm__sc.d2840[2]), SCM_OBJ(&scm__rc.d2852[1])}, + { SCM_UNDEFINED, SCM_OBJ(&scm__rc.d2852[2])}, + { SCM_OBJ(&scm__rc.d2852[3]), SCM_NIL}, + }, + { /* ScmObj d2851 */ + SCM_UNBOUND, + SCM_UNBOUND, + SCM_UNBOUND, + SCM_UNBOUND, + SCM_UNBOUND, + SCM_OBJ(SCM_CLASS_STATIC_TAG(Scm_VectorClass)) /* */, + SCM_VECTOR_SIZE_SLOT_INITIALIZER(4, FALSE), + SCM_MAKE_INT(1U), + SCM_FALSE, + SCM_UNDEFINED, + SCM_UNDEFINED, + }, +}; + +static ScmObj gauche_primitives_2egauche_hello(ScmObj *SCM_FP SCM_UNUSED, int SCM_ARGCNT SCM_UNUSED, void *data_ SCM_UNUSED) +{ + SCM_ENTER_SUBR("hello"); + { +{ +ScmObj SCM_RESULT; +{SCM_RESULT=(hello());goto SCM_STUB_RETURN;} +goto SCM_STUB_RETURN; +SCM_STUB_RETURN: +SCM_RETURN(SCM_OBJ_SAFE(SCM_RESULT)); +} + } +} + +void Scm_Init_gauche_primitives_2egauche(ScmModule *mod SCM_UNUSED){ + + scm__rc.d2851[0] = Scm_MakeSymbol(SCM_STRING(SCM_OBJ(&scm__sc.d2840[0])),TRUE); /* hello */ + scm__rc.d2851[1] = Scm_MakeSymbol(SCM_STRING(SCM_OBJ(&scm__sc.d2840[1])),TRUE); /* source-info */ + SCM_SET_CAR(SCM_OBJ(&scm__rc.d2852[3]), scm__rc.d2851[1]); + scm__rc.d2851[2] = Scm_MakeExtendedPair(scm__rc.d2851[0], SCM_NIL, SCM_OBJ(&scm__rc.d2852[4])); + scm__rc.d2851[3] = Scm_MakeSymbol(SCM_STRING(SCM_OBJ(&scm__sc.d2840[3])),TRUE); /* -> */ + scm__rc.d2851[4] = Scm_MakeSymbol(SCM_STRING(SCM_OBJ(&scm__sc.d2840[4])),TRUE); /* */ + ((ScmObj*)SCM_OBJ(&scm__rc.d2851[5]))[4] = scm__rc.d2851[3]; + ((ScmObj*)SCM_OBJ(&scm__rc.d2851[5]))[5] = scm__rc.d2851[4]; + Scm_MakeBinding(SCM_MODULE(mod), SCM_SYMBOL(SCM_INTERN("hello")), SCM_OBJ(&gauche_primitives_2egauche_hello__STUB), 0); + gauche_primitives_2egauche_hello__STUB.common.info = scm__rc.d2851[2]; + gauche_primitives_2egauche_hello__STUB.common.typeHint = SCM_OBJ(&scm__rc.d2851[5]); + SCM_VECTOR_ELEMENT(SCM_OBJ(&scm__rc.d2851[5]), 1) = SCM_MODULE(mod)->name; +} diff --git a/tests/hello.scm b/OLD/hello.scm similarity index 100% rename from tests/hello.scm rename to OLD/hello.scm diff --git a/foreign/c/internal.scm b/OLD/internal.scm similarity index 100% rename from foreign/c/internal.scm rename to OLD/internal.scm diff --git a/foreign/c/libc.scm b/OLD/libc.scm similarity index 100% rename from foreign/c/libc.scm rename to OLD/libc.scm diff --git a/foreign/c/main.scm b/OLD/main.scm similarity index 97% rename from foreign/c/main.scm rename to OLD/main.scm index 2789e20..86a25dc 100644 --- a/foreign/c/main.scm +++ b/OLD/main.scm @@ -25,7 +25,13 @@ (cond-expand (gambit #t) ; Defined in gambit.scm - (chicken #t) ; Defined in chicken.scm + (chicken + (define-syntax define-c-library + (syntax-rules () + ((_ scheme-name headers object-name options) + (begin + (define scheme-name #t) + (shared-object-load headers)))))) (cyclone #t) ; Defined in cyclone.scm (else (define-syntax define-c-library diff --git a/OLD/mit-scheme-foreign-c-const b/OLD/mit-scheme-foreign-c-const new file mode 100755 index 0000000..0e68feb Binary files /dev/null and b/OLD/mit-scheme-foreign-c-const differ diff --git a/OLD/mit-scheme-foreign-c-const.c b/OLD/mit-scheme-foreign-c-const.c new file mode 100644 index 0000000..db7c7f7 --- /dev/null +++ b/OLD/mit-scheme-foreign-c-const.c @@ -0,0 +1,51 @@ +/* -*-C-*- */ + +/* Prefix */ +#include +#include +/* End Prefix */ + +#include + +void +grovel_basics (FILE * out) +{ + fprintf (out, " ((sizeof char) . %ld)\n", (long) sizeof (char)); + fprintf (out, " ((sizeof uchar) . %ld)\n", (long) sizeof (unsigned char)); + fprintf (out, " ((sizeof short) . %ld)\n", (long) sizeof (short)); + fprintf (out, " ((sizeof ushort) . %ld)\n", (long) sizeof (unsigned short)); + fprintf (out, " ((sizeof int) . %ld)\n", (long) sizeof (int)); + fprintf (out, " ((sizeof uint) . %ld)\n", (long) sizeof (unsigned int)); + fprintf (out, " ((sizeof long) . %ld)\n", (long) sizeof (long)); + fprintf (out, " ((sizeof ulong) . %ld)\n", (long) sizeof (unsigned long)); + fprintf (out, " ((sizeof float) . %ld)\n", (long) sizeof (float)); + fprintf (out, " ((sizeof double) . %ld)\n", (long) sizeof (double)); + fprintf (out, " ((sizeof *) . %ld)\n", (long) sizeof (void*)); +} + +void +grovel_enums (FILE * out) +{ +} + +int +main (void) +{ + FILE * out = fopen ("mit-scheme-foreign-c-const.scm", "w"); + if (out == NULL) { + perror ("could not open mit-scheme-foreign-c-const.scm"); + return 1; + } + fprintf (out, "'( ;; mit-scheme-foreign-c constants\n"); + fprintf (out, " ( ;; enum member values\n"); + grovel_enums(out); + fprintf (out, " )\n"); + fprintf (out, " ( ;; struct values\n"); + grovel_basics(out); + fprintf (out, " ))\n"); + if (fclose (out)) { + perror ("could not close mit-scheme-foreign-c-const.scm"); + return 1; + } + return 0; +} diff --git a/OLD/mit-scheme-foreign-c-const.scm b/OLD/mit-scheme-foreign-c-const.scm new file mode 100644 index 0000000..4671e4c --- /dev/null +++ b/OLD/mit-scheme-foreign-c-const.scm @@ -0,0 +1,16 @@ +'( ;; mit-scheme-foreign-c constants + ( ;; enum member values + ) + ( ;; struct values + ((sizeof char) . 1) + ((sizeof uchar) . 1) + ((sizeof short) . 2) + ((sizeof ushort) . 2) + ((sizeof int) . 4) + ((sizeof uint) . 4) + ((sizeof long) . 8) + ((sizeof ulong) . 8) + ((sizeof float) . 4) + ((sizeof double) . 8) + ((sizeof *) . 8) + )) diff --git a/OLD/mit-scheme-foreign-c-shim.c b/OLD/mit-scheme-foreign-c-shim.c new file mode 100644 index 0000000..438efec --- /dev/null +++ b/OLD/mit-scheme-foreign-c-shim.c @@ -0,0 +1,47 @@ +/* -*-C-*- */ + +#include + +/* Prefix */ +#include +#include +/* End Prefix */ + +SCM +Scm_continue_puts (void) +{ + /* Declare. */ + char * tos0; + int ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_puts); + CSTACK_LPOP (int, ret0, tos0); + + /* Return. */ + ret0s = long_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +SCM +Scm_puts (void) +{ + /* Declare. */ + int ret0; + char * s; + + /* Init. */ + check_number_of_args (2); + s = (char *) arg_pointer (2); + + /* Call. */ + callout_seal (&Scm_continue_puts); + ret0 = puts (s); + + /* Save. */ + callout_unseal (&Scm_continue_puts); + CSTACK_PUSH (int, ret0); + + return callout_continue (&Scm_continue_puts); +} diff --git a/tests/old-all.scm b/OLD/old-all.scm similarity index 100% rename from tests/old-all.scm rename to OLD/old-all.scm diff --git a/package.scm b/OLD/package.scm similarity index 100% rename from package.scm rename to OLD/package.scm diff --git a/foreign/c/pointer.scm b/OLD/pointer.scm similarity index 88% rename from foreign/c/pointer.scm rename to OLD/pointer.scm index 80296a2..1a1edff 100644 --- a/foreign/c/pointer.scm +++ b/OLD/pointer.scm @@ -3,7 +3,7 @@ libc-name '((additional-versions ("0" "6")))) -(define-c-procedure c-calloc libc 'calloc 'pointer '(int int)) +;(define-c-procedure c-calloc libc 'calloc 'pointer '(int int)) (cond-expand (gambit (define c-memset-address->pointer @@ -87,8 +87,16 @@ (string->utf8 (string-append string-var (string #\null)))))) (cond-expand - (chicken #t) ; FIXME - (kawa #t) ; FIXME + ;; FIXME + (chicken + (define make-c-null + (lambda () + (address->pointer 0)))) + ;; FIXME + (kawa + (define make-c-null + (lambda () + (static-field java.lang.foreign.MemorySegment 'NULL)))) ;(chibi #t) (else (define make-c-null (lambda () @@ -98,8 +106,20 @@ (else (c-memset-address->pointer 0 0 0))))))) (cond-expand - (chicken #t) ; FIXME - (kawa #t) ; FIXME + ;; FIXME + (chicken + (define c-null? + (lambda (pointer) + (if (and (not (pointer? pointer)) + pointer) + #f + (or (not pointer) ; #f counts as null pointer on Chicken + (= (pointer->address pointer) 0)))))) + ;; FIXME + (kawa + (define c-null? + (lambda (pointer) + (invoke pointer 'equals null-pointer)))) (chibi #t) (gauche (define c-null? pointer-null?)) (stklos (define c-null? diff --git a/foreign/c/primitives/chibi/foreign-c.stub b/OLD/primitives/chibi/foreign-c.stub similarity index 100% rename from foreign/c/primitives/chibi/foreign-c.stub rename to OLD/primitives/chibi/foreign-c.stub diff --git a/foreign/c/primitives/guile.scm b/OLD/primitives/guile.scm similarity index 100% rename from foreign/c/primitives/guile.scm rename to OLD/primitives/guile.scm diff --git a/foreign/c/primitives/kawa.scm b/OLD/primitives/kawa.scm similarity index 100% rename from foreign/c/primitives/kawa.scm rename to OLD/primitives/kawa.scm diff --git a/foreign/c/primitives/larceny-util.scm b/OLD/primitives/larceny-util.scm similarity index 100% rename from foreign/c/primitives/larceny-util.scm rename to OLD/primitives/larceny-util.scm diff --git a/foreign/c/primitives/larceny.scm b/OLD/primitives/larceny.scm similarity index 100% rename from foreign/c/primitives/larceny.scm rename to OLD/primitives/larceny.scm diff --git a/OLD/primitives/mit-scheme.scm b/OLD/primitives/mit-scheme.scm new file mode 100644 index 0000000..3d336a8 --- /dev/null +++ b/OLD/primitives/mit-scheme.scm @@ -0,0 +1,12 @@ +(declare (usual-integrations)) +(load-option 'ffi) + +;(define lib (dld-load-file "mit-scheme-foreign-c-shim.so")) +(C-include "mit-scheme-foreign-c") + +(define (hello) + (puts "Hello from puts") + ;(display "Not from puts") + (newline) + ) +;(C-call "puts" "Hello world") diff --git a/foreign/c/primitives/mosh.scm b/OLD/primitives/mosh.scm similarity index 100% rename from foreign/c/primitives/mosh.scm rename to OLD/primitives/mosh.scm diff --git a/foreign/c/primitives/racket.scm b/OLD/primitives/racket.scm similarity index 100% rename from foreign/c/primitives/racket.scm rename to OLD/primitives/racket.scm diff --git a/foreign/c/primitives/sagittarius.scm b/OLD/primitives/sagittarius.scm similarity index 100% rename from foreign/c/primitives/sagittarius.scm rename to OLD/primitives/sagittarius.scm diff --git a/foreign/c/primitives/skint.scm b/OLD/primitives/skint.scm similarity index 100% rename from foreign/c/primitives/skint.scm rename to OLD/primitives/skint.scm diff --git a/foreign/c/primitives/stklos.scm b/OLD/primitives/stklos.scm similarity index 100% rename from foreign/c/primitives/stklos.scm rename to OLD/primitives/stklos.scm diff --git a/foreign/c/primitives/tr7.scm b/OLD/primitives/tr7.scm similarity index 100% rename from foreign/c/primitives/tr7.scm rename to OLD/primitives/tr7.scm diff --git a/foreign/c/primitives/ypsilon.scm b/OLD/primitives/ypsilon.scm similarity index 100% rename from foreign/c/primitives/ypsilon.scm rename to OLD/primitives/ypsilon.scm diff --git a/templates/css/pdf-documentation.css b/OLD/templates/css/pdf-documentation.css similarity index 100% rename from templates/css/pdf-documentation.css rename to OLD/templates/css/pdf-documentation.css diff --git a/templates/documentation.html b/OLD/templates/documentation.html similarity index 100% rename from templates/documentation.html rename to OLD/templates/documentation.html diff --git a/documentation/foreign-c.pdf b/documentation/foreign-c.pdf deleted file mode 100644 index c0af255..0000000 Binary files a/documentation/foreign-c.pdf and /dev/null differ diff --git a/foreign/c.scm b/foreign/c.scm new file mode 100644 index 0000000..945a6a8 --- /dev/null +++ b/foreign/c.scm @@ -0,0 +1,366 @@ +(define c-type-signed? + (lambda (type) + (if (member type '(int8 int16 int32 int64 char short int long float double)) + #t + #f))) + +(define c-type-unsigned? + (lambda (type) + (if (member type '(uint8 uint16 uint32 uint64 unsigned-char unsigned-short unsigned-int unsigned-long)) + #t + #f))) + +(define c-type-size + (lambda (type) + (size-of-type type))) + +(define c-type-align + (lambda (type) + (align-of-type type))) + +(define foreign-c:string-split + (lambda (str mark) + (let* ((str-l (string->list str)) + (res (list)) + (last-index 0) + (index 0) + (splitter (lambda (c) + (cond ((char=? c mark) + (begin + (set! res (append res (list (string-copy str last-index index)))) + (set! last-index (+ index 1)))) + ((equal? (length str-l) (+ index 1)) + (set! res (append res (list (string-copy str last-index (+ index 1))))))) + (set! index (+ index 1))))) + (for-each splitter str-l) + res))) + +(cond-expand + (gambit #t) ; Defined in gambit.scm + (chicken + (define-syntax define-c-library + (syntax-rules () + ((_ scheme-name headers object-name options) + (begin + (define scheme-name #t) + (shared-object-load headers)))))) + (cyclone #t) ; Defined in cyclone.scm + (else + (define-syntax define-c-library + (syntax-rules () + ((_ scheme-name headers object-name options) + (define scheme-name + (let* ((internal-options (if (null? 'options) + (list) + (cadr 'options))) + (additional-paths (if (assoc 'additional-paths internal-options) + (cadr (assoc 'additional-paths internal-options)) + (list))) + (additional-versions (if (assoc 'additional-versions internal-options) + (map (lambda (version) + (if (number? version) + (number->string version) + version)) + (cadr (assoc 'additional-versions internal-options))) + (list))) + (slash (cond-expand (windows (string #\\)) (else "/"))) + (auto-load-paths + (cond-expand + (windows + (append + (if (get-environment-variable "FOREIGN_C_LOAD_PATH") + (foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\;) + (list)) + (if (get-environment-variable "SYSTEM") + (list (get-environment-variable "SYSTEM")) + (list)) + (if (get-environment-variable "WINDIR") + (list (get-environment-variable "WINDIR")) + (list)) + (if (get-environment-variable "WINEDLLDIR0") + (list (get-environment-variable "WINEDLLDIR0")) + (list)) + (if (get-environment-variable "SystemRoot") + (list (string-append + (get-environment-variable "SystemRoot") + slash + "system32")) + (list)) + (list ".") + (if (get-environment-variable "PATH") + (foreign-c:string-split (get-environment-variable "PATH") #\;) + (list)) + (if (get-environment-variable "PWD") + (list (get-environment-variable "PWD")) + (list)))) + (else + (append + (if (get-environment-variable "FOREIGN_C_LOAD_PATH") + (foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\:) + (list)) + ; Guix + (list (if (get-environment-variable "GUIX_ENVIRONMENT") + (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") + "") + "/run/current-system/profile/lib") + ; Debian + (if (get-environment-variable "LD_LIBRARY_PATH") + (foreign-c:string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) + (list)) + (list + ;;; x86-64 + ; Debian + "/lib/x86_64-linux-gnu" + "/usr/lib/x86_64-linux-gnu" + "/usr/local/lib" + ; Fedora/Alpine + "/usr/lib" + "/usr/lib64" + ;;; aarch64 + ; Debian + "/lib/aarch64-linux-gnu" + "/usr/lib/aarch64-linux-gnu" + "/usr/local/lib" + ; Fedora/Alpine + "/usr/lib" + "/usr/lib64" + ; NetBSD + "/usr/pkg/lib" + ; Haiku + "/boot/system/lib"))))) + (auto-load-versions (list "")) + (paths (append auto-load-paths additional-paths)) + (versions (append additional-versions auto-load-versions)) + (platform-lib-prefix (cond-expand (windows "") (else "lib"))) + (platform-file-extension (cond-expand (windows ".dll") (else ".so"))) + (shared-object #f) + (searched-paths (list))) + (for-each + (lambda (path) + (for-each + (lambda (version) + (let ((library-path + (string-append path + slash + platform-lib-prefix + object-name + (cond-expand + (windows "") + (else platform-file-extension)) + (if (string=? version "") + "" + (string-append + (cond-expand (windows "-") + (else ".")) + version)) + (cond-expand + (windows platform-file-extension) + (else "")))) + (library-path-without-suffixes (string-append path + slash + platform-lib-prefix + object-name))) + (set! searched-paths (append searched-paths (list library-path))) + (when (and (not shared-object) + (file-exists? library-path)) + (set! shared-object + (cond-expand (racket library-path-without-suffixes) + (else library-path)))))) + versions)) + paths) + (if (not shared-object) + (begin + (display "Could not load shared object: ") + (write (list (cons 'object object-name) + (cons 'paths paths) + (cons 'platform-file-extension platform-file-extension) + (cons 'versions versions))) + (newline) + (display "Searched paths: ") + (write searched-paths) + (newline) + (exit 1)) + (cond-expand + (stklos shared-object) + (else (shared-object-load shared-object + `((additional-versions ,additional-versions))))))))))))) + +(cond-expand + (windows + (define libc-name "ucrtbase")) + (else + (define libc-name + (cond ((get-environment-variable "BE_HOST_CPU") "root") ; Haiku + (else "c"))))) + + +(define-c-library libc + '("stdlib.h" "stdio.h" "string.h") + libc-name + '((additional-versions ("0" "6")))) + +;(define-c-procedure c-calloc libc 'calloc 'pointer '(int int)) +(cond-expand + (gambit + (define c-memset-address->pointer + (c-lambda (unsigned-int64 unsigned-int8 int) + (pointer void) + "___return(memset((void*)___arg1, ___arg2, ___arg3));"))) + (chicken + (define c-memset-address->pointer + (lambda (address value offset) + (address->pointer address)))) + (else + (define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int)))) + +(cond-expand + (gambit + (define c-memset-pointer->address + (c-lambda ((pointer void) unsigned-int8 int) + unsigned-int64 + "___return((uint64_t)memset(___arg1, ___arg2, ___arg3));"))) + (chicken (define c-memset-pointer->address + (lambda (pointer value offset) + (pointer->address pointer)))) + (else (define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int)))) +;(define-c-procedure c-memset-address libc 'memset 'pointer '(uint64 uint8 int)) +;(define-c-procedure c-printf libc 'printf 'int '(pointer pointer)) +(define-c-procedure c-malloc libc 'malloc 'pointer '(int)) +(define-c-procedure c-strlen libc 'strlen 'int '(pointer)) + +(define make-c-bytevector + (lambda (k . byte) + (if (null? byte) + (c-malloc k) + (bytevector->c-bytevector (make-bytevector k (car byte)))))) + +(define c-bytevector + (lambda bytes + (bytevector->c-bytevector (apply bytevector bytes)))) + +(cond-expand + (else (define-c-procedure c-free libc 'free 'void '(pointer)))) + +(define bytevector->c-bytevector + (lambda (bytes) + (letrec* ((bytes-length (bytevector-length bytes)) + (pointer (make-c-bytevector bytes-length)) + (looper (lambda (index) + (when (< index bytes-length) + (c-bytevector-u8-set! pointer + index + (bytevector-u8-ref bytes index)) + (looper (+ index 1)))))) + (looper 0) + pointer))) + +(define c-bytevector->bytevector + (lambda (pointer size) + (letrec* ((bytes (make-bytevector size)) + (looper (lambda (index) + (let ((byte (c-bytevector-u8-ref pointer index))) + (if (= index size) + bytes + (begin + (bytevector-u8-set! bytes index byte) + (looper (+ index 1)))))))) + (looper 0)))) + +(define c-string-length + (lambda (bytevector-var) + (c-strlen bytevector-var))) + +(define c-utf8->string + (lambda (c-bytevector) + (when (c-null? c-bytevector) + (error "Can not turn null pointer into string" c-bytevector)) + (let ((size (c-strlen c-bytevector))) + (utf8->string (c-bytevector->bytevector c-bytevector size))))) + +(define string->c-utf8 + (lambda (string-var) + (bytevector->c-bytevector + (string->utf8 (string-append string-var (string #\null)))))) + +(cond-expand + ;; FIXME + (chicken + (define make-c-null + (lambda () + (address->pointer 0)))) + ;; FIXME + (kawa + (define make-c-null + (lambda () + (static-field java.lang.foreign.MemorySegment 'NULL)))) + ;(chibi #t) + (else (define make-c-null + (lambda () + (cond-expand (stklos (let ((pointer (make-c-bytevector 1))) + (free-bytes pointer) + pointer)) + (else (c-memset-address->pointer 0 0 0))))))) + +(cond-expand + ;; FIXME + (chicken + (define c-null? + (lambda (pointer) + (if (and (not (pointer? pointer)) + pointer) + #f + (or (not pointer) ; #f counts as null pointer on Chicken + (= (pointer->address pointer) 0)))))) + ;; FIXME + (kawa + (define c-null? + (lambda (pointer) + (invoke pointer 'equals null-pointer)))) + ;; FIXME + (chibi #t) ;; In chibi-primitives.stub + (gauche (define c-null? pointer-null?)) + (stklos (define c-null? + (lambda (pointer) + (cond ((void? pointer) #t) + ((= (c-memset-pointer->address pointer 0 0) 0) #t) + (else #f))))) + (else (define c-null? + (lambda (pointer) + (if (c-bytevector? pointer) + (= (c-memset-pointer->address pointer 0 0) 0) + #f))))) + +(define c-bytevector->address + (lambda (c-bytevector) + (c-memset-pointer->address c-bytevector 0 0))) + +(define address->c-bytevector + (lambda (address) + (c-memset-address->pointer address 0 0))) + +#;(define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (c-bytevector-uint-set! c-bytevector + 0 + (c-bytevector->address pointer) + (native-endianness) + (c-type-size 'pointer)))) + +#;(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (address->c-bytevector (c-bytevector-uint-ref c-bytevector + 0 + (native-endianness) + (c-type-size 'pointer))))) + +(cond-expand + ;(kawa #t) ; Defined in kawa.scm + (else (define-syntax call-with-address-of + (syntax-rules () + ((_ input-pointer thunk) + (let ((address-pointer (make-c-bytevector (c-type-size 'pointer)))) + (c-bytevector-pointer-set! address-pointer 0 input-pointer) + (let ((result (apply thunk (list address-pointer)))) + (set! input-pointer (c-bytevector-pointer-ref address-pointer 0)) + (c-free address-pointer) + result))))))) diff --git a/foreign/c.sld b/foreign/c.sld index 3935c40..4b2ff57 100644 --- a/foreign/c.sld +++ b/foreign/c.sld @@ -1,184 +1,30 @@ (define-library (foreign c) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (scheme inexact)) (cond-expand - (chibi - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme process-context) - (chibi ast) - (scheme inexact) - (chibi)) - (include-shared "c/primitives/chibi/foreign-c")) - (chicken - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (chicken base) - (chicken foreign) - (chicken locative) - (chicken syntax) - (chicken memory) - (chicken random))) - #;(cyclone - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (cyclone foreign) - (scheme cyclone primitives))) - (gambit - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (only (gambit) c-declare c-lambda c-define define-macro))) - (gauche - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (gauche base) - (foreign c primitives gauche))) - (guile - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (system foreign) - (system foreign-library) - ;(only (guile) include-from-path) - #;(only (rnrs bytevectors) - bytevector-int8-set! - bytevector-uint-ref))) - (kawa - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context))) - (mit-scheme - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context))) - #;(larceny - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (rename (primitives r5rs:require) (r5rs:require require)) - (primitives std-ffi) - (primitives foreign-procedure) - (primitives foreign-file) - (primitives foreign-stdlib) - (primitives system-interface))) - (mosh - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme inexact) - (scheme process-context) - (mosh ffi))) - (racket - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (only (racket base) - system-type - system-big-endian?) - (ffi winapi) - (compatibility mlist) - (ffi unsafe) - (ffi vector))) - (sagittarius - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (except (sagittarius ffi) c-free c-malloc define-c-struct) - (sagittarius))) - #;(skint - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context))) - (stklos - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (only (stklos) - %make-callback - make-external-function - allocate-bytes - free-bytes - cpointer? - cpointer-null? - cpointer-data - cpointer-data-set! - cpointer-set-abs! - cpointer-ref-abs - c-size-of - void?)) - (export ; calculate-struct-size-and-offsets - ;struct-make - get-environment-variable - file-exists? - make-external-function - address->c-bytevector - foreign-c:string-split - c-bytevector-pointer-set! - c-bytevector-pointer-ref)) - #;(tr7 - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - ;(scheme inexact) - (scheme process-context))) - (ypsilon - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (ypsilon c-ffi) - (ypsilon c-types) - (only (core) - define-macro - syntax-case - bytevector-c-int8-set! - bytevector-c-uint8-ref)))) + (chibi (import (foreign c chibi-primitives))) + (chicken (import ;(chicken memory) ;; FIXME + (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))) + ;(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)) + ) (export ;;;; Primitives 1 c-type-size c-type-align @@ -284,53 +130,8 @@ ;c-utf8-length ;; TODO ?? - ;; c-array - make-c-array - c-array-ref - c-array-set! - list->c-array - c-array->list - - ;; c-struct - define-c-struct - c-struct->alist - ;pffi-define-struct;define-c-struct - ;pffi-struct-pointer;c-struct-bytevector - ;pffi-struct-offset-get;c-struct-offset - ;pffi-struct-set!;c-struct-set! - ;pffi-struct-get;c-struct-get - - ;; c-variable ;define-c-variable (?) ) - (include "c/internal.scm") - (cond-expand - (chibi (include "c/primitives/chibi.scm")) - (chicken (export foreign-declare foreign-safe-lambda void) - (include "c/primitives/chicken.scm")) - ;(cyclone (include "c/primitives/cyclone.scm")) - (gambit (include "c/primitives/gambit.scm")) - (gauche (include "c/primitives/gauche/define-c-procedure.scm")) - (guile (include "./c/primitives/guile.scm")) - (kawa (include "c/primitives/kawa.scm")) - (mit-scheme (include "c/primitives/mit-scheme.scm")) - ;(larceny (include "c/primitives/larceny.scm")) - (mosh (include "c/primitives/mosh.scm")) - (racket (include "c/primitives/racket.scm")) - (sagittarius (include "c/primitives/sagittarius.scm")) - ;(skint (include "c/primitives/skint.scm")) - (stklos (include "c/primitives/stklos.scm")) - ;(tr7 (include "c/primitives/tr7.scm")) - (ypsilon (export c-function - c-callback - bytevector-c-int8-set! - bytevector-c-uint8-ref) - (include "c/primitives/ypsilon.scm"))) - (include "c/c-types.scm") - (include "c/main.scm") - (include "c/libc.scm") - (include "c/c-bytevectors.scm") - (include "c/pointer.scm") - (include "c/array.scm") - (include "c/struct.scm")) + (include "c/c-bytevectors.scm") + (include "c.scm")) diff --git a/foreign/c/Makefile b/foreign/c/Makefile deleted file mode 100644 index fdeb98e..0000000 --- a/foreign/c/Makefile +++ /dev/null @@ -1,66 +0,0 @@ -CC=gcc - -chibi: foreign/c/primitives/chibi/foreign-c.stub - chibi-ffi foreign/c/primitives/chibi/foreign-c.stub - ${CC} \ - -g3 \ - -o foreign/c/primitives/chibi/foreign-c.so \ - foreign/c/primitives/chibi/foreign-c.c \ - -fPIC \ - -lffi \ - -shared - -chicken: - @echo "Nothing to build for Chicken" - -cyclone: - @echo "Nothing to build for Cyclone" - -gambit: - @echo "Nothing to build for Gambit" - -gauche: primitives/gauche/foreign-c-primitives-gauche.c primitives/gauche/gauchelib.scm - gauche-package compile \ - --srcdir=primitives/gauche \ - --cc=${CC} \ - --cflags="-I./primitives/include" \ - --libs=-lffi \ - foreign-c-primitives-gauche foreign-c-primitives-gauche.c gauchelib.scm - mkdir -p lib - mv foreign-c-primitives-gauche.so lib/gauche.so - mv foreign-c-primitives-gauche.o lib/gauche.o - - -guile: - @echo "Nothing to build for Guile" - -kawa: - @echo "Nothing to build for Kawa" - -larceny: - @echo "Nothing to build for Larceny" - -mosh: - @echo "Nothing to build for Mosh" - -racket: - @echo "Nothing to build for Racket" - -sagittarius: - @echo "Nothing to build for Sagittarius" - -skint: - @echo "Nothing to build for Skint" - -stklos: - @echo "Nothing to build for Stklos" - -tr7: - @echo "Nothing to build for tr7" - -ypsilon: - @echo "Nothing to build for Ypsilon" - -clean: - @rm -rf primitives/chibi/foreign-c.c - @rm -rf lib diff --git a/foreign/c/array.sld b/foreign/c/array.sld new file mode 100644 index 0000000..48b546d --- /dev/null +++ b/foreign/c/array.sld @@ -0,0 +1,14 @@ +(define-library + (foreign c array) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context)) + (export make-c-array + c-array-ref + c-array-set! + list->c-array + c-array->list) + (include "array.scm")) diff --git a/foreign/c/primitives/mit-scheme.scm b/foreign/c/bytevectors.scm similarity index 100% rename from foreign/c/primitives/mit-scheme.scm rename to foreign/c/bytevectors.scm diff --git a/foreign/c/c-bytevectors.sld b/foreign/c/c-bytevectors.sld new file mode 100644 index 0000000..1b4b086 --- /dev/null +++ b/foreign/c/c-bytevectors.sld @@ -0,0 +1,10 @@ +(define-library + (foreign c c-bytevectors) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (scheme inexact)) + (export c-bytevectors-init) + (include "c-bytevectors.scm")) diff --git a/foreign/c/chibi-primitives.c b/foreign/c/chibi-primitives.c new file mode 100644 index 0000000..57f05ec --- /dev/null +++ b/foreign/c/chibi-primitives.c @@ -0,0 +1,854 @@ +/* Automatically generated by chibi-ffi; version: 0.5 */ + +#include + +#include + +#include + +#include + +#include +void* make_c_null() { return NULL; } +sexp is_null(void* pointer) { if(pointer == NULL) { return SEXP_TRUE; } else { return SEXP_FALSE; } } + + int size_of_int8_t() { return sizeof(int8_t); } + int size_of_uint8_t() { return sizeof(uint8_t); } + int size_of_int16_t() { return sizeof(int16_t); } + int size_of_uint16_t() { return sizeof(uint16_t); } + int size_of_int32_t() { return sizeof(int32_t); } + int size_of_uint32_t() { return sizeof(uint32_t); } + int size_of_int64_t() { return sizeof(int64_t); } + int size_of_uint64_t() { return sizeof(uint64_t); } + int size_of_char() { return sizeof(char); } + int size_of_unsigned_char() { return sizeof(unsigned char); } + int size_of_short() { return sizeof(short); } + int size_of_unsigned_short() { return sizeof(unsigned short); } + int size_of_int() { return sizeof(int); } + int size_of_unsigned_int() { return sizeof(unsigned int); } + int size_of_long() { return sizeof(long); } + int size_of_unsigned_long() { return sizeof(unsigned long); } + int size_of_float() { return sizeof(float); } + int size_of_double() { return sizeof(double); } + int size_of_pointer() { return sizeof(void*); } + + + int align_of_int8_t() { return _Alignof(int8_t); } + int align_of_uint8_t() { return _Alignof(uint8_t); } + int align_of_int16_t() { return _Alignof(int16_t); } + int align_of_uint16_t() { return _Alignof(uint16_t); } + int align_of_int32_t() { return _Alignof(int32_t); } + int align_of_uint32_t() { return _Alignof(uint32_t); } + int align_of_int64_t() { return _Alignof(int64_t); } + int align_of_uint64_t() { return _Alignof(uint64_t); } + int align_of_char() { return _Alignof(char); } + int align_of_unsigned_char() { return _Alignof(unsigned char); } + int align_of_short() { return _Alignof(short); } + int align_of_unsigned_short() { return _Alignof(unsigned short); } + int align_of_int() { return _Alignof(int); } + int align_of_unsigned_int() { return _Alignof(unsigned int); } + int align_of_long() { return _Alignof(long); } + int align_of_unsigned_long() { return _Alignof(unsigned long); } + int align_of_float() { return _Alignof(float); } + int align_of_double() { return _Alignof(double); } + int align_of_pointer() { return _Alignof(void*); } + +sexp is_pointer(struct sexp_struct* object) { if(sexp_cpointerp(object)) { return SEXP_TRUE; } else { return SEXP_FALSE; } } +void c_bytevector_u8_set(void* pointer, int offset, uint8_t value) { *(uint8_t*)((uint8_t*)pointer + offset) = value; } +uint8_t c_bytevector_u8_ref (void* pointer, int offset) { return *(uint8_t*)((uint8_t*)pointer + offset); } +void c_bytevector_pointer_set (void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; } +void* c_bytevector_pointer_ref (void* pointer, int offset) { char* p = (char*)pointer + offset; return (void*)*(char**)p;} +ffi_cif cif; +void* internal_ffi_call( + unsigned int nargs, + unsigned int rtype, + unsigned int atypes[], + void* fn, + unsigned int rvalue_size, + struct sexp_struct* avalues[]) + { + ffi_type* c_atypes[nargs]; + void* c_avalues[nargs]; + + int8_t vals1[nargs]; + uint8_t vals2[nargs]; + int16_t vals3[nargs]; + uint16_t vals4[nargs]; + int32_t vals5[nargs]; + uint32_t vals6[nargs]; + int64_t vals7[nargs]; + uint64_t vals8[nargs]; + char vals9[nargs]; + unsigned char vals10[nargs]; + short vals11[nargs]; + unsigned short vals12[nargs]; + int vals13[nargs]; + unsigned int vals14[nargs]; + long vals15[nargs]; + unsigned long vals16[nargs]; + float vals17[nargs]; + double vals18[nargs]; + void* vals20[nargs]; + + //printf("nargs: %i\n", nargs); + for(int i = 0; i < nargs; i++) { + //printf("i: %i\n", i); + void* arg = NULL; + switch(atypes[i]) { + case 1: + c_atypes[i] = &ffi_type_sint8; + vals1[i] = (int8_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals1[i]; + break; + case 2: + c_atypes[i] = &ffi_type_uint8; + vals2[i] = (uint8_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals2[i]; + break; + case 3: + c_atypes[i] = &ffi_type_sint16; + vals3[i] = (int16_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals3[i]; + break; + case 4: + c_atypes[i] = &ffi_type_uint16; + vals4[i] = (uint16_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals4[i]; + break; + case 5: + c_atypes[i] = &ffi_type_sint32; + vals5[i] = (int32_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals5[i]; + break; + case 6: + c_atypes[i] = &ffi_type_uint32; + vals6[i] = (int64_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals6[i]; + break; + case 7: + c_atypes[i] = &ffi_type_sint64; + vals7[i] = (int64_t) sexp_sint_value(avalues[i]); + c_avalues[i] = &vals7[i]; + break; + case 8: + c_atypes[i] = &ffi_type_uint64; + vals8[i] = (uint64_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals8[i]; + break; + case 9: + c_atypes[i] = &ffi_type_schar; + vals9[i] = (char)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals9[i]; + break; + case 10: + c_atypes[i] = &ffi_type_uchar; + vals10[i] = (unsigned char)sexp_uint_value(avalues[i]); + break; + case 11: + c_atypes[i] = &ffi_type_sshort; + vals11[i] = (short)sexp_sint_value(avalues[i]); + break; + case 12: + c_atypes[i] = &ffi_type_ushort; + vals12[i] = (unsigned short)sexp_uint_value(avalues[i]); + break; + case 13: + c_atypes[i] = &ffi_type_sint; + vals13[i] = (int)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals13[i]; + break; + case 14: + c_atypes[i] = &ffi_type_uint; + vals14[i] = (unsigned int)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals14[i]; + break; + case 15: + c_atypes[i] = &ffi_type_slong; + vals15[i] = (long)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals15[i]; + break; + case 16: + c_atypes[i] = &ffi_type_ulong; + vals16[i] = (unsigned long)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals16[i]; + break; + case 17: + c_atypes[i] = &ffi_type_float; + vals17[i] = (float)sexp_flonum_value(avalues[i]); + c_avalues[i] = &vals17[i]; + break; + case 18: + c_atypes[i] = &ffi_type_double; + vals18[i] = (double)sexp_flonum_value(avalues[i]); + c_avalues[i] = &vals18[i]; + break; + case 19: + c_atypes[i] = &ffi_type_void; + arg = NULL; + c_avalues[i] = NULL; + break; + case 20: + c_atypes[i] = &ffi_type_pointer; + if(sexp_cpointerp(avalues[i])) { + vals20[i] = sexp_cpointer_value(avalues[i]); + } else { + vals20[i] = NULL; + } + c_avalues[i] = &vals20[i]; + break; + default: + printf("Undefined argument type integer: %i, index: %i\n", atypes[i], i); + //c_avalues[i] = sexp_cpointer_value(avalues[i]); + break; + } + } + + ffi_type* c_rtype = &ffi_type_void; + switch(rtype) { + case 1: c_rtype = &ffi_type_sint8; break; + case 2: c_rtype = &ffi_type_uint8; break; + case 3: c_rtype = &ffi_type_sint16; break; + case 4: c_rtype = &ffi_type_uint16; break; + case 5: c_rtype = &ffi_type_sint32; break; + case 6: c_rtype = &ffi_type_uint32; break; + case 7: c_rtype = &ffi_type_sint64; break; + case 8: c_rtype = &ffi_type_uint64; break; + case 9: c_rtype = &ffi_type_schar; break; + case 10: c_rtype = &ffi_type_uchar; break; + case 11: c_rtype = &ffi_type_sshort; break; + case 12: c_rtype = &ffi_type_ushort; break; + case 13: c_rtype = &ffi_type_sint; break; + case 14: c_rtype = &ffi_type_uint; break; + case 15: c_rtype = &ffi_type_slong; break; + case 16: c_rtype = &ffi_type_ulong; break; + case 17: c_rtype = &ffi_type_float; break; + case 18: c_rtype = &ffi_type_double; break; + case 19: c_rtype = &ffi_type_void; break; + case 20: c_rtype = &ffi_type_pointer; break; + default: + printf("Undefined return type: %i\n", rtype); + c_rtype = &ffi_type_pointer; + break; + } + + int r = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, c_rtype, c_atypes); + + void* rvalue = malloc(rvalue_size); + ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues); + return rvalue; + } +void* scheme_procedure_to_pointer(sexp proc) { + if(sexp_procedurep(proc) == 1) { + return 0; //&sexp_unbox_fixnum(proc); + } else { + printf("NOT A FUNCTION\n"); + } + return (void*)proc; + } +/* +types: () +enums: () +*/ + +sexp sexp_scheme_procedure_to_pointer_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) { + sexp res; + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, scheme_procedure_to_pointer(arg0), SEXP_FALSE, 0); + return res; +} + +sexp sexp_internal_ffi_call_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1, sexp arg2, sexp arg3, sexp arg4, sexp arg5) { + int i = 0; + void* *tmp; + unsigned int *tmp2; + sexp *tmp5; + sexp res; + if (! sexp_exact_integerp(arg0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + for (res=arg2; sexp_pairp(res); res=sexp_cdr(res)) + if (! sexp_exact_integerp(sexp_car(res))) + return sexp_xtype_exception(ctx, self, "not a list of integers", arg2); + if (! sexp_nullp(res)) + return sexp_xtype_exception(ctx, self, "not a list of integers", arg2); + if (! ((sexp_pointerp(arg3) && (sexp_pointer_tag(arg3) == SEXP_CPOINTER)) || sexp_not(arg3))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg3); + if (! sexp_exact_integerp(arg4)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg4); + for (res=arg5; sexp_pairp(res); res=sexp_cdr(res)) + if (! 1) + return sexp_xtype_exception(ctx, self, "not a list of sexps", arg5); + if (! sexp_nullp(res)) + return sexp_xtype_exception(ctx, self, "not a list of sexps", arg5); + tmp2 = (unsigned int*) calloc((sexp_unbox_fixnum(sexp_length(ctx, arg2))+1), sizeof(tmp2[0])); + for (i=0, res=arg2; sexp_pairp(res); res=sexp_cdr(res), i++) { + tmp2[i] = sexp_uint_value(sexp_car(res)); + } + tmp2[i] = 0; + tmp5 = (sexp*) calloc((sexp_unbox_fixnum(sexp_length(ctx, arg5))+1), sizeof(tmp5[0])); + for (i=0, res=arg5; sexp_pairp(res); res=sexp_cdr(res), i++) { + tmp5[i] = sexp_car(res); + } + tmp5[i] = 0; + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, internal_ffi_call(sexp_uint_value(arg0), sexp_uint_value(arg1), tmp2, (void**)sexp_cpointer_maybe_null_value(arg3), sexp_uint_value(arg4), tmp5), SEXP_FALSE, 0); + free(tmp2); + free(tmp5); + return res; +} + +sexp sexp_dlsym_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) { + void* *tmp; + sexp res; + if (! ((sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER)) || sexp_not(arg0))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + if (! sexp_stringp(arg1)) + return sexp_type_exception(ctx, self, SEXP_STRING, arg1); + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, dlsym((void**)sexp_cpointer_maybe_null_value(arg0), sexp_string_data(arg1)), SEXP_FALSE, 0); + return res; +} + +sexp sexp_c_bytevector_pointer_ref_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) { + void* *tmp; + sexp res; + if (! ((sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER)) || sexp_not(arg0))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, c_bytevector_pointer_ref((void**)sexp_cpointer_maybe_null_value(arg0), sexp_sint_value(arg1)), SEXP_FALSE, 0); + return res; +} + +sexp sexp_c_bytevector_pointer_set_x_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1, sexp arg2) { + sexp res; + if (! (sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + if (! ((sexp_pointerp(arg2) && (sexp_pointer_tag(arg2) == SEXP_CPOINTER)) || sexp_not(arg2))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg2); + res = ((c_bytevector_pointer_set((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), (void**)sexp_cpointer_maybe_null_value(arg2))), SEXP_VOID); + return res; +} + +sexp sexp_c_bytevector_u8_ref_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) { + sexp res; + if (! ((sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER)) || sexp_not(arg0))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + res = sexp_make_unsigned_integer(ctx, c_bytevector_u8_ref((void**)sexp_cpointer_maybe_null_value(arg0), sexp_sint_value(arg1))); + return res; +} + +sexp sexp_c_bytevector_u8_set_x_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1, sexp arg2) { + sexp res; + if (! ((sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER)) || sexp_not(arg0))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + if (! sexp_exact_integerp(arg2)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); + res = ((c_bytevector_u8_set((void**)sexp_cpointer_maybe_null_value(arg0), sexp_sint_value(arg1), sexp_uint_value(arg2))), SEXP_VOID); + return res; +} + +sexp sexp_pointer_p_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) { + sexp res; + res = is_pointer(arg0); + return res; +} + +sexp sexp_dlerror_stub (sexp ctx, sexp self, sexp_sint_t n) { + void* *tmp; + sexp res; + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, dlerror(), SEXP_FALSE, 0); + return res; +} + +sexp sexp_dlopen_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) { + void* *tmp; + sexp res; + if (! sexp_stringp(arg0)) + return sexp_type_exception(ctx, self, SEXP_STRING, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, dlopen(sexp_string_data(arg0), sexp_sint_value(arg1)), SEXP_FALSE, 0); + return res; +} + +sexp sexp_align_of_pointer_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_pointer()); + return res; +} + +sexp sexp_align_of_double_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_double()); + return res; +} + +sexp sexp_align_of_float_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_float()); + return res; +} + +sexp sexp_align_of_unsigned_long_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_unsigned_long()); + return res; +} + +sexp sexp_align_of_long_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_long()); + return res; +} + +sexp sexp_align_of_unsigned_int_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_unsigned_int()); + return res; +} + +sexp sexp_align_of_int_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_int()); + return res; +} + +sexp sexp_align_of_unsigned_short_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_unsigned_short()); + return res; +} + +sexp sexp_align_of_short_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_short()); + return res; +} + +sexp sexp_align_of_unsigned_char_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_unsigned_char()); + return res; +} + +sexp sexp_align_of_char_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_char()); + return res; +} + +sexp sexp_align_of_uint64_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_uint64_t()); + return res; +} + +sexp sexp_align_of_int64_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_int64_t()); + return res; +} + +sexp sexp_align_of_uint32_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_uint32_t()); + return res; +} + +sexp sexp_align_of_int32_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_int32_t()); + return res; +} + +sexp sexp_align_of_uint16_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_uint16_t()); + return res; +} + +sexp sexp_align_of_int16_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_int16_t()); + return res; +} + +sexp sexp_align_of_uint8_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_uint8_t()); + return res; +} + +sexp sexp_align_of_int8_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_int8_t()); + return res; +} + +sexp sexp_size_of_pointer_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_pointer()); + return res; +} + +sexp sexp_size_of_double_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_double()); + return res; +} + +sexp sexp_size_of_float_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_float()); + return res; +} + +sexp sexp_size_of_unsigned_long_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_unsigned_long()); + return res; +} + +sexp sexp_size_of_long_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_long()); + return res; +} + +sexp sexp_size_of_unsigned_int_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_unsigned_int()); + return res; +} + +sexp sexp_size_of_int_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_int()); + return res; +} + +sexp sexp_size_of_unsigned_short_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_unsigned_short()); + return res; +} + +sexp sexp_size_of_short_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_short()); + return res; +} + +sexp sexp_size_of_unsigned_char_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_unsigned_char()); + return res; +} + +sexp sexp_size_of_char_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_char()); + return res; +} + +sexp sexp_size_of_uint64_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_uint64_t()); + return res; +} + +sexp sexp_size_of_int64_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_int64_t()); + return res; +} + +sexp sexp_size_of_uint32_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_uint32_t()); + return res; +} + +sexp sexp_size_of_int32_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_int32_t()); + return res; +} + +sexp sexp_size_of_uint16_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_uint16_t()); + return res; +} + +sexp sexp_size_of_int16_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_int16_t()); + return res; +} + +sexp sexp_size_of_uint8_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_uint8_t()); + return res; +} + +sexp sexp_size_of_int8_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_int8_t()); + return res; +} + +sexp sexp_c_null_p_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) { + sexp res; + if (! ((sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER)) || sexp_not(arg0))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + res = is_null((void**)sexp_cpointer_maybe_null_value(arg0)); + return res; +} + +sexp sexp_make_c_null_stub (sexp ctx, sexp self, sexp_sint_t n) { + void* *tmp; + sexp res; + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, make_c_null(), SEXP_FALSE, 0); + return res; +} + + +sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) { + sexp_gc_var3(name, tmp, op); + if (!(sexp_version_compatible(ctx, version, sexp_version) + && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) + return SEXP_ABI_ERROR; + sexp_gc_preserve3(ctx, name, tmp, op); + name = sexp_intern(ctx, "FFI-OK", 6); + sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, FFI_OK)); + name = sexp_intern(ctx, "RTLD-NOW", 8); + sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, RTLD_NOW)); + op = sexp_define_foreign(ctx, env, "scheme-procedure-to-pointer", 1, sexp_scheme_procedure_to_pointer_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + } + op = sexp_define_foreign(ctx, env, "internal-ffi-call", 6, sexp_internal_ffi_call_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_argn_type(op) = sexp_make_vector(ctx, SEXP_THREE, sexp_make_fixnum(SEXP_OBJECT)); + sexp_vector_set(sexp_opcode_argn_type(op), SEXP_ZERO, sexp_make_fixnum(SEXP_CPOINTER)); + sexp_vector_set(sexp_opcode_argn_type(op), SEXP_ONE, sexp_make_fixnum(SEXP_FIXNUM)); + } + op = sexp_define_foreign(ctx, env, "dlsym", 2, sexp_dlsym_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_STRING); + } + op = sexp_define_foreign(ctx, env, "c-bytevector-pointer-ref", 2, sexp_c_bytevector_pointer_ref_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "c-bytevector-pointer-set!", 3, sexp_c_bytevector_pointer_set_x_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = SEXP_VOID; + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + } + op = sexp_define_foreign(ctx, env, "c-bytevector-u8-ref", 2, sexp_c_bytevector_u8_ref_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "c-bytevector-u8-set!", 3, sexp_c_bytevector_u8_set_x_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = SEXP_VOID; + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "pointer?", 1, sexp_pointer_p_stub); + op = sexp_define_foreign(ctx, env, "dlerror", 0, sexp_dlerror_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + } + op = sexp_define_foreign(ctx, env, "dlopen", 2, sexp_dlopen_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-pointer", 0, sexp_align_of_pointer_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-double", 0, sexp_align_of_double_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-float", 0, sexp_align_of_float_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-unsigned-long", 0, sexp_align_of_unsigned_long_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-long", 0, sexp_align_of_long_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-unsigned-int", 0, sexp_align_of_unsigned_int_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-int", 0, sexp_align_of_int_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-unsigned-short", 0, sexp_align_of_unsigned_short_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-short", 0, sexp_align_of_short_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-unsigned-char", 0, sexp_align_of_unsigned_char_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-char", 0, sexp_align_of_char_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-uint64_t", 0, sexp_align_of_uint64_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-int64_t", 0, sexp_align_of_int64_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-uint32_t", 0, sexp_align_of_uint32_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-int32_t", 0, sexp_align_of_int32_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-uint16_t", 0, sexp_align_of_uint16_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-int16_t", 0, sexp_align_of_int16_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-uint8_t", 0, sexp_align_of_uint8_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-int8_t", 0, sexp_align_of_int8_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-pointer", 0, sexp_size_of_pointer_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-double", 0, sexp_size_of_double_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-float", 0, sexp_size_of_float_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-unsigned-long", 0, sexp_size_of_unsigned_long_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-long", 0, sexp_size_of_long_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-unsigned-int", 0, sexp_size_of_unsigned_int_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-int", 0, sexp_size_of_int_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-unsigned-short", 0, sexp_size_of_unsigned_short_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-short", 0, sexp_size_of_short_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-unsigned-char", 0, sexp_size_of_unsigned_char_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-char", 0, sexp_size_of_char_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-uint64_t", 0, sexp_size_of_uint64_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-int64_t", 0, sexp_size_of_int64_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-uint32_t", 0, sexp_size_of_uint32_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-int32_t", 0, sexp_size_of_int32_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-uint16_t", 0, sexp_size_of_uint16_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-int16_t", 0, sexp_size_of_int16_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-uint8_t", 0, sexp_size_of_uint8_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-int8_t", 0, sexp_size_of_int8_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "c-null?", 1, sexp_c_null_p_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + } + op = sexp_define_foreign(ctx, env, "make-c-null", 0, sexp_make_c_null_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + } + sexp_gc_release3(ctx); + return SEXP_VOID; +} + diff --git a/foreign/c/primitives/chibi.scm b/foreign/c/chibi-primitives.scm similarity index 63% rename from foreign/c/primitives/chibi.scm rename to foreign/c/chibi-primitives.scm index ea8713f..3555d52 100644 --- a/foreign/c/primitives/chibi.scm +++ b/foreign/c/chibi-primitives.scm @@ -1,3 +1,54 @@ +(define c-bytevector-get + (lambda (pointer type offset) + (cond ((equal? type 'int8) (c-bytevector-s8-ref pointer offset)) + ((equal? type 'uint8) (c-bytevector-u8-ref pointer offset)) + ((equal? type 'int16) (c-bytevector-s16-ref pointer offset)) + ((equal? type 'uint16) (c-bytevector-u16-ref pointer offset)) + ((equal? type 'int32) (c-bytevector-s32-ref pointer offset)) + ((equal? type 'uint32) (c-bytevector-u32-ref pointer offset)) + ((equal? type 'int64) (c-bytevector-s64-ref pointer offset)) + ((equal? type 'uint64) (c-bytevector-u64-ref pointer offset)) + ((equal? type 'char) (integer->char (c-bytevector-s8-ref pointer offset))) + ((equal? type 'unsigned-char) (integer->char (c-bytevector-u8-ref pointer offset))) + ((equal? type 'short) (c-bytevector-sint-ref pointer offset (native-endianness) (size-of-type 'short))) + ((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 '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)) + ((equal? type 'pointer) (c-bytevector-pointer-ref pointer offset)) + ((not (equal? type 'void)) (error "No such foreign type" type)) + ;; Return unspecified on purpose if type is void + ))) + +(define type->libffi-type-number + (lambda (type) + (cond ((equal? type 'int8) 1) + ((equal? type 'uint8) 2) + ((equal? type 'int16) 3) + ((equal? type 'uint16) 4) + ((equal? type 'int32) 5) + ((equal? type 'uint32) 6) + ((equal? type 'int64) 7) + ((equal? type 'uint64) 8) + ((equal? type 'char) 9) + ((equal? type 'unsigned-char) 10) + ((equal? type 'short) 11) + ((equal? type 'unsigned-short) 12) + ((equal? type 'int) 13) + ((equal? type 'unsigned-int) 14) + ((equal? type 'long) 15) + ((equal? type 'unsigned-long) 16) + ((equal? type 'float) 17) + ((equal? type 'double) 18) + ((equal? type 'void) 19) + ((equal? type 'pointer) 20) + ((equal? type 'pointer-address) 21) + ((equal? type 'callback) 22) + (else (error "Undefined type" type))))) + (define size-of-type (lambda (type) (cond ((eq? type 'int8) (size-of-int8_t)) @@ -100,7 +151,7 @@ (type->libffi-type-number return-type) (map type->libffi-type-number argument-types) c-function - (c-type-size return-type) + (size-of-type return-type) arguments))) (c-bytevector-get return-pointer return-type 0)))))) diff --git a/foreign/c/chibi-primitives.sld b/foreign/c/chibi-primitives.sld new file mode 100644 index 0000000..57428e2 --- /dev/null +++ b/foreign/c/chibi-primitives.sld @@ -0,0 +1,26 @@ +(define-library + (foreign c chibi-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (chibi ast) + (scheme inexact) + (chibi)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + ;; Chibi specific + c-null? + ) + (include-shared "chibi-primitives") + (include "chibi-primitives.scm") + (include "c-bytevectors.scm")) diff --git a/foreign/c/chibi-primitives.stub b/foreign/c/chibi-primitives.stub new file mode 100644 index 0000000..5ee419c --- /dev/null +++ b/foreign/c/chibi-primitives.stub @@ -0,0 +1,324 @@ +; vim: ft=scheme + +(c-system-include "stdint.h") +(c-system-include "dlfcn.h") +(c-system-include "stdio.h") +(c-system-include "ffi.h") +(c-link "ffi") + +;; make-c-null +(c-declare "void* make_c_null() { return NULL; }") +(define-c (maybe-null pointer void*) make-c-null ()) + +;; c-null? +(c-declare "sexp is_null(void* pointer) { if(pointer == NULL) { return SEXP_TRUE; } else { return SEXP_FALSE; } }") +(define-c sexp (c-null? is_null) ((maybe-null pointer void*))) + +;; c-type-size +(c-declare " + int size_of_int8_t() { return sizeof(int8_t); } + int size_of_uint8_t() { return sizeof(uint8_t); } + int size_of_int16_t() { return sizeof(int16_t); } + int size_of_uint16_t() { return sizeof(uint16_t); } + int size_of_int32_t() { return sizeof(int32_t); } + int size_of_uint32_t() { return sizeof(uint32_t); } + int size_of_int64_t() { return sizeof(int64_t); } + int size_of_uint64_t() { return sizeof(uint64_t); } + int size_of_char() { return sizeof(char); } + int size_of_unsigned_char() { return sizeof(unsigned char); } + int size_of_short() { return sizeof(short); } + int size_of_unsigned_short() { return sizeof(unsigned short); } + int size_of_int() { return sizeof(int); } + int size_of_unsigned_int() { return sizeof(unsigned int); } + int size_of_long() { return sizeof(long); } + int size_of_unsigned_long() { return sizeof(unsigned long); } + int size_of_float() { return sizeof(float); } + int size_of_double() { return sizeof(double); } + int size_of_pointer() { return sizeof(void*); } +") + +(define-c int (size-of-int8_t size_of_int8_t) ()) +(define-c int (size-of-uint8_t size_of_uint8_t) ()) +(define-c int (size-of-int16_t size_of_int16_t) ()) +(define-c int (size-of-uint16_t size_of_uint16_t) ()) +(define-c int (size-of-int32_t size_of_int32_t) ()) +(define-c int (size-of-uint32_t size_of_uint32_t) ()) +(define-c int (size-of-int64_t size_of_int64_t) ()) +(define-c int (size-of-uint64_t size_of_uint64_t) ()) +(define-c int (size-of-char size_of_char) ()) +(define-c int (size-of-unsigned-char size_of_unsigned_char) ()) +(define-c int (size-of-short size_of_short) ()) +(define-c int (size-of-unsigned-short size_of_unsigned_short) ()) +(define-c int (size-of-int size_of_int) ()) +(define-c int (size-of-unsigned-int size_of_unsigned_int) ()) +(define-c int (size-of-long size_of_long) ()) +(define-c int (size-of-unsigned-long size_of_unsigned_long) ()) +(define-c int (size-of-float size_of_float) ()) +(define-c int (size-of-double size_of_double) ()) +(define-c int (size-of-pointer size_of_pointer) ()) + +;; c-type-align +(c-declare " + int align_of_int8_t() { return _Alignof(int8_t); } + int align_of_uint8_t() { return _Alignof(uint8_t); } + int align_of_int16_t() { return _Alignof(int16_t); } + int align_of_uint16_t() { return _Alignof(uint16_t); } + int align_of_int32_t() { return _Alignof(int32_t); } + int align_of_uint32_t() { return _Alignof(uint32_t); } + int align_of_int64_t() { return _Alignof(int64_t); } + int align_of_uint64_t() { return _Alignof(uint64_t); } + int align_of_char() { return _Alignof(char); } + int align_of_unsigned_char() { return _Alignof(unsigned char); } + int align_of_short() { return _Alignof(short); } + int align_of_unsigned_short() { return _Alignof(unsigned short); } + int align_of_int() { return _Alignof(int); } + int align_of_unsigned_int() { return _Alignof(unsigned int); } + int align_of_long() { return _Alignof(long); } + int align_of_unsigned_long() { return _Alignof(unsigned long); } + int align_of_float() { return _Alignof(float); } + int align_of_double() { return _Alignof(double); } + int align_of_pointer() { return _Alignof(void*); } +") + +(define-c int (align-of-int8_t align_of_int8_t) ()) +(define-c int (align-of-uint8_t align_of_uint8_t) ()) +(define-c int (align-of-int16_t align_of_int16_t) ()) +(define-c int (align-of-uint16_t align_of_uint16_t) ()) +(define-c int (align-of-int32_t align_of_int32_t) ()) +(define-c int (align-of-uint32_t align_of_uint32_t) ()) +(define-c int (align-of-int64_t align_of_int64_t) ()) +(define-c int (align-of-uint64_t align_of_uint64_t) ()) +(define-c int (align-of-char align_of_char) ()) +(define-c int (align-of-unsigned-char align_of_unsigned_char) ()) +(define-c int (align-of-short align_of_short) ()) +(define-c int (align-of-unsigned-short align_of_unsigned_short) ()) +(define-c int (align-of-int align_of_int) ()) +(define-c int (align-of-unsigned-int align_of_unsigned_int) ()) +(define-c int (align-of-long align_of_long) ()) +(define-c int (align-of-unsigned-long align_of_unsigned_long) ()) +(define-c int (align-of-float align_of_float) ()) +(define-c int (align-of-double align_of_double) ()) +(define-c int (align-of-pointer align_of_pointer) ()) + +;; shared-object-load +(define-c-const int (RTLD-NOW "RTLD_NOW")) +(define-c (maybe-null pointer void*) dlopen (string int)) +(define-c (maybe-null pointer void*) dlerror ()) + +(c-declare "sexp is_pointer(struct sexp_struct* object) { if(sexp_cpointerp(object)) { return SEXP_TRUE; } else { return SEXP_FALSE; } }") +(define-c sexp (pointer? is_pointer) (sexp)) + +(c-declare "void c_bytevector_u8_set(void* pointer, int offset, uint8_t value) { *(uint8_t*)((uint8_t*)pointer + offset) = value; }") +(define-c void (c-bytevector-u8-set! c_bytevector_u8_set) ((maybe-null pointer void*) int uint8_t)) + +(c-declare "uint8_t c_bytevector_u8_ref (void* pointer, int offset) { return *(uint8_t*)((uint8_t*)pointer + offset); }") +(define-c uint8_t (c-bytevector-u8-ref c_bytevector_u8_ref) ((maybe-null pointer void*) int)) + +(c-declare "void c_bytevector_pointer_set (void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }") +(define-c void (c-bytevector-pointer-set! c_bytevector_pointer_set) ((pointer void*) int (maybe-null pointer void*))) + +(c-declare "void* c_bytevector_pointer_ref (void* pointer, int offset) { char* p = (char*)pointer + offset; return (void*)*(char**)p;}") +(define-c (maybe-null pointer void*) (c-bytevector-pointer-ref c_bytevector_pointer_ref) ((maybe-null pointer void*) int)) + +(c-declare "ffi_cif cif;") +(define-c (maybe-null pointer void*) dlsym ((maybe-null pointer void*) string)) + +(define-c-const int (FFI-OK "FFI_OK")) +(c-declare + "void* internal_ffi_call( + unsigned int nargs, + unsigned int rtype, + unsigned int atypes[], + void* fn, + unsigned int rvalue_size, + struct sexp_struct* avalues[]) + { + ffi_type* c_atypes[nargs]; + void* c_avalues[nargs]; + + int8_t vals1[nargs]; + uint8_t vals2[nargs]; + int16_t vals3[nargs]; + uint16_t vals4[nargs]; + int32_t vals5[nargs]; + uint32_t vals6[nargs]; + int64_t vals7[nargs]; + uint64_t vals8[nargs]; + char vals9[nargs]; + unsigned char vals10[nargs]; + short vals11[nargs]; + unsigned short vals12[nargs]; + int vals13[nargs]; + unsigned int vals14[nargs]; + long vals15[nargs]; + unsigned long vals16[nargs]; + float vals17[nargs]; + double vals18[nargs]; + void* vals20[nargs]; + + //printf(\"nargs: %i\\n\", nargs); + for(int i = 0; i < nargs; i++) { + //printf(\"i: %i\\n\", i); + void* arg = NULL; + switch(atypes[i]) { + case 1: + c_atypes[i] = &ffi_type_sint8; + vals1[i] = (int8_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals1[i]; + break; + case 2: + c_atypes[i] = &ffi_type_uint8; + vals2[i] = (uint8_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals2[i]; + break; + case 3: + c_atypes[i] = &ffi_type_sint16; + vals3[i] = (int16_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals3[i]; + break; + case 4: + c_atypes[i] = &ffi_type_uint16; + vals4[i] = (uint16_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals4[i]; + break; + case 5: + c_atypes[i] = &ffi_type_sint32; + vals5[i] = (int32_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals5[i]; + break; + case 6: + c_atypes[i] = &ffi_type_uint32; + vals6[i] = (int64_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals6[i]; + break; + case 7: + c_atypes[i] = &ffi_type_sint64; + vals7[i] = (int64_t) sexp_sint_value(avalues[i]); + c_avalues[i] = &vals7[i]; + break; + case 8: + c_atypes[i] = &ffi_type_uint64; + vals8[i] = (uint64_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals8[i]; + break; + case 9: + c_atypes[i] = &ffi_type_schar; + vals9[i] = (char)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals9[i]; + break; + case 10: + c_atypes[i] = &ffi_type_uchar; + vals10[i] = (unsigned char)sexp_uint_value(avalues[i]); + break; + case 11: + c_atypes[i] = &ffi_type_sshort; + vals11[i] = (short)sexp_sint_value(avalues[i]); + break; + case 12: + c_atypes[i] = &ffi_type_ushort; + vals12[i] = (unsigned short)sexp_uint_value(avalues[i]); + break; + case 13: + c_atypes[i] = &ffi_type_sint; + vals13[i] = (int)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals13[i]; + break; + case 14: + c_atypes[i] = &ffi_type_uint; + vals14[i] = (unsigned int)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals14[i]; + break; + case 15: + c_atypes[i] = &ffi_type_slong; + vals15[i] = (long)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals15[i]; + break; + case 16: + c_atypes[i] = &ffi_type_ulong; + vals16[i] = (unsigned long)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals16[i]; + break; + case 17: + c_atypes[i] = &ffi_type_float; + vals17[i] = (float)sexp_flonum_value(avalues[i]); + c_avalues[i] = &vals17[i]; + break; + case 18: + c_atypes[i] = &ffi_type_double; + vals18[i] = (double)sexp_flonum_value(avalues[i]); + c_avalues[i] = &vals18[i]; + break; + case 19: + c_atypes[i] = &ffi_type_void; + arg = NULL; + c_avalues[i] = NULL; + break; + case 20: + c_atypes[i] = &ffi_type_pointer; + if(sexp_cpointerp(avalues[i])) { + vals20[i] = sexp_cpointer_value(avalues[i]); + } else { + vals20[i] = NULL; + } + c_avalues[i] = &vals20[i]; + break; + default: + printf(\"Undefined argument type integer: %i, index: %i\\n\", atypes[i], i); + //c_avalues[i] = sexp_cpointer_value(avalues[i]); + break; + } + } + + ffi_type* c_rtype = &ffi_type_void; + switch(rtype) { + case 1: c_rtype = &ffi_type_sint8; break; + case 2: c_rtype = &ffi_type_uint8; break; + case 3: c_rtype = &ffi_type_sint16; break; + case 4: c_rtype = &ffi_type_uint16; break; + case 5: c_rtype = &ffi_type_sint32; break; + case 6: c_rtype = &ffi_type_uint32; break; + case 7: c_rtype = &ffi_type_sint64; break; + case 8: c_rtype = &ffi_type_uint64; break; + case 9: c_rtype = &ffi_type_schar; break; + case 10: c_rtype = &ffi_type_uchar; break; + case 11: c_rtype = &ffi_type_sshort; break; + case 12: c_rtype = &ffi_type_ushort; break; + case 13: c_rtype = &ffi_type_sint; break; + case 14: c_rtype = &ffi_type_uint; break; + case 15: c_rtype = &ffi_type_slong; break; + case 16: c_rtype = &ffi_type_ulong; break; + case 17: c_rtype = &ffi_type_float; break; + case 18: c_rtype = &ffi_type_double; break; + case 19: c_rtype = &ffi_type_void; break; + case 20: c_rtype = &ffi_type_pointer; break; + default: + printf(\"Undefined return type: %i\\n\", rtype); + c_rtype = &ffi_type_pointer; + break; + } + + int r = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, c_rtype, c_atypes); + + void* rvalue = malloc(rvalue_size); + ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues); + return rvalue; + }") +(define-c (maybe-null pointer void*) + (internal-ffi-call internal_ffi_call) + (unsigned-int + unsigned-int + (array unsigned-int) + (maybe-null pointer void*) + unsigned-int + (array sexp))) + +(c-declare + "void* scheme_procedure_to_pointer(sexp proc) { + if(sexp_procedurep(proc) == 1) { + return 0; //&sexp_unbox_fixnum(proc); + } else { + printf(\"NOT A FUNCTION\\n\"); + } + return (void*)proc; + }") +(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp)) diff --git a/foreign/c/primitives/chicken.scm b/foreign/c/chicken-primitives.scm similarity index 95% rename from foreign/c/primitives/chicken.scm rename to foreign/c/chicken-primitives.scm index 41eb726..c06f267 100644 --- a/foreign/c/primitives/chicken.scm +++ b/foreign/c/chicken-primitives.scm @@ -160,17 +160,6 @@ ((equal? type 'string) (foreign-value "_Alignof(void*)" int)) ((equal? type 'callback) (foreign-value "_Alignof(void*)" int))))) -(define make-c-null - (lambda () - (address->pointer 0))) - -(define-syntax define-c-library - (syntax-rules () - ((_ scheme-name headers object-name options) - (begin - (define scheme-name #t) - (shared-object-load headers))))) - (define-syntax shared-object-load (er-macro-transformer (lambda (expr rename compare) @@ -181,14 +170,6 @@ `(foreign-declare ,(string-append "#include <" header ">"))) headers)))))) -(define c-null? - (lambda (pointer) - (if (and (not (pointer? pointer)) - pointer) - #f - (or (not pointer) ; #f counts as null pointer on Chicken - (= (pointer->address pointer) 0))))) - (define c-bytevector-u8-ref (lambda (c-bytevector k) (pointer-u8-ref (pointer+ c-bytevector k)))) diff --git a/foreign/c/chicken-primitives.sld b/foreign/c/chicken-primitives.sld new file mode 100644 index 0000000..ad4e77f --- /dev/null +++ b/foreign/c/chicken-primitives.sld @@ -0,0 +1,33 @@ +(define-library + (foreign c chicken-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (chicken base) + (chicken foreign) + (chicken locative) + (chicken syntax) + (chicken memory) + (chicken random)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + ;; Chicken specific + foreign-declare + foreign-safe-lambda + void + pointer? + foreign-declare + address->pointer + pointer->address) + (include "chicken-primitives.scm")) diff --git a/foreign/c/cyclone-primitives.sld b/foreign/c/cyclone-primitives.sld new file mode 100644 index 0000000..fc0a263 --- /dev/null +++ b/foreign/c/cyclone-primitives.sld @@ -0,0 +1,21 @@ +(define-library + (foreign c primitives-cyclone) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (cyclone foreign) + (scheme cyclone primitives))) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (include "primitives-cyclone.scm")) diff --git a/foreign/c/primitives/cyclone.scm b/foreign/c/cyclones-primitives.scm similarity index 100% rename from foreign/c/primitives/cyclone.scm rename to foreign/c/cyclones-primitives.scm diff --git a/foreign/c/primitives/gambit.scm b/foreign/c/gambit-primitives.scm similarity index 100% rename from foreign/c/primitives/gambit.scm rename to foreign/c/gambit-primitives.scm diff --git a/foreign/c/gambit-primitives.sld b/foreign/c/gambit-primitives.sld new file mode 100644 index 0000000..e922669 --- /dev/null +++ b/foreign/c/gambit-primitives.sld @@ -0,0 +1,20 @@ +(define-library + (foreign c gambit-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (only (gambit) c-declare c-lambda c-define define-macro)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (include "gambit-primitives.scm")) diff --git a/foreign/c/gauche-primitives-gauche.scm b/foreign/c/gauche-primitives-gauche.scm new file mode 100644 index 0000000..2070f54 --- /dev/null +++ b/foreign/c/gauche-primitives-gauche.scm @@ -0,0 +1,6 @@ +(define-module foreign.c.gauche-primitives-gauche + (export hello)) +(select-module foreign.c.gauche-primitives-gauche) +(dynamic-load "gauche-primitives-gauche") + +;(define (hello) 1) diff --git a/foreign/c/gauche-primitives.gauche.c b/foreign/c/gauche-primitives.gauche.c new file mode 100644 index 0000000..f835a68 --- /dev/null +++ b/foreign/c/gauche-primitives.gauche.c @@ -0,0 +1,15 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +void gauche_primitives_init(void) { puts("Hello from init"); } + +extern ScmObj hello() { return Scm_MakeInteger(1); } diff --git a/foreign/c/gauche-primitives.gauche.h b/foreign/c/gauche-primitives.gauche.h new file mode 100644 index 0000000..be0f5d3 --- /dev/null +++ b/foreign/c/gauche-primitives.gauche.h @@ -0,0 +1,113 @@ + +/* +extern ScmObj size_of_int8(); +extern ScmObj size_of_uint8(); +extern ScmObj size_of_int16(); +extern ScmObj size_of_uint16(); +extern ScmObj size_of_int32(); +extern ScmObj size_of_uint32(); +extern ScmObj size_of_int64(); +extern ScmObj size_of_uint64(); +extern ScmObj size_of_char(); +extern ScmObj size_of_unsigned_char(); +extern ScmObj size_of_short(); +extern ScmObj size_of_unsigned_short(); +extern ScmObj size_of_int(); +extern ScmObj size_of_unsigned_int(); +extern ScmObj size_of_long(); +extern ScmObj size_of_unsigned_long(); +extern ScmObj size_of_float(); +extern ScmObj size_of_double(); +extern ScmObj size_of_string(); +extern ScmObj size_of_pointer(); +extern ScmObj size_of_void(); + +extern ScmObj align_of_int8(); +extern ScmObj align_of_uint8(); +extern ScmObj align_of_int16(); +extern ScmObj align_of_uint16(); +extern ScmObj align_of_int32(); +extern ScmObj align_of_uint32(); +extern ScmObj align_of_int64(); +extern ScmObj align_of_uint64(); +extern ScmObj align_of_char(); +extern ScmObj align_of_unsigned_char(); +extern ScmObj align_of_short(); +extern ScmObj align_of_unsigned_short(); +extern ScmObj align_of_int(); +extern ScmObj align_of_unsigned_int(); +extern ScmObj align_of_long(); +extern ScmObj align_of_unsigned_long(); +extern ScmObj align_of_float(); +extern ScmObj align_of_double(); +extern ScmObj align_of_string(); +extern ScmObj align_of_pointer(); +extern ScmObj align_of_void(); + +extern ScmObj shared_object_load(ScmString* path, ScmObj options); +//extern ScmObj pointer_null(); +extern ScmObj is_pointer_null(ScmObj pointer); +//extern ScmObj pointer_allocate(int size); +//extern ScmObj pointer_address(ScmObj pointer); +extern ScmObj is_pointer(ScmObj pointer); +//extern ScmObj pointer_free(ScmObj pointer); + + +//extern ScmObj pointer_set_int8(ScmObj pointer, int offset, int8_t value); +extern ScmObj pointer_set_uint8(ScmObj pointer, int offset, uint8_t value); +extern ScmObj pointer_get_uint8(ScmObj pointer, int offset); +*/ +/* + * extern ScmObj pointer_set_int16(ScmObj pointer, int offset, int16_t value); + * extern ScmObj pointer_set_uint16(ScmObj pointer, int offset, uint16_t value); + * extern ScmObj pointer_set_int32(ScmObj pointer, int offset, int32_t value); + * extern ScmObj pointer_set_uint32(ScmObj pointer, int offset, uint32_t value); + * extern ScmObj pointer_set_int64(ScmObj pointer, int offset, int64_t value); + * extern ScmObj pointer_set_uint64(ScmObj pointer, int offset, uint64_t value); + * extern ScmObj pointer_set_char(ScmObj pointer, int offset, char value); + * extern ScmObj pointer_set_unsigned_char(ScmObj pointer, int offset, unsigned char value); + * extern ScmObj pointer_set_short(ScmObj pointer, int offset, short value); + * extern ScmObj pointer_set_unsigned_short(ScmObj pointer, int offset, unsigned short value); + * extern ScmObj pointer_set_int(ScmObj pointer, int offset, int value); + * extern ScmObj pointer_set_unsigned_int(ScmObj pointer, int offset, unsigned int value); + * extern ScmObj pointer_set_long(ScmObj pointer, int offset, long value); + * extern ScmObj pointer_set_unsigned_long(ScmObj pointer, int offset, unsigned long value); + * extern ScmObj pointer_set_float(ScmObj pointer, int offset, float value); + * extern ScmObj pointer_set_double(ScmObj pointer, int offset, double value); + * */ + +/* +extern ScmObj pointer_set_pointer(ScmObj pointer, int offset, ScmObj value); +extern ScmObj pointer_get_pointer(ScmObj pointer, int offset); +//extern ScmObj string_to_pointer(ScmObj string); +//extern ScmObj pointer_to_string(ScmObj pointer); + +extern ScmObj internal_dlerror(); +extern ScmObj internal_dlsym(ScmObj shared_object, ScmObj c_name); +extern ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, ScmObj rvalue, ScmObj avalues); +extern ScmObj scheme_procedure_to_pointer(ScmObj procedure); + +extern ScmObj get_ffi_type_int8(); +extern ScmObj get_ffi_type_uint8(); +extern ScmObj get_ffi_type_int16(); +extern ScmObj get_ffi_type_uint16(); +extern ScmObj get_ffi_type_int32(); +extern ScmObj get_ffi_type_uint32(); +extern ScmObj get_ffi_type_int64(); +extern ScmObj get_ffi_type_uint64(); +extern ScmObj get_ffi_type_char(); +extern ScmObj get_ffi_type_unsigned_char(); +extern ScmObj get_ffi_type_short(); +extern ScmObj get_ffi_type_unsigned_short(); +extern ScmObj get_ffi_type_int(); +extern ScmObj get_ffi_type_unsigned_int(); +extern ScmObj get_ffi_type_long(); +extern ScmObj get_ffi_type_unsigned_long(); +extern ScmObj get_ffi_type_float(); +extern ScmObj get_ffi_type_double(); +extern ScmObj get_ffi_type_void(); +extern ScmObj get_ffi_type_pointer(); +*/ + +extern void Scm_Init_foreign_c_gauche_primitives(void); +extern ScmObj hello(void); diff --git a/foreign/c/gauche-primitives.gauche.sci b/foreign/c/gauche-primitives.gauche.sci new file mode 100644 index 0000000..aa0595e --- /dev/null +++ b/foreign/c/gauche-primitives.gauche.sci @@ -0,0 +1,5 @@ +;; generated automatically. DO NOT EDIT +#!no-fold-case +(define-module foreign.c.gauche-primitives (export hello-lol)) +(select-module foreign.c.gauche-primitives) +(dynamic-load "gauche-primitives.so") diff --git a/foreign/c/gauche-primitives.gauche.scm b/foreign/c/gauche-primitives.gauche.scm new file mode 100644 index 0000000..97ab1a1 --- /dev/null +++ b/foreign/c/gauche-primitives.gauche.scm @@ -0,0 +1,13 @@ +(in-module gauche-primitives) + +(inline-stub + (declcode "#include ") + (declcode "#include ") + + (declcode "void Scm_Init_foreign_c_gauche_primitives_internal(void) { puts(\"Hello from init\"); }") + + (declcode "ScmObj hello() { return Scm_MakeInteger(1); }") + + (define-cproc hello-lol () hello)) + + diff --git a/foreign/c/gauche-primitives.gauche.stub b/foreign/c/gauche-primitives.gauche.stub new file mode 100644 index 0000000..3a904ab --- /dev/null +++ b/foreign/c/gauche-primitives.gauche.stub @@ -0,0 +1,8 @@ +(declcode "#include ") +(declcode "#include ") + +(declcode "void Scm_Init_gauche_primitives_gauche(void) { puts(\"Hello from init\"); }") + +(declcode "extern ScmObj hello() { return Scm_MakeInteger(1); }") + +(define-cproc hello () hello) diff --git a/foreign/c/gauche-primitives.sld b/foreign/c/gauche-primitives.sld new file mode 100644 index 0000000..9be5fac --- /dev/null +++ b/foreign/c/gauche-primitives.sld @@ -0,0 +1,21 @@ +(define-library + (foreign c chibi-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (gauche base) + (foreign c primitives gauche)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (include "gauche-primitives.scm")) diff --git a/foreign/c/guile-primitives.scm b/foreign/c/guile-primitives.scm new file mode 100644 index 0000000..8498921 --- /dev/null +++ b/foreign/c/guile-primitives.scm @@ -0,0 +1,132 @@ +(define type->native-type + (lambda (type) + (cond ((equal? type 'int8) int8) + ((equal? type 'uint8) uint8) + ((equal? type 'int16) int16) + ((equal? type 'uint16) uint16) + ((equal? type 'int32) int32) + ((equal? type 'uint32) uint32) + ((equal? type 'int64) int64) + ((equal? type 'uint64) uint64) + ((equal? type 'char) int8) + ((equal? type 'unsigned-char) uint8) + ((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) '*) + ((equal? type 'void) void) + ((equal? type 'callback) '*) + (else #f)))) + +(define c-bytevector? + (lambda (object) + (pointer? object))) + +(define-syntax define-c-procedure + (syntax-rules () + ((_ scheme-name shared-object c-name return-type argument-types) + (define scheme-name + (foreign-library-function shared-object + (symbol->string c-name) + #:return-type (type->native-type return-type) + #:arg-types (map type->native-type argument-types)))))) + +(define-syntax define-c-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name + (procedure->pointer (type->native-type return-type) + procedure + (map type->native-type argument-types)))))) + +(define size-of-type + (lambda (type) + (let ((native-type (type->native-type type))) + (cond ((equal? native-type void) 0) + (native-type (sizeof native-type)) + (else #f))))) + +(define align-of-type + (lambda (type) + (let ((native-type (type->native-type type))) + (cond ((equal? native-type void) 0) + (native-type (alignof native-type)) + (else #f))))) + +(define shared-object-load + (lambda (path options) + (load-foreign-library path))) + +(define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + (let ((p (pointer->bytevector c-bytevector (+ k 100)))) + (bytevector-u8-set! p k byte)))) + +(define c-bytevector-u8-ref + (lambda (c-bytevector k) + (let ((p (pointer->bytevector c-bytevector (+ k 100)))) + (bytevector-u8-ref p k)))) + +(define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (c-bytevector-uint-set! c-bytevector + k + (pointer-address pointer) + (native-endianness) + (size-of-type 'pointer)))) + +(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (make-pointer (c-bytevector-uint-ref c-bytevector + k + (native-endianness) + (size-of-type 'pointer))))) + +#;(define pointer-set! +(lambda (pointer type offset value) + (let ((p (pointer->bytevector pointer (+ offset 100)))) + (cond ((equal? type 'int8) (bytevector-s8-set! p offset value)) + ((equal? type 'uint8) (bytevector-u8-set! p offset value)) + ((equal? type 'int16) (bytevector-s16-set! p offset value (native-endianness))) + ((equal? type 'uint16) (bytevector-u16-set! p offset value (native-endianness))) + ((equal? type 'int32) (bytevector-s32-set! p offset value (native-endianness))) + ((equal? type 'uint32) (bytevector-u32-set! p offset value (native-endianness))) + ((equal? type 'int64) (bytevector-s64-set! p offset value (native-endianness))) + ((equal? type 'uint64) (bytevector-u64-set! p offset value (native-endianness))) + ((equal? type 'char) (bytevector-s8-set! p offset (char->integer value))) + ((equal? type 'short) (bytevector-s8-set! p offset value)) + ((equal? type 'unsigned-short) (bytevector-u8-set! p offset value)) + ((equal? type 'int) (bytevector-sint-set! p offset value (native-endianness) (size-of-type type))) + ((equal? type 'unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (size-of-type type))) + ((equal? type 'long) (bytevector-s64-set! p offset value (native-endianness))) + ((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness))) + ((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness))) + ((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness))) + ((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type))))))) + +#;(define pointer-get +(lambda (pointer type offset) + (let ((p (pointer->bytevector pointer (+ offset 100)))) + (cond ((equal? type 'int8) (bytevector-s8-ref p offset)) + ((equal? type 'uint8) (bytevector-u8-ref p offset)) + ((equal? type 'int16) (bytevector-s16-ref p offset (native-endianness))) + ((equal? type 'uint16) (bytevector-u16-ref p offset (native-endianness))) + ((equal? type 'int32) (bytevector-s32-ref p offset (native-endianness))) + ((equal? type 'uint32) (bytevector-u32-ref p offset (native-endianness))) + ((equal? type 'int64) (bytevector-s64-ref p offset (native-endianness))) + ((equal? type 'uint64) (bytevector-u64-ref p offset (native-endianness))) + ((equal? type 'char) (integer->char (bytevector-s8-ref p offset))) + ((equal? type 'short) (bytevector-s8-ref p offset)) + ((equal? type 'unsigned-short) (bytevector-u8-ref p offset)) + ((equal? type 'int) (bytevector-sint-ref p offset (native-endianness) (size-of-type type))) + ((equal? type 'unsigned-int) (bytevector-uint-ref p offset (native-endianness) (size-of-type type))) + ((equal? type 'long) (bytevector-s64-ref p offset (native-endianness))) + ((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness))) + ((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness))) + ((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness))) + ((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))))))) diff --git a/foreign/c/guile-primitives.sld b/foreign/c/guile-primitives.sld new file mode 100644 index 0000000..daa22fe --- /dev/null +++ b/foreign/c/guile-primitives.sld @@ -0,0 +1,22 @@ +(define-library + (foreign c guile-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (system foreign) + (system foreign-library)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (include "c-bytevectors.scm") + (include "guile-primitives.scm")) diff --git a/foreign/c/kawa-primitives.scm b/foreign/c/kawa-primitives.scm new file mode 100644 index 0000000..dc53475 --- /dev/null +++ b/foreign/c/kawa-primitives.scm @@ -0,0 +1,209 @@ +(define arena (invoke-static java.lang.foreign.Arena 'global)) +(define method-handle-lookup (invoke-static java.lang.invoke.MethodHandles 'lookup)) +(define native-linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) +(define INTEGER-MAX-VALUE (static-field java.lang.Integer 'MAX_VALUE)) + +(define value->object + (lambda (value type) + (cond ((equal? type 'byte) + (java.lang.Byte value)) + ((equal? type 'int8) + (java.lang.Integer value)) + ((equal? type 'uint8) + (java.lang.Integer value)) + ((equal? type 'short) + (java.lang.Short value)) + ((equal? type 'unsigned-short) + (java.lang.Short value)) + ((equal? type 'int) + (java.lang.Integer value)) + ((equal? type 'unsigned-int) + (java.lang.Integer value)) + ((equal? type 'long) + (java.lang.Long value)) + ((equal? type 'unsigned-long) + (java.lang.Long value)) + ((equal? type 'float) + (java.lang.Float value)) + ((equal? type 'double) + (java.lang.Double value)) + ((equal? type 'char) + (java.lang.Char value)) + (else value)))) + +(define type->native-type + (lambda (type) + (cond + ((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 1)) + ((equal? type 'uint8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) + ((equal? type 'int16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) + ((equal? type 'uint16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) + ((equal? type 'int32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) + ((equal? type 'uint32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) + ((equal? type 'int64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) + ((equal? type 'uint64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) + ((equal? type 'char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR) 'withByteAlignment 1)) + ((equal? type 'unsigned-char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR) 'withByteAlignment 1)) + ((equal? type 'short) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT) 'withByteAlignment 2)) + ((equal? type 'unsigned-short) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT) 'withByteAlignment 2)) + ((equal? type 'int) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) + ((equal? type 'unsigned-int) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) + ((equal? type 'long) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_LONG) 'withByteAlignment 8)) + ((equal? type 'unsigned-long) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_LONG) 'withByteAlignment 8)) + ((equal? type 'float) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT) 'withByteAlignment 4)) + ((equal? type 'double) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE) 'withByteAlignment 8)) + ((equal? type 'pointer) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) + ((equal? type 'void) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1)) + ((equal? type 'callback) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) + ((equal? type 'struct) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) + (else #f)))) + +(define c-bytevector? + (lambda (object) + (string=? (invoke (invoke object 'getClass) 'getName) + "jdk.internal.foreign.NativeMemorySegmentImpl"))) + +(define-syntax define-c-procedure + (syntax-rules () + ((_ scheme-name shared-object c-name return-type argument-types) + (define scheme-name + (lambda vals + (invoke (invoke (cdr (assoc 'linker shared-object)) + 'downcallHandle + (invoke (invoke (cdr (assoc 'lookup shared-object)) + 'find + (symbol->string c-name)) + 'orElseThrow) + (if (equal? return-type 'void) + (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid) + (map type->native-type argument-types)) + (apply (class-methods java.lang.foreign.FunctionDescriptor 'of) + (type->native-type return-type) + (map type->native-type argument-types)))) + 'invokeWithArguments + (map value->object vals argument-types))))))) + +(define range + (lambda (from to) + (letrec* + ((looper + (lambda (count result) + (if (= count to) + (append result (list count)) + (looper (+ count 1) (append result (list count))))))) + (looper from (list))))) + +(define-syntax define-c-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name + (let* ((callback-procedure + (lambda (arg1 . args) + (try-catch (begin (apply procedure (append (list arg1) args))) + (ex #f)))) + (function-descriptor + (let ((function-descriptor + (if (equal? return-type 'void) + (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid) + (map type->native-type argument-types)) + (apply (class-methods java.lang.foreign.FunctionDescriptor 'of) + (type->native-type return-type) + (map type->native-type argument-types))))) + (write function-descriptor) + (newline) + (write (invoke function-descriptor 'getClass)) + (newline) + (write function-descriptor) + (newline) + function-descriptor)) + ;(method-type (invoke function-descriptor 'toMethodType)) + (method-type (field callback-procedure 'applyMethodType)) + (method-handle + (let* ((method-handle (field callback-procedure 'applyToConsumerDefault))) + (write method-handle) + (newline) + method-handle))) + (invoke native-linker 'upcallStub method-handle function-descriptor arena)))))) + +(define size-of-type + (lambda (type) + (let ((native-type (type->native-type type))) + (if native-type + (invoke native-type 'byteAlignment) + #f)))) + +(define align-of-type + (lambda (type) + (let ((native-type (type->native-type type))) + (if native-type + (invoke native-type 'byteAlignment) + #f)))) + +(define shared-object-load + (lambda (path options) + (let* ((library-file (make java.io.File path)) + (file-name (invoke library-file 'getName)) + (library-parent-folder (make java.io.File (invoke library-file 'getParent))) + (absolute-path (string-append (invoke library-parent-folder 'getCanonicalPath) + "/" + file-name)) + (linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) + (lookup (invoke-static java.lang.foreign.SymbolLookup + 'libraryLookup + absolute-path + arena))) + (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 + 1)) + +(define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + (invoke (invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE) + 'set + u8-value-layout + k + byte))) + +(define c-bytevector-u8-ref + (lambda (c-bytevector k) + (invoke (java.lang.Byte 1) + 'toUnsignedInt + (invoke + (invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE) + 'get + u8-value-layout + k)))) + +(define pointer-value-layout + (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) + 'withByteAlignment + 8)) + +(define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (invoke (invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE) + 'set + pointer-value-layout + k + pointer))) + +(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (invoke (invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE) + 'get + pointer-value-layout + k))) + +#;(define-syntax call-with-address-of-c-bytevector + (syntax-rules () + ((_ input-pointer thunk) + (let ((address-pointer (make-c-bytevector (c-type-size 'pointer)))) + (pointer-set! address-pointer 'pointer 0 input-pointer) + (apply thunk (list address-pointer)) + (set! input-pointer (pointer-get address-pointer 'pointer 0)) + (c-free address-pointer))))) diff --git a/foreign/c/kawa-primitives.sld b/foreign/c/kawa-primitives.sld new file mode 100644 index 0000000..bc95c0a --- /dev/null +++ b/foreign/c/kawa-primitives.sld @@ -0,0 +1,19 @@ +(define-library + (foreign c kawa-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (include "kawa-primitives.scm")) diff --git a/foreign/c/larceny-primitives.scm b/foreign/c/larceny-primitives.scm new file mode 100644 index 0000000..a0d4c9e --- /dev/null +++ b/foreign/c/larceny-primitives.scm @@ -0,0 +1,76 @@ +(require 'std-ffi) +(require 'ffi-load) +(require 'foreign-ctools) +(require 'foreign-cenums) +(require 'foreign-stdlib) +(require 'foreign-sugar) +(require 'system-interface) + +;; FIXME +(define size-of-type + (lambda (type) + (cond ((eq? type 'int8) 1) + ((eq? type 'uint8) 1) + ((eq? type 'int16) 2) + ((eq? type 'uint16) 2) + ((eq? type 'int32) 4) + ((eq? type 'uint32) 4) + ((eq? type 'int64) 8) + ((eq? type 'uint64) 8) + ((eq? type 'char) 1) + ((eq? type 'unsigned-char) 1) + ((eq? type 'short) 2) + ((eq? type 'unsigned-short) 2) + ((eq? type 'int) 4) + ((eq? type 'unsigned-int) 4) + ((eq? type 'long) 4) + ((eq? type 'unsigned-long) 4) + ((eq? type 'float) 4) + ((eq? type 'double) 8) + ((eq? type 'pointer) sizeof:pointer) + ((eq? type 'void) 0) + ((eq? type 'callback) sizeof:pointer) + (else (error "Can not get size of unknown type" type))))) + +(define c-bytevector? + (lambda (object) + ;(void*? object) + (number? object))) + +(define shared-object-load + (lambda (headers path . options) + (foreign-file path))) + +(define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + (syscall syscall:poke-bytes c-bytevector k (c-type-size 'uint8) byte))) + +(define c-bytevector-u8-ref + (lambda (c-bytevector k) + (syscall syscall:peek-bytes c-bytevector k (c-type-size 'uint8)))) + +(define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (syscall syscall:poke-bytes c-bytevector k (c-type-size 'pointer) pointer))) + +(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (syscall syscall:peek-bytes c-bytevector k (c-type-size 'pointer)))) + +(define-syntax define-c-procedure + (syntax-rules () + ((_ scheme-name shared-object c-name return-type argument-types) + (define scheme-name + 0 + + #;(make-c-function shared-object + (symbol->string c-name) + return-type + argument-types))))) + +(define-syntax define-c-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name + 0 + #;(make-c-callback return-type argument-types procedure))))) diff --git a/foreign/c/larceny-primitives.sld b/foreign/c/larceny-primitives.sld new file mode 100644 index 0000000..495d962 --- /dev/null +++ b/foreign/c/larceny-primitives.sld @@ -0,0 +1,25 @@ +(define-library + (foreign c larceny-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (rename (primitives r5rs:require) (r5rs:require require)) + (primitives std-ffi) + (primitives foreign-procedure) + (primitives foreign-file) + (primitives foreign-stdlib) + (primitives system-interface)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (include "larceny-primitives.scm")) diff --git a/foreign/c/mit-scheme-primitives.scm b/foreign/c/mit-scheme-primitives.scm new file mode 100644 index 0000000..3d336a8 --- /dev/null +++ b/foreign/c/mit-scheme-primitives.scm @@ -0,0 +1,12 @@ +(declare (usual-integrations)) +(load-option 'ffi) + +;(define lib (dld-load-file "mit-scheme-foreign-c-shim.so")) +(C-include "mit-scheme-foreign-c") + +(define (hello) + (puts "Hello from puts") + ;(display "Not from puts") + (newline) + ) +;(C-call "puts" "Hello world") diff --git a/foreign/c/mit-scheme-primitives.sld b/foreign/c/mit-scheme-primitives.sld new file mode 100644 index 0000000..bdd672f --- /dev/null +++ b/foreign/c/mit-scheme-primitives.sld @@ -0,0 +1,19 @@ +(define-library + (foreign c mit-scheme-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (include "mit-scheme-primitives.scm")) diff --git a/foreign/c/mosh-primitives.scm b/foreign/c/mosh-primitives.scm new file mode 100644 index 0000000..b34099c --- /dev/null +++ b/foreign/c/mosh-primitives.scm @@ -0,0 +1,108 @@ +(define size-of-type + (lambda (type) + (cond ((eq? type 'int8) 1) + ((eq? type 'uint8) 1) + ((eq? type 'int16) 2) + ((eq? type 'uint16) 2) + ((eq? type 'int32) 4) + ((eq? type 'uint32) 4) + ((eq? type 'int64) 8) + ((eq? type 'uint64) 8) + ((eq? type 'char) 1) + ((eq? type 'unsigned-char) 1) + ((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-pointer) + ((eq? type 'callback) size-of-pointer) + ((eq? type 'void) 0) + (else #f)))) + +(define align-of-type + (lambda (type) + (cond ((eq? type 'int8) 1) + ((eq? type 'uint8) 1) + ((eq? type 'int16) 2) + ((eq? type 'uint16) 2) + ((eq? type 'int32) 4) + ((eq? type 'uint32) 4) + ((eq? type 'int64) 8) + ((eq? type 'uint64) 8) + ((eq? type 'char) 1) + ((eq? type 'unsigned-char) 1) + ((eq? type 'short) align-of-short) + ((eq? type 'unsigned-short) align-of-short) + ((eq? type 'int) align-of-int) + ((eq? type 'unsigned-int) align-of-int) + ((eq? type 'long) align-of-long) + ((eq? type 'unsigned-long) align-of-unsigned-long) + ((eq? type 'float) align-of-float) + ((eq? type 'double) align-of-double) + ((eq? type 'pointer) align-of-void*) + ((eq? type 'callback) align-of-void*) + ((eq? type 'void) 0) + (else #f)))) + +(define shared-object-load + (lambda (path options) + (open-shared-library path))) + +(define c-bytevector? + (lambda (object) + (pointer? object))) + +(define c-bytevector-u8-set! pointer-set-c-uint8!) +(define c-bytevector-u8-ref pointer-ref-c-uint8) +(define c-bytevector-pointer-set! + (lambda (pointer offset value) + (pointer-set-c-pointer! pointer offset value))) +(define c-bytevector-pointer-ref + (lambda (pointer offset) + (pointer-ref-c-pointer pointer offset))) + +(define type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'int8_t) + ((equal? type 'uint8) 'uint8_t) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32_t) + ((equal? type 'uint32) 'uint32_t) + ((equal? type 'int64) 'int64_t) + ((equal? type 'uint64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) '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) 'void*) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'void*) + (else (error "type->native-type -- No such type" type))))) + +(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 + (type->native-type return-type) + c-name + (map type->native-type argument-types)))))) + +(define-syntax define-c-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name + (make-c-callback (type->native-type return-type) + (map type->native-type argument-types) + procedure))))) diff --git a/foreign/c/mosh-primitives.sld b/foreign/c/mosh-primitives.sld new file mode 100644 index 0000000..8c1fc40 --- /dev/null +++ b/foreign/c/mosh-primitives.sld @@ -0,0 +1,21 @@ +(define-library + (foreign c mosh-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme inexact) + (scheme process-context) + (mosh ffi)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (include "mosh-primitives.scm")) diff --git a/foreign/c/racket-primitives.scm b/foreign/c/racket-primitives.scm new file mode 100644 index 0000000..f67a5b1 --- /dev/null +++ b/foreign/c/racket-primitives.scm @@ -0,0 +1,88 @@ +(define type->native-type + (lambda (type) + (cond ((equal? type 'int8) _byte) + ((equal? type 'uint8) _ubyte) + ((equal? type 'int16) _int16) + ((equal? type 'uint16) _uint16) + ((equal? type 'int32) _int32) + ((equal? type 'uint32) _uint32) + ((equal? type 'int64) _int64) + ((equal? type 'uint64) _uint64) + ((equal? type 'char) _int8) + ((equal? type 'unsigned-char) _uint8) + ((equal? type 'short) _short) + ((equal? type 'unsigned-short) _ushort) + ((equal? type 'int) _int) + ((equal? type 'unsigned-int) _uint) + ((equal? type 'long) _long) + ((equal? type 'unsigned-long) _ulong) + ((equal? type 'float) _float) + ((equal? type 'double) _double) + ((equal? type 'pointer) _pointer) + ((equal? type 'void) _void) + ((equal? type 'callback) _pointer) + (else #f)))) + +(define c-bytevector? + (lambda (object) + (cpointer? object))) + +(define-syntax define-c-procedure + (syntax-rules () + ((_ scheme-name shared-object c-name return-type argument-types) + (define scheme-name + (get-ffi-obj c-name + shared-object + (_cprocedure (mlist->list (map type->native-type argument-types)) + (type->native-type return-type))))))) + +(define-syntax define-c-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name (function-ptr procedure + (_cprocedure + (mlist->list (map type->native-type argument-types)) + (type->native-type return-type))))))) + +(define size-of-type + (lambda (type) + (ctype-sizeof (type->native-type type)))) + +;; FIXME +(define align-of-type + (lambda (type) + (ctype-sizeof (type->native-type type)))) + +(define shared-object-load + (lambda (path options) + (if (and (not (null? options)) + (assoc 'additional-versions options)) + (ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions + options)) + (list #f)))) + (ffi-lib path)))) + +(define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + (ptr-set! c-bytevector _uint8 'abs k byte))) + +(define c-bytevector-u8-ref + (lambda (c-bytevector k) + (ptr-ref c-bytevector _uint8 'abs k))) + +(define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (ptr-set! c-bytevector _pointer 'abs k pointer))) + +(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (ptr-ref c-bytevector _pointer 'abs k))) + +#;(define-syntax call-with-address-of-c-bytevector + (syntax-rules () + ((_ input-pointer thunk) + (let ((address-pointer (make-c-bytevector (c-type-size 'pointer)))) + (c-bytevector-pointer-set! address-pointer 0 input-pointer) + (apply thunk (list address-pointer)) + (set! input-pointer (c-bytevector-pointer-ref address-pointer 0)) + (c-free address-pointer))))) diff --git a/foreign/c/racket-primitives.sld b/foreign/c/racket-primitives.sld new file mode 100644 index 0000000..f519ed1 --- /dev/null +++ b/foreign/c/racket-primitives.sld @@ -0,0 +1,29 @@ +(define-library + (foreign c racket-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (only (racket base) + system-type + system-big-endian?) + (ffi winapi) + (compatibility mlist) + (ffi unsafe) + (ffi vector)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + ;; Racket specific + system-big-endian? + ) + (include "racket-primitives.scm")) diff --git a/foreign/c/sagittarius-primitives.scm b/foreign/c/sagittarius-primitives.scm new file mode 100644 index 0000000..aa9be93 --- /dev/null +++ b/foreign/c/sagittarius-primitives.scm @@ -0,0 +1,149 @@ +(define size-of-type + (lambda (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*) + ((eq? type 'void) 0) + ((eq? type 'callback) size-of-void*) + (else #f)))) + +(define align-of-type + (lambda (type) + (cond ((eq? type 'int8) align-of-int8_t) + ((eq? type 'uint8) align-of-uint8_t) + ((eq? type 'int16) align-of-int16_t) + ((eq? type 'uint16) align-of-uint16_t) + ((eq? type 'int32) align-of-int32_t) + ((eq? type 'uint32) align-of-uint32_t) + ((eq? type 'int64) align-of-int64_t) + ((eq? type 'uint64) align-of-uint64_t) + ((eq? type 'char) align-of-char) + ((eq? type 'unsigned-char) align-of-char) + ((eq? type 'short) align-of-short) + ((eq? type 'unsigned-short) align-of-unsigned-short) + ((eq? type 'int) align-of-int) + ((eq? type 'unsigned-int) align-of-unsigned-int) + ((eq? type 'long) align-of-long) + ((eq? type 'unsigned-long) align-of-unsigned-long) + ((eq? type 'float) align-of-float) + ((eq? type 'double) align-of-double) + ((eq? type 'pointer) align-of-void*) + ((eq? type 'void) 0) + ((eq? type 'callback) align-of-void*) + (else #f)))) + +(define shared-object-load + (lambda (path options) + (open-shared-library path))) + +(define type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'int8_t) + ((equal? type 'uint8) 'uint8_t) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32_t) + ((equal? type 'uint32) 'uint32_t) + ((equal? type 'int64) 'int64_t) + ((equal? type 'uint64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) '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) 'void*) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'callback) + (else #f)))) + +(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 + (type->native-type return-type) + c-name + (map type->native-type argument-types)))))) + +(define-syntax define-c-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name + (make-c-callback (type->native-type return-type) + (map type->native-type argument-types) + procedure))))) + +(define c-bytevector? + (lambda (object) + (pointer? object))) + +(define c-bytevector-u8-set! pointer-set-c-uint8_t!) +(define c-bytevector-u8-ref pointer-ref-c-uint8_t) +(define c-bytevector-pointer-set! pointer-set-c-pointer!) +(define c-bytevector-pointer-ref pointer-ref-c-pointer) + +#;(define pointer-set! + (lambda (pointer type offset value) + (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value)) + ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value)) + ((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value)) + ((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value)) + ((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value)) + ((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value)) + ((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value)) + ((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value)) + ((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value))) + ((equal? type 'short) (pointer-set-c-short! pointer offset value)) + ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value)) + ((equal? type 'int) (pointer-set-c-int! pointer offset value)) + ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value)) + ((equal? type 'long) (pointer-set-c-long! pointer offset value)) + ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value)) + ((equal? type 'float) (pointer-set-c-float! pointer offset value)) + ((equal? type 'double) (pointer-set-c-double! pointer offset value)) + ((equal? type 'void) (pointer-set-c-pointer! pointer offset value)) + ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) + +#;(define pointer-get + (lambda (pointer type offset) + (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset)) + ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset)) + ((equal? type 'int16) (pointer-ref-c-int16_t pointer offset)) + ((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset)) + ((equal? type 'int32) (pointer-ref-c-int32_t pointer offset)) + ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset)) + ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset)) + ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset)) + ((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset))) + ((equal? type 'short) (pointer-ref-c-short pointer offset)) + ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset)) + ((equal? type 'int) (pointer-ref-c-int pointer offset)) + ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset)) + ((equal? type 'long) (pointer-ref-c-long pointer offset)) + ((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset)) + ((equal? type 'float) (pointer-ref-c-float pointer offset)) + ((equal? type 'double) (pointer-ref-c-double pointer offset)) + ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) + ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) + diff --git a/foreign/c/sagittarius-primitives.sld b/foreign/c/sagittarius-primitives.sld new file mode 100644 index 0000000..bad9947 --- /dev/null +++ b/foreign/c/sagittarius-primitives.sld @@ -0,0 +1,21 @@ +(define-library + (foreign c sagittarius-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (except (sagittarius ffi) c-free c-malloc define-c-struct) + (sagittarius)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (include "sagittarius-primitives.scm")) diff --git a/foreign/c/stklos-primitives.scm b/foreign/c/stklos-primitives.scm new file mode 100644 index 0000000..a64b762 --- /dev/null +++ b/foreign/c/stklos-primitives.scm @@ -0,0 +1,122 @@ +(define type->native-type + (lambda (type) + (cond ((equal? type 'int8) :char) + ((equal? type 'uint8) :char) + ((equal? type 'int16) :short) + ((equal? type 'uint16) :ushort) + ((equal? type 'int32) :int) + ((equal? type 'uint32) :uint) + ((equal? type 'int64) :long) + ((equal? type 'uint64) :ulong) + ((equal? type 'char) :char) + ((equal? type 'unsigned-char) :uchar) + ((equal? type 'short) :short) + ((equal? type 'unsigned-short) :ushort) + ((equal? type 'int) :int) + ((equal? type 'unsigned-int) :uint) + ((equal? type 'long) :long) + ((equal? type 'unsigned-long) :ulong) + ((equal? type 'float) :float) + ((equal? type 'double) :double) + ((equal? type 'pointer) :pointer) + ((equal? type 'void) :void) + ((equal? type 'callback) :pointer) + (else (error "type->native-type -- No such pffi type" type))))) + +(define c-bytevector? + (lambda (object) + (and (not (void? object)) + (cpointer? object)))) + +(define-syntax define-c-procedure + (syntax-rules () + ((_ scheme-name shared-object c-name return-type argument-types) + (begin + (define type->native-type + (lambda (type) + (cond ((equal? type 'int8) :char) + ((equal? type 'uint8) :char) + ((equal? type 'int16) :short) + ((equal? type 'uint16) :ushort) + ((equal? type 'int32) :int) + ((equal? type 'uint32) :uint) + ((equal? type 'int64) :long) + ((equal? type 'uint64) :ulong) + ((equal? type 'char) :char) + ((equal? type 'unsigned-char) :char) + ((equal? type 'short) :short) + ((equal? type 'unsigned-short) :ushort) + ((equal? type 'int) :int) + ((equal? type 'unsigned-int) :uint) + ((equal? type 'long) :long) + ((equal? type 'unsigned-long) :ulong) + ((equal? type 'float) :float) + ((equal? type 'double) :double) + ((equal? type 'pointer) :pointer) + ((equal? type 'void) :void) + ((equal? type 'callback) :pointer) + (else (error "type->native-type -- No such pffi type" type))))) + (define scheme-name + (make-external-function + (symbol->string c-name) + (map type->native-type argument-types) + (type->native-type return-type) + shared-object)))))) + +(define-syntax define-c-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name + (%make-callback procedure + (map type->native-type argument-types) + (type->native-type return-type)))))) + +(define size-of-type + (lambda (type) + (cond ((equal? type 'int8) (c-size-of :int8)) + ((equal? type 'uint8) (c-size-of :uint8)) + ((equal? type 'int16) (c-size-of :int16)) + ((equal? type 'uint16) (c-size-of :uint16)) + ((equal? type 'int32) (c-size-of :int32)) + ((equal? type 'uint32) (c-size-of :uint32)) + ((equal? type 'int64) (c-size-of :int64)) + ((equal? type 'uint64) (c-size-of :uint64)) + ((equal? type 'char) (c-size-of :char)) + ((equal? type 'unsigned-char) (c-size-of :uchar)) + ((equal? type 'short) (c-size-of :short)) + ((equal? type 'unsigned-short) (c-size-of :ushort)) + ((equal? type 'int) (c-size-of :int)) + ((equal? type 'unsigned-int) (c-size-of :uint)) + ((equal? type 'long) (c-size-of :long)) + ((equal? type 'unsigned-long) (c-size-of :ulong)) + ((equal? type 'float) (c-size-of :float)) + ((equal? type 'double) (c-size-of :double)) + ((equal? type 'pointer) (c-size-of :pointer))))) + +;; FIXME +(define align-of-type + (lambda (type) + (size-of-type type))) + +(define c-bytevector-u8-set! + (lambda (pointer offset value) + (cpointer-set-abs! pointer :uint8 value offset))) + +(define c-bytevector-u8-ref + (lambda (pointer offset) + (cpointer-ref-abs pointer :uint8 offset))) + +(define c-bytevector-pointer-set! + (lambda (pointer offset value) + (cpointer-set-abs! pointer :pointer value offset))) + +(define c-bytevector-pointer-ref + (lambda (pointer offset) + (cpointer-ref-abs pointer :pointer offset))) + +#;(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (address->c-bytevector (c-bytevector-uint-ref c-bytevector + 0 + (native-endianness) + (size-of-type 'pointer))))) diff --git a/foreign/c/stklos-primitives.sld b/foreign/c/stklos-primitives.sld new file mode 100644 index 0000000..a3c4494 --- /dev/null +++ b/foreign/c/stklos-primitives.sld @@ -0,0 +1,45 @@ +(define-library + (foreign c stklos-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (only (stklos) + %make-callback + make-external-function + allocate-bytes + free-bytes + cpointer? + cpointer-null? + cpointer-data + cpointer-data-set! + cpointer-set-abs! + cpointer-ref-abs + c-size-of + void?)) + (export size-of-type + align-of-type + ;shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + ;; STklos specific + ; calculate-struct-size-and-offsets + ;struct-make + get-environment-variable + file-exists? + make-external-function + ;address->c-bytevector + foreign-c:string-split + ;c-bytevector-pointer-set! + ;c-bytevector-pointer-ref + void? + ) + (include "c-bytevectors.scm") + (include "stklos-primitives.scm")) diff --git a/foreign/c/struct.sld b/foreign/c/struct.sld new file mode 100644 index 0000000..8bd1f8a --- /dev/null +++ b/foreign/c/struct.sld @@ -0,0 +1,17 @@ +(define-library + (foreign c struct) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context)) + (export define-c-struct + c-struct->alist + ;pffi-define-struct;define-c-struct + ;pffi-struct-pointer;c-struct-bytevector + ;pffi-struct-offset-get;c-struct-offset + ;pffi-struct-set!;c-struct-set! + ;pffi-struct-get;c-struct-get + ) + (include "struct.scm")) diff --git a/foreign/c/ypsilon-primitives.scm b/foreign/c/ypsilon-primitives.scm new file mode 100644 index 0000000..df8d33a --- /dev/null +++ b/foreign/c/ypsilon-primitives.scm @@ -0,0 +1,149 @@ +(define size-of-type + (lambda (type) + (cond ((eq? type 'int8) (c-sizeof int8_t)) + ((eq? type 'uint8) (c-sizeof uint8_t)) + ((eq? type 'int16) (c-sizeof int16_t)) + ((eq? type 'uint16) (c-sizeof uint16_t)) + ((eq? type 'int32) (c-sizeof int32_t)) + ((eq? type 'uint32) (c-sizeof uint32_t)) + ((eq? type 'int64) (c-sizeof int64_t)) + ((eq? type 'uint64) (c-sizeof uint64_t)) + ((eq? type 'char) (c-sizeof char)) + ((eq? type 'unsigned-char) (c-sizeof char)) + ((eq? type 'short) (c-sizeof short)) + ((eq? type 'unsigned-short) (c-sizeof unsigned-short)) + ((eq? type 'int) (c-sizeof int)) + ((eq? type 'unsigned-int) (c-sizeof unsigned-int)) + ((eq? type 'long) (c-sizeof long)) + ((eq? type 'unsigned-long) (c-sizeof unsigned-long)) + ((eq? type 'float) (c-sizeof float)) + ((eq? type 'double) (c-sizeof double)) + ((eq? type 'pointer) (c-sizeof void*)) + ((eq? type 'callback) (c-sizeof void*)) + ((eq? type 'void) 0) + (else #f)))) + +(define align-of-type + (lambda (type) + (cond ((eq? type 'int8) (alignof:int8_t)) + ((eq? type 'uint8) (alignof:int8_t)) + ((eq? type 'int16) (alignof:int16_t)) + ((eq? type 'uint16) (alignof:int16_t)) + ((eq? type 'int32) (alignof:int32_t)) + ((eq? type 'uint32) (alignof:int32_t)) + ((eq? type 'int64) (alignof:int64_t)) + ((eq? type 'uint64) (alignof:int64_t)) + ((eq? type 'char) (alignof:int8_t)) + ((eq? type 'unsigned-char) (alignof:int8_t)) + ((eq? type 'short) (alignof:short)) + ((eq? type 'unsigned-short) (alignof:short)) + ((eq? type 'int) (alignof:int)) + ((eq? type 'unsigned-int) (alignof:int)) + ((eq? type 'long) (alignof:long)) + ((eq? type 'unsigned-long) (alignof:long)) + ((eq? type 'float) (alignof:float)) + ((eq? type 'double) (alignof:double)) + ((eq? type 'pointer) (alignof:void*)) + ((eq? type 'callback) (alignof:void*)) + ((eq? type 'void) 0) + (else #f)))) + +(define c-bytevector? + (lambda (object) + (number? object))) + +(define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + ;; Ypsilon for some reason does not have bytevector-c-uint8-set! + ;; or other bytevector-c-u*-set! procedures so we use + ;; bytevector-c-int8-set! + (bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k) + (size-of-type 'uint8)) + 0 + byte))) + +(define c-bytevector-u8-ref + (lambda (c-bytevector k) + (bytevector-c-uint8-ref (make-bytevector-mapping (+ c-bytevector k) + (size-of-type 'uint8)) + 0))) + +(define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (bytevector-c-void*-set! (make-bytevector-mapping (+ c-bytevector k) + (size-of-type 'pointer)) + 0 + pointer))) + +(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (bytevector-c-void*-ref (make-bytevector-mapping (+ c-bytevector k) + (size-of-type 'pointer)) + 0))) + +(define shared-object-load + (lambda (path options) + (load-shared-object path))) + +(define-macro + (define-c-procedure scheme-name shared-object c-name return-type argument-types) + (begin + (let ((type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'int8_t) + ((equal? type 'uint8) 'uint8_t) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32_t) + ((equal? type 'uint32) 'uint32_t) + ((equal? type 'int64) 'int64_t) + ((equal? type 'uint64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) '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) 'void*) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'void*) + (else (error "type->native-type -- No such type" type)))))) + `(define ,scheme-name + (c-function ,(type->native-type (cadr return-type)) + ,(cadr c-name) + ,(map type->native-type (cadr argument-types))))))) + +(define-macro + (define-c-callback scheme-name return-type argument-types procedure) + (let* ((type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'int8_t) + ((equal? type 'uint8) 'uint8_t) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32_t) + ((equal? type 'uint32) 'uint32_t) + ((equal? type 'int64) 'int64_t) + ((equal? type 'uint64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) '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) 'void*) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'void*) + (else (error "type->native-type -- No such type" type))))) + (native-return-type (type->native-type (cadr return-type))) + (native-argument-types (map type->native-type (cadr argument-types)))) + `(define ,scheme-name + (c-callback ,native-return-type ,native-argument-types ,procedure)))) diff --git a/foreign/c/ypsilon-primitives.sld b/foreign/c/ypsilon-primitives.sld new file mode 100644 index 0000000..5f2ad8a --- /dev/null +++ b/foreign/c/ypsilon-primitives.sld @@ -0,0 +1,31 @@ +(define-library + (foreign c ypsilon-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (ypsilon c-ffi) + (ypsilon c-types) + (only (core) + define-macro + syntax-case + bytevector-c-int8-set! + bytevector-c-uint8-ref)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + ;; Ypsilon specific + c-function + c-callback + bytevector-c-int8-set! + bytevector-c-uint8-ref) + (include "ypsilon-primitives.scm")) diff --git a/kawa.jar b/kawa.jar deleted file mode 100644 index 31e7afc..0000000 Binary files a/kawa.jar and /dev/null differ diff --git a/primitives b/primitives deleted file mode 100755 index 9a15c4f..0000000 --- a/primitives +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -ypsilon --r7rs --mute --quiet --sitelib=. --top-level-program primitives.scm "$@" diff --git a/test.scm b/test.scm index dc7d776..4cc961b 100644 --- a/test.scm +++ b/test.scm @@ -1,11 +1,147 @@ (import (scheme base) (scheme write) - (foreign c) - (srfi 64)) + (scheme read) + (scheme char) + (scheme file) + (scheme process-context) + (srfi 64) + (foreign c)) -(test-begin "Foreign-c") +(test-begin "foreign-c") -(test-assert (number? (c-type-size 'int8))) -(test-assert(= (c-type-size 'int8) 1)) +(define-c-library libc + '("stdlib.h" "stdio.h" "string.h") + libc-name + '((additional-versions ("0" "6")))) -(test-end "Foreign-c") +(test-assert libc) + +;; c-type-size + +(test-begin "c-type-size") + +(test-eq (c-type-size 'int8) 1) +(test-eq (c-type-size 'uint8) 1) +(test-eq (c-type-size 'int16) 2) +(test-eq (c-type-size 'uint16) 2) +(test-eq (c-type-size 'int32) 4) +(test-eq (c-type-size 'uint32) 4) +(test-eq (c-type-size 'int64) 8) +(test-eq (c-type-size 'uint64) 8) +(test-eq (c-type-size 'char) 1) +(test-eq (c-type-size 'unsigned-char) 1) +(test-eq (c-type-size 'short) 2) +(test-eq (c-type-size 'unsigned-short) 2) +(test-eq (c-type-size 'int) 4) +(test-eq (c-type-size 'unsigned-int) 4) + +(cond-expand + (i386 (test-eq (c-type-size 'long) 4)) + (else (test-eq (c-type-size 'long) 8))) + +(cond-expand + (i386 (test-eq (c-type-size 'unsigned-long) 4)) + (else (test-eq (c-type-size 'unsigned-long) 8))) + +(test-eq (c-type-size 'float) 4) +(test-eq (c-type-size 'double) 8) + +(cond-expand + (i386 (test-eq (c-type-size 'pointer) 4)) + (else (test-eq (c-type-size 'pointer) 8))) + +(test-end "c-type-size") + +(test-begin "define-c-library") + +(define-c-library c-testlib + '("libtest.h") + "test" + '((additional-paths ("." "./tests")))) + +(define-c-procedure c-abs libc 'abs 'int '(int)) +(test-eq (c-abs -2) 2) + +(define-c-procedure c-takes-no-args c-testlib 'takes_no_args 'void '()) +(c-takes-no-args) + +(define-c-procedure c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int '()) +(define takes-no-args-returns-int-result (c-takes-no-args-returns-int)) +(test-eq takes-no-args-returns-int-result 0) + +(test-end "define-c-library") + +(test-begin "make-c-bytevector and c-bytevector?") +(define bytes (make-c-bytevector 100)) +(test-assert (c-bytevector? bytes)) + +(define is-pointer (make-c-bytevector 100)) +(test-assert (c-bytevector? is-pointer)) +(test-assert (c-bytevector? 100)) +(test-assert (c-bytevector? #f)) +(test-assert (not (c-bytevector? "Hello"))) +(test-assert (not (c-bytevector? 'bar))) + +(test-end "make-c-bytevector and c-bytevector?") + +(test-begin "c-bytevector-u8-set! and c-bytevector-u8-ref") + +(define u8-pointer (make-c-bytevector (c-type-size 'uint8))) +(test-assert (c-bytevector? u8-pointer)) +(c-bytevector-u8-set! u8-pointer 0 42) +(test-eq (c-bytevector-u8-ref u8-pointer 0) 42) + +(test-end "c-bytevector-u8-set! and c-bytevector-u8-ref") + + +(test-begin "c-bytevector-pointer-set! and c-bytevector-pointer-ref") + +(define p-pointer (make-c-bytevector (c-type-size 'pointer))) +(test-assert (c-bytevector? p-pointer)) +(c-bytevector-pointer-set! p-pointer 0 u8-pointer) +(test-eq (c-bytevector-u8-ref (c-bytevector-pointer-ref p-pointer 0) 0) 42) + +(test-end "c-bytevector-pointer-set! and c-bytevector-pointer-ref") + +(test-begin "string->c-utf8 c-utf8->string") +(for-each + (lambda (str) + (let ((utf-eight (string->c-utf8 str))) + (let ((str1 (c-utf8->string utf-eight))) + (test-assert (string=? str1 str))))) + (list "100" "Hello world" "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")) +(test-end "string->c-utf8 c-utf8->string") + +(test-begin "define-c-procedure") + +(define-c-procedure c-atoi libc 'atoi 'int '(pointer)) +(test-eq (c-atoi (string->c-utf8 "100")) 100) + +(define-c-procedure c-puts libc 'puts 'int '(pointer)) +(define chars-written (c-puts (string->c-utf8 "puts: Hello from testing, I am C function puts"))) +(test-eq chars-written 47) + +(define-c-procedure c-strcat libc 'strcat 'pointer '(pointer pointer)) +(define c-string1 (string->c-utf8 "test123")) +(test-assert (string=? (c-utf8->string (c-strcat (string->c-utf8 "con2") + (string->c-utf8 "cat2"))) + "con2cat2")) + +(when (file-exists? "testfile.test") (delete-file "testfile.test")) +(define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer)) +(define output-file (c-fopen (string->c-utf8 "testfile.test") + (string->c-utf8 "w"))) +(define-c-procedure c-fprintf libc 'fprintf 'int '(pointer pointer int)) +(define characters-written (c-fprintf output-file (string->c-utf8 "Hello world %i") 1)) +(test-eq characters-written 13) +(define-c-procedure c-fclose libc 'fclose 'int '(pointer)) +(define closed-status (c-fclose output-file)) +(test-eq closed-status 0) +(test-assert (file-exists? "testfile.test")) +(define file-content (with-input-from-file "testfile.test" + (lambda () (read-line)))) +(test-assert (string=? file-content "Hello world 1")) + +(test-end "define-c-procedure") + +(test-end "foreign-c") diff --git a/tests/c-src/libtest.c b/tests/c-src/libtest.c index 35c71df..31362a3 100644 --- a/tests/c-src/libtest.c +++ b/tests/c-src/libtest.c @@ -41,6 +41,11 @@ struct test { float n; }; + +void Scm_hello() { + printf("Hello from Scm_hello"); +} + void print_string_pointer(char* p) { printf("C print_string_pointer: %s\n", p); }