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

Working on a restructuring

This commit is contained in:
retropikzel 2025-10-17 07:20:24 +03:00
parent c2c1747444
commit b39e530f05
96 changed files with 5230 additions and 372 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
Jenkinsfile vendored
View File

@ -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"
}
}

156
Makefile
View File

@ -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 "<pre>$$(cat README.md)</pre>" > 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 "<pre>$$(cat README.md)</pre>" > 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 <stdio.h>\n#include <ffi.h>\") " | ${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 <stdio.h>\n#include <ffi.h>\")" | ${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 <stdio.h>\n#include <ffi.h>\")" \
--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

0
OLD_README.md → OLD/OLD_README.md
View File

0
VERSION → OLD/VERSION
View File

43
OLD/c-mit-scheme.sld Normal file
View File

@ -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")
)

0
foreign/c/c-types.scm → OLD/c-types.scm
View File

0
documentation/foreign-c.html → OLD/documentation/foreign-c.html
View File

6
foreign/c/primitives/gauche/foreign-c-primitives-gauche.c → OLD/gauche-old/gauche-primitives.c
View File

@ -6,7 +6,7 @@
#include <gauche/load.h>
#include <gauche/number.h>
#include <gauche/string.h>
#include <foreign-c-primitives-gauche.h>
#include <gauche-primitives.h>
#include <ffi.h>
#include <dlfcn.h>
@ -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();
}

6
OLD/gauche-old/gauche-primitives.gauche.c Normal file
View File

@ -0,0 +1,6 @@
#include <stdio.h>
int lol() {
return 1;
}

2
foreign/c/primitives/gauche/foreign-c-primitives-gauche.h → OLD/gauche-old/gauche-primitives.h
View File

@ -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);

5
OLD/gauche-old/gauche-primitives.sci Normal file
View File

@ -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")

143
OLD/gauche-old/gauche-primitives.scm Normal file
View File

@ -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::<string> options) shared_object_load)
;(define-cproc pointer-null () pointer_null)
(define-cproc pointer-null? (pointer) is_pointer_null)
;(define-cproc pointer-allocate (size::<int>) 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::<int> value::<int8>) pointer_set_int8)
(define-cproc pointer-set-uint8! (pointer offset::<int> value::<uint8>) pointer_set_uint8)
;(define-cproc pointer-set-int16! (pointer offset::<int> value::<int16>) pointer_set_int16)
;(define-cproc pointer-set-uint16! (pointer offset::<int> value::<int16>) pointer_set_uint16)
;(define-cproc pointer-set-int32! (pointer offset::<int> value::<int32>) pointer_set_int32)
;(define-cproc pointer-set-uint32! (pointer offset::<int> value::<int32>) pointer_set_uint32)
;(define-cproc pointer-set-int64! (pointer offset::<int> value::<int64>) pointer_set_int64)
;(define-cproc pointer-set-uint64! (pointer offset::<int> value::<int64>) pointer_set_uint64)
;(define-cproc pointer-set-char! (pointer offset::<int> value::<char>) pointer_set_char)
;(define-cproc pointer-set-unsigned-char! (pointer offset::<int> value::<char>) pointer_set_unsigned_char)
;(define-cproc pointer-set-short! (pointer offset::<int> value::<short>) pointer_set_short)
;(define-cproc pointer-set-unsigned-short! (pointer offset::<int> value::<short>) pointer_set_unsigned_short)
;(define-cproc pointer-set-int! (pointer offset::<int> value::<int>) pointer_set_int)
;(define-cproc pointer-set-unsigned-int! (pointer offset::<int> value::<int>) pointer_set_unsigned_int)
;(define-cproc pointer-set-long! (pointer offset::<int> value::<long>) pointer_set_long)
;(define-cproc pointer-set-unsigned-long! (pointer offset::<int> value::<long>) pointer_set_unsigned_long)
;(define-cproc pointer-set-float! (pointer offset::<int> value::<float>) pointer_set_float)
;(define-cproc pointer-set-double! (pointer offset::<int> value::<double>) pointer_set_double)
(define-cproc pointer-set-pointer! (pointer offset::<int> value) pointer_set_pointer)
;(define-cproc pointer-get-int8 (pointer offset::<int>) pointer_get_int8)
(define-cproc pointer-get-uint8 (pointer offset::<int>) pointer_get_uint8)
;(define-cproc pointer-get-int16 (pointer offset::<int>) pointer_get_int16)
;(define-cproc pointer-get-uint16 (pointer offset::<int>) pointer_get_uint16)
;(define-cproc pointer-get-int32 (pointer offset::<int>) pointer_get_int32)
;(define-cproc pointer-get-uint32 (pointer offset::<int>) pointer_get_uint32)
;(define-cproc pointer-get-int64 (pointer offset::<int>) pointer_get_int64)
;(define-cproc pointer-get-uint64 (pointer offset::<int>) pointer_get_uint64)
;(define-cproc pointer-get-char (pointer offset::<int>) pointer_get_char)
;(define-cproc pointer-get-unsigned-char (pointer offset::<int>) pointer_get_unsigned_char)
;(define-cproc pointer-get-short (pointer offset::<int>) pointer_get_short)
;(define-cproc pointer-get-unsigned-short (pointer offset::<int>) pointer_get_unsigned_short)
;(define-cproc pointer-get-int (pointer offset::<int>) pointer_get_int)
;(define-cproc pointer-get-unsigned-int (pointer offset::<int>) pointer_get_unsigned_int)
;(define-cproc pointer-get-long (pointer offset::<int>) pointer_get_long)
;(define-cproc pointer-get-unsigned-long (pointer offset::<int>) pointer_get_unsigned_long)
;(define-cproc pointer-get-float (pointer offset::<int>) pointer_get_float)
;(define-cproc pointer-get-double (pointer offset::<int>) pointer_get_double)
(define-cproc pointer-get-pointer (pointer offset::<int>) 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)
)

179
OLD/gauche-old/gauche-primitives.sld Normal file
View File

@ -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)))))

120
OLD/gauche-old/gauche-primitives.stub Normal file
View File

@ -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::<string> options) shared_object_load)
;(define-cproc pointer-null () pointer_null)
(define-cproc pointer-null? (pointer) is_pointer_null)
;(define-cproc pointer-allocate (size::<int>) 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::<int> value::<int8>) pointer_set_int8)
(define-cproc pointer-set-uint8! (pointer offset::<int> value::<uint8>) pointer_set_uint8)
;(define-cproc pointer-set-int16! (pointer offset::<int> value::<int16>) pointer_set_int16)
;(define-cproc pointer-set-uint16! (pointer offset::<int> value::<int16>) pointer_set_uint16)
;(define-cproc pointer-set-int32! (pointer offset::<int> value::<int32>) pointer_set_int32)
;(define-cproc pointer-set-uint32! (pointer offset::<int> value::<int32>) pointer_set_uint32)
;(define-cproc pointer-set-int64! (pointer offset::<int> value::<int64>) pointer_set_int64)
;(define-cproc pointer-set-uint64! (pointer offset::<int> value::<int64>) pointer_set_uint64)
;(define-cproc pointer-set-char! (pointer offset::<int> value::<char>) pointer_set_char)
;(define-cproc pointer-set-unsigned-char! (pointer offset::<int> value::<char>) pointer_set_unsigned_char)
;(define-cproc pointer-set-short! (pointer offset::<int> value::<short>) pointer_set_short)
;(define-cproc pointer-set-unsigned-short! (pointer offset::<int> value::<short>) pointer_set_unsigned_short)
;(define-cproc pointer-set-int! (pointer offset::<int> value::<int>) pointer_set_int)
;(define-cproc pointer-set-unsigned-int! (pointer offset::<int> value::<int>) pointer_set_unsigned_int)
;(define-cproc pointer-set-long! (pointer offset::<int> value::<long>) pointer_set_long)
;(define-cproc pointer-set-unsigned-long! (pointer offset::<int> value::<long>) pointer_set_unsigned_long)
;(define-cproc pointer-set-float! (pointer offset::<int> value::<float>) pointer_set_float)
;(define-cproc pointer-set-double! (pointer offset::<int> value::<double>) pointer_set_double)
(define-cproc pointer-set-pointer! (pointer offset::<int> value) pointer_set_pointer)
;(define-cproc pointer-get-int8 (pointer offset::<int>) pointer_get_int8)
(define-cproc pointer-get-uint8 (pointer offset::<int>) pointer_get_uint8)
;(define-cproc pointer-get-int16 (pointer offset::<int>) pointer_get_int16)
;(define-cproc pointer-get-uint16 (pointer offset::<int>) pointer_get_uint16)
;(define-cproc pointer-get-int32 (pointer offset::<int>) pointer_get_int32)
;(define-cproc pointer-get-uint32 (pointer offset::<int>) pointer_get_uint32)
;(define-cproc pointer-get-int64 (pointer offset::<int>) pointer_get_int64)
;(define-cproc pointer-get-uint64 (pointer offset::<int>) pointer_get_uint64)
;(define-cproc pointer-get-char (pointer offset::<int>) pointer_get_char)
;(define-cproc pointer-get-unsigned-char (pointer offset::<int>) pointer_get_unsigned_char)
;(define-cproc pointer-get-short (pointer offset::<int>) pointer_get_short)
;(define-cproc pointer-get-unsigned-short (pointer offset::<int>) pointer_get_unsigned_short)
;(define-cproc pointer-get-int (pointer offset::<int>) pointer_get_int)
;(define-cproc pointer-get-unsigned-int (pointer offset::<int>) pointer_get_unsigned_int)
;(define-cproc pointer-get-long (pointer offset::<int>) pointer_get_long)
;(define-cproc pointer-get-unsigned-long (pointer offset::<int>) pointer_get_unsigned_long)
;(define-cproc pointer-get-float (pointer offset::<int>) pointer_get_float)
;(define-cproc pointer-get-double (pointer offset::<int>) pointer_get_double)
(define-cproc pointer-get-pointer (pointer offset::<int>) 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)

6
OLD/gauche-old/gauche-tmp/gauche-primitives.sci Normal file
View File

@ -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)))))

4
foreign/c/primitives/gauche.scm → OLD/gauche-old/gauche-tmp/gauche-primitives.scm
View File

@ -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)

21
OLD/gauche-old/gauche-tmp/gauche-primitives.sld Normal file
View File

@ -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"))

1
OLD/gauche-old/gauche-tmp/gauche-primitives.stub Normal file
View File

@ -0,0 +1 @@
(declcode "ScmObj size_of_int8() { return Scm_MakeInteger(sizeof(int8_t)); }")

0
foreign/c/primitives/gauche/define-c-procedure.scm → OLD/gauche-old/gauche/define-c-procedure.scm
View File

835
OLD/gauche-old/gauche/foreign-c-gauche-primitives.c Normal file
View File

@ -0,0 +1,835 @@
#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 <foreign-c-gauche-primitives.h>
#include <ffi.h>
#include <dlfcn.h>
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, "<pointer: (null)>\n");
} else {
Scm_Printf(sink, "<pointer: %i>\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();
}

108
OLD/gauche-old/gauche/foreign-c-gauche-primitives.h Normal file
View File

@ -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);

4
foreign/c/primitives/gauche/gauchelib.scm → OLD/gauche-old/gauche/gauchelib.scm
View File

@ -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)

80
OLD/gauche-primitives.gauche.c Normal file
View File

@ -0,0 +1,80 @@
/* Generated by genstub. Do not edit. */
#include <gauche.h>
#include <stdio.h>
#include <ffi.h>
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("<top>", 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)) /* <vector> */,
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); /* <top> */
((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;
}

0
tests/hello.scm → OLD/hello.scm
View File

0
foreign/c/internal.scm → OLD/internal.scm
View File

0
foreign/c/libc.scm → OLD/libc.scm
View File

8
foreign/c/main.scm → OLD/main.scm
View File

@ -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

BIN
OLD/mit-scheme-foreign-c-const Executable file
View File

Binary file not shown.

51
OLD/mit-scheme-foreign-c-const.c Normal file
View File

@ -0,0 +1,51 @@
/* -*-C-*- */
/* Prefix */
#include <stdio.h>
#include <ffi.h>
/* End Prefix */
#include <stdio.h>
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;
}

16
OLD/mit-scheme-foreign-c-const.scm Normal file
View File

@ -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)
))

47
OLD/mit-scheme-foreign-c-shim.c Normal file
View File

@ -0,0 +1,47 @@
/* -*-C-*- */
#include <mit-scheme.h>
/* Prefix */
#include <stdio.h>
#include <ffi.h>
/* 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);
}

0
tests/old-all.scm → OLD/old-all.scm
View File

0
package.scm → OLD/package.scm
View File

30
foreign/c/pointer.scm → OLD/pointer.scm
View File

@ -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?

0
foreign/c/primitives/chibi/foreign-c.stub → OLD/primitives/chibi/foreign-c.stub
View File

0
foreign/c/primitives/guile.scm → OLD/primitives/guile.scm
View File

0
foreign/c/primitives/kawa.scm → OLD/primitives/kawa.scm
View File

0
foreign/c/primitives/larceny-util.scm → OLD/primitives/larceny-util.scm
View File

0
foreign/c/primitives/larceny.scm → OLD/primitives/larceny.scm
View File

12
OLD/primitives/mit-scheme.scm Normal file
View File

@ -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")

0
foreign/c/primitives/mosh.scm → OLD/primitives/mosh.scm
View File

0
foreign/c/primitives/racket.scm → OLD/primitives/racket.scm
View File

0
foreign/c/primitives/sagittarius.scm → OLD/primitives/sagittarius.scm
View File

0
foreign/c/primitives/skint.scm → OLD/primitives/skint.scm
View File

0
foreign/c/primitives/stklos.scm → OLD/primitives/stklos.scm
View File

0
foreign/c/primitives/tr7.scm → OLD/primitives/tr7.scm
View File

0
foreign/c/primitives/ypsilon.scm → OLD/primitives/ypsilon.scm
View File

0
templates/css/pdf-documentation.css → OLD/templates/css/pdf-documentation.css
View File

0
templates/documentation.html → OLD/templates/documentation.html
View File

BIN
documentation/foreign-c.pdf
View File

Binary file not shown.

366
foreign/c.scm Normal file
View File

@ -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)))))))

251
foreign/c.sld
View File

@ -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"))

66
foreign/c/Makefile
View File

@ -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

14
foreign/c/array.sld Normal file
View File

@ -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"))

0
foreign/c/primitives/mit-scheme.scm → foreign/c/bytevectors.scm
View File

10
foreign/c/c-bytevectors.sld Normal file
View File

@ -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"))

854
foreign/c/chibi-primitives.c Normal file
View File

@ -0,0 +1,854 @@
/* Automatically generated by chibi-ffi; version: 0.5 */
#include <chibi/eval.h>
#include <stdint.h>
#include <dlfcn.h>
#include <stdio.h>
#include <ffi.h>
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;
}

53
foreign/c/primitives/chibi.scm → foreign/c/chibi-primitives.scm
View File

@ -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))))))

26
foreign/c/chibi-primitives.sld Normal file
View File

@ -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"))

324
foreign/c/chibi-primitives.stub Normal file
View File

@ -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))

19
foreign/c/primitives/chicken.scm → foreign/c/chicken-primitives.scm
View File

@ -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))))

33
foreign/c/chicken-primitives.sld Normal file
View File

@ -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"))

21
foreign/c/cyclone-primitives.sld Normal file
View File

@ -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"))

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

0
foreign/c/primitives/gambit.scm → foreign/c/gambit-primitives.scm
View File

20
foreign/c/gambit-primitives.sld Normal file
View File

@ -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"))

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

@ -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)

15
foreign/c/gauche-primitives.gauche.c Normal file
View File

@ -0,0 +1,15 @@
#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.gauche.h>
#include <ffi.h>
#include <dlfcn.h>
void gauche_primitives_init(void) { puts("Hello from init"); }
extern ScmObj hello() { return Scm_MakeInteger(1); }

113
foreign/c/gauche-primitives.gauche.h Normal file
View File

@ -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);

5
foreign/c/gauche-primitives.gauche.sci Normal file
View File

@ -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")

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

@ -0,0 +1,13 @@
(in-module gauche-primitives)
(inline-stub
(declcode "#include <stdio.h>")
(declcode "#include <ffi.h>")
(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))

8
foreign/c/gauche-primitives.gauche.stub Normal file
View File

@ -0,0 +1,8 @@
(declcode "#include <stdio.h>")
(declcode "#include <ffi.h>")
(declcode "void Scm_Init_gauche_primitives_gauche(void) { puts(\"Hello from init\"); }")
(declcode "extern ScmObj hello() { return Scm_MakeInteger(1); }")
(define-cproc hello () hello)

21
foreign/c/gauche-primitives.sld Normal file
View File

@ -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"))

132
foreign/c/guile-primitives.scm Normal file
View File

@ -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))))))))

22
foreign/c/guile-primitives.sld Normal file
View File

@ -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"))

209
foreign/c/kawa-primitives.scm Normal file
View File

@ -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 <java.lang.Throwable> #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)))))

19
foreign/c/kawa-primitives.sld Normal file
View File

@ -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"))

76
foreign/c/larceny-primitives.scm Normal file
View File

@ -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)))))

25
foreign/c/larceny-primitives.sld Normal file
View File

@ -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"))

12
foreign/c/mit-scheme-primitives.scm Normal file
View File

@ -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")

19
foreign/c/mit-scheme-primitives.sld Normal file
View File

@ -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"))

108
foreign/c/mosh-primitives.scm Normal file
View File

@ -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)))))

21
foreign/c/mosh-primitives.sld Normal file
View File

@ -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"))

88
foreign/c/racket-primitives.scm Normal file
View File

@ -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)))))

29
foreign/c/racket-primitives.sld Normal file
View File

@ -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"))

149
foreign/c/sagittarius-primitives.scm Normal file
View File

@ -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)))))

21
foreign/c/sagittarius-primitives.sld Normal file
View File

@ -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"))

122
foreign/c/stklos-primitives.scm Normal file
View File

@ -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)))))

45
foreign/c/stklos-primitives.sld Normal file
View File

@ -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"))

17
foreign/c/struct.sld Normal file
View File

@ -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"))

149
foreign/c/ypsilon-primitives.scm Normal file
View File

@ -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))))

31
foreign/c/ypsilon-primitives.sld Normal file
View File

@ -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"))

BIN
kawa.jar
View File

Binary file not shown.

2
primitives
View File

@ -1,2 +0,0 @@
#!/bin/sh
ypsilon --r7rs --mute --quiet --sitelib=. --top-level-program primitives.scm "$@"

148
test.scm
View File

@ -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")

5
tests/c-src/libtest.c
View File

@ -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);
}