diff --git a/Makefile b/Makefile index afd9c80..7f4fd0f 100644 --- a/Makefile +++ b/Makefile @@ -1,16 +1,15 @@ -.PHONY: snow PREFIX=/usr/local build: printf "#!/bin/sh\nsash --disable-cache -r7 -L ${PREFIX}/lib/compile-r7rs/snow ${PREFIX}/lib/compile-r7rs/main.scm \"\$$@\"\n" > compile-r7rs snow: - rm -rf snow mkdir -p snow cp -r ../r7rs-pffi/retropikzel snow/ cp -r ../pffi-srfi-170/srfi snow/ -install: +# Does uninstall because without that the changes do not seem to update +install: uninstall mkdir -p ${PREFIX}/lib/compile-r7rs/snow cp -r snow/* ${PREFIX}/lib/compile-r7rs/snow cp -r libs ${PREFIX}/lib/compile-r7rs/snow/libs @@ -63,6 +62,12 @@ test-r7rs-docker: docker build --build-arg COMPILE_R7RS=${COMPILE_R7RS} --tag=compile-r7rs-test-${COMPILE_R7RS} . docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${COMPILE_R7RS} sh -c "make && make install && make clean-test COMPILE_R7RS=${COMPILE_R7RS} test-r7rs" +clean-snow: + rm -rf snow + +clean-test: + rm -rf test + clean: find . -name "*.so" -delete find . -name "*.o*" -delete @@ -74,5 +79,4 @@ clean: rm -rf dist rm -rf test -clean-test: - rm -rf test + diff --git a/README.md b/README.md index 4e43dc5..a5b0b5b 100644 --- a/README.md +++ b/README.md @@ -98,6 +98,11 @@ as compiler. - interpreter - R6RS - R7RS +- racket + - interpreter + - Has compiling capabilities but I havent got them to work yet + - r6rs + - r7rs - sagittarius - interpreter - R6RS @@ -132,12 +137,6 @@ as compiler. https://github.com/yamacir-kit/meevax/issues/494, might not be implemented yet - r7rs - - racket - - Wants the library paths to be full paths so I need to implement - realpath into [pffi-srfi-170](https://git.sr.ht/~retropikzel/pffi-srfi-170) - to get them - - r6rs - - r7rs - picrin - Might not be possible, seems to not have (include...) that works like others @@ -435,12 +434,3 @@ libs/util.sld. If the transformer has to go trough hoops, that is is little or much unusual then it is a good idea to explain how it works in this readmes how it works section. - -### Misc notes - - -When developing and testing, run: - - make && sudo make uninstall install - -without the uninstall the changes to libraries dont seem to update. diff --git a/libs/data.sld b/libs/data.sld index 29aa7c0..4a007c3 100644 --- a/libs/data.sld +++ b/libs/data.sld @@ -391,13 +391,26 @@ " " ,input-file))))) (racket - (type . compiler) + (type . interpreter) + (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) + (let ((library-rkt-file (change-file-suffix library-file ".rkt"))) + (apply string-append + `("printf" + " " + "'#lang r7rs\\n(import (scheme base))\\n(include \"" + ,(path->filename library-file) + "\")\\n" + "'" + " " + ">" + " " + ,library-rkt-file))))) (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) (let ((rkt-input-file (if (string=? input-file "") "" (change-file-suffix input-file ".rkt")))) (when (not (string=? rkt-input-file "")) - (if (file-exists? rkt-input-file) + (when (file-exists? rkt-input-file) (delete-file rkt-input-file)) (with-output-to-file rkt-input-file @@ -410,38 +423,23 @@ (display (path->filename input-file)) (display "\")") (newline)))) - (for-each - (lambda (file) - (let ((library-rkt-file (change-file-suffix file ".rkt"))) - (if (file-exists? library-rkt-file) - (delete-file library-rkt-file)) - (with-output-to-file - library-rkt-file - (lambda () - (display "#lang r7rs") - (newline) - (display "(import (scheme base))") - (newline) - (display "(include \"") - (display (path->filename file)) - (display "\")") - (newline))))) - library-files) (apply string-append - ;; TODO run realpath to each directory - ;; as Racket expects static paths - `("PLTCOLLECTS=" - ,(string-join prepend-directories ":") - ,(string-join append-directories ":") - " " - "raco exe" + `("racket" " " ,(util-getenv "COMPILE_R7RS_RACKET") " " - "--orig-exe ++lang r7rs -o " - ,output-file + "-I" " " - ,rkt-input-file)))))) + ,(if r6rs? "r6rs" "r7rs") + " " + ,@(map (lambda (item) + (string-append "-S " item " ")) + prepend-directories) + ,@(map (lambda (item) + (string-append "-S " item " ")) + append-directories) + " " + ,(if r6rs? input-file rkt-input-file))))))) (sagittarius (type . interpreter) (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) diff --git a/snow/retropikzel/pffi/Makefile b/snow/retropikzel/pffi/Makefile index 1cb9662..c9f6bde 100644 --- a/snow/retropikzel/pffi/Makefile +++ b/snow/retropikzel/pffi/Makefile @@ -1,13 +1,55 @@ CC=gcc -chibi-pffi.so: chibi/pffi.stub - chibi-ffi chibi/pffi.stub - ${CC} -g3 -o chibi-pffi.so chibi/pffi.c -fPIC -lffi -shared +chibi: chibi-src/pffi.stub + chibi-ffi chibi-src/pffi.stub + ${CC} -g3 -o chibi-pffi.so chibi-src/pffi.c -fPIC -lffi -shared -gauche-pffi.so: +chicken: + @echo "Nothing to build for Chicken" + +cyclone: + @echo "Nothing to build for Cyclone" + +gambit: + @echo "Nothing to build for Gambit" + +gauche: gauche-src/gauche-pffi.c gauche-src/gauchelib.scm gauche-package compile \ - --srcdir=gauche \ + --srcdir=gauche-src \ --cc=${CC} \ --cflags="-I./include" \ --libs=-lffi \ gauche-pffi gauche-pffi.c gauchelib.scm + +gerbil: + @echo "Nothing to build for Gerbil" + +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" diff --git a/snow/retropikzel/pffi/chibi/pffi.stub b/snow/retropikzel/pffi/chibi-src/pffi.stub similarity index 100% rename from snow/retropikzel/pffi/chibi/pffi.stub rename to snow/retropikzel/pffi/chibi-src/pffi.stub diff --git a/snow/retropikzel/pffi/chibi/pffi.c b/snow/retropikzel/pffi/chibi/pffi.c deleted file mode 100644 index e909d9c..0000000 --- a/snow/retropikzel/pffi/chibi/pffi.c +++ /dev/null @@ -1,1421 +0,0 @@ -/* Automatically generated by chibi-ffi; version: 0.5 */ - -#include - -#include - -#include - -#include - - 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*); } - -void* pointer_null() { return NULL; } -int is_pointer_null(void* pointer) { if(pointer == NULL) { return 1; } else { return 0; }; } -void* pointer_allocate(int size) { return malloc(size); } -sexp is_pointer(struct sexp_struct* object) { - if(sexp_cpointerp(object)) { - return SEXP_TRUE; - } else { - return SEXP_FALSE; - } - } -intptr_t pointer_address(struct sexp_struct* pointer) { - return (intptr_t)&sexp_cpointer_value(pointer); - } -void pointer_free(void* pointer) { free(pointer); } -void pointer_set_c_int8_t(void* pointer, int offset, int8_t value) { *(int8_t*)((char*)pointer + offset) = value; } -void pointer_set_c_uint8_t(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; } -void pointer_set_c_int16_t(void* pointer, int offset, int16_t value) { *(int16_t*)((char*)pointer + offset) = value; } -void pointer_set_c_uint16_t(void* pointer, int offset, uint16_t value) { *(uint16_t*)((char*)pointer + offset) = value; } -void pointer_set_c_int32_t(void* pointer, int offset, int32_t value) { *(int32_t*)((char*)pointer + offset) = value; } -void pointer_set_c_uint32_t(void* pointer, int offset, uint32_t value) { *(uint32_t*)((char*)pointer + offset) = value; } -void pointer_set_c_int64_t(void* pointer, int offset, int64_t value) { *(int64_t*)((char*)pointer + offset) = value; } -void pointer_set_c_uint64_t(void* pointer, int offset, uint64_t value) { *(uint64_t*)((char*)pointer + offset) = value; } -void pointer_set_c_char(void* pointer, int offset, char value) { *((char*)pointer + offset) = value; } -void pointer_set_c_unsigned_char(void* pointer, int offset, unsigned char value) { *(unsigned char*)((char*)pointer + offset) = value; } -void pointer_set_c_short(void* pointer, int offset, short value) { *(short*)((char*)pointer + offset) = value; } -void pointer_set_c_unsigned_short(void* pointer, int offset, unsigned short value) { *(unsigned short*)((char*)pointer + offset) = value; } -void pointer_set_c_int(void* pointer, int offset, int value) { *(int*)((char*)pointer + offset) = value; } -void pointer_set_c_unsigned_int(void* pointer, int offset, unsigned int value) { *(unsigned int*)((char*)pointer + offset) = value; } -void pointer_set_c_long(void* pointer, int offset, long value) { *(long*)((char*)pointer + offset) = value; } -void pointer_set_c_unsigned_long(void* pointer, int offset, unsigned long value) { *(unsigned long*)((char*)pointer + offset) = value; } -void pointer_set_c_float(void* pointer, int offset, float value) { *(float*)((char*)pointer + offset) = value; } -void pointer_set_c_double(void* pointer, int offset, double value) { *(double*)((char*)pointer + offset) = value; } -void pointer_set_c_pointer(void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; } -int8_t pointer_ref_c_int8_t(void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); } -uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { return *(uint8_t*)((char*)pointer + offset); } -int16_t pointer_ref_c_int16_t(void* pointer, int offset) { return *(int16_t*)((char*)pointer + offset); } -uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { return *(uint16_t*)((char*)pointer + offset); } -int32_t pointer_ref_c_int32_t(void* pointer, int offset) { return *(int32_t*)((char*)pointer + offset); } -uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { return *(uint32_t*)((char*)pointer + offset); } -int64_t pointer_ref_c_int64_t(void* pointer, int offset) { return *(int64_t*)((char*)pointer + offset); } -uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { return *(uint64_t*)((char*)pointer + offset); } -char pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); } -unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { return *(unsigned char*)((char*)pointer + offset); } -short pointer_ref_c_short(void* pointer, int offset) { return *(short*)((char*)pointer + offset); } -unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { return *(unsigned short*)((char*)pointer + offset); } -int pointer_ref_c_int(void* pointer, int offset) { return *(int*)((char*)pointer + offset); } -unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { return *(unsigned int*)((char*)pointer + offset); } -long pointer_ref_c_long(void* pointer, int offset) { return *(long*)((char*)pointer + offset); } -unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { return *(unsigned long*)((char*)pointer + offset); } -float pointer_ref_c_float(void* pointer, int offset) { return *(float*)((char*)pointer + offset); } -double pointer_ref_c_double(void* pointer, int offset) { return *(double*)((char*)pointer + offset); } -void* pointer_ref_c_pointer(void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; } -ffi_cif cif; -void* get_ffi_type_int8() { return &ffi_type_sint8; } -void* get_ffi_type_uint8() { return &ffi_type_uint8; } -void* get_ffi_type_int16() { return &ffi_type_sint16; } -void* get_ffi_type_uint16() { return &ffi_type_uint16; } -void* get_ffi_type_int32() { return &ffi_type_sint32; } -void* get_ffi_type_uint32() { return &ffi_type_uint32; } -void* get_ffi_type_int64() { return &ffi_type_sint64; } -void* get_ffi_type_uint64() { return &ffi_type_uint64; } -void* get_ffi_type_char() { return &ffi_type_schar; } -void* get_ffi_type_uchar() { return &ffi_type_uchar; } -void* get_ffi_type_short() { return &ffi_type_sshort; } -void* get_ffi_type_ushort() { return &ffi_type_ushort; } -void* get_ffi_type_int() { return &ffi_type_sint; } -void* get_ffi_type_uint() { return &ffi_type_uint; } -void* get_ffi_type_long() { return &ffi_type_slong; } -void* get_ffi_type_ulong() { return &ffi_type_ulong; } -void* get_ffi_type_float() { return &ffi_type_float; } -void* get_ffi_type_double() { return &ffi_type_double; } -void* get_ffi_type_void() { return &ffi_type_void; } -void* get_ffi_type_pointer() { return &ffi_type_pointer; } -int internal_ffi_prep_cif(unsigned int nargs, void* rtype, void* atypes[]) { - printf("A1: %u, A2: %u, nargs: %u\n", &ffi_type_pointer, atypes[0], nargs); - return ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes); - } -void internal_ffi_call(unsigned int nargs, void* rtype, void** atypes, void* fn, void* rvalue, struct sexp_struct* avalues[]) { - ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes); - void* c_avalues[nargs]; - for(int i = 0; i < nargs; i++) { - c_avalues[i] = sexp_cpointer_value(avalues[i]); - } - ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues); - } -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* *tmp2; - sexp *tmp5; - sexp res; - if (! sexp_exact_integerp(arg0)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg0); - if (! (sexp_pointerp(arg1) && (sexp_pointer_tag(arg1) == SEXP_CPOINTER))) - return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg1); - for (res=arg2; sexp_pairp(res); res=sexp_cdr(res)) - if (! (sexp_pointerp(sexp_car(res)) && (sexp_pointer_tag(sexp_car(res)) == SEXP_CPOINTER))) - return sexp_xtype_exception(ctx, self, "not a list of void*s", arg2); - if (! sexp_nullp(res)) - return sexp_xtype_exception(ctx, self, "not a list of void*s", arg2); - if (! (sexp_pointerp(arg3) && (sexp_pointer_tag(arg3) == SEXP_CPOINTER))) - return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg3); - if (! (sexp_pointerp(arg4) && (sexp_pointer_tag(arg4) == SEXP_CPOINTER))) - return sexp_type_exception(ctx, self, SEXP_CPOINTER, 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 = (void**) 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] = (void*)sexp_cpointer_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 = ((internal_ffi_call(sexp_uint_value(arg0), (void**)sexp_cpointer_value(arg1), tmp2, (void**)sexp_cpointer_value(arg3), (void**)sexp_cpointer_value(arg4), tmp5)), SEXP_VOID); - free(tmp2); - free(tmp5); - return res; -} - -sexp sexp_internal_ffi_prep_cif_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1, sexp arg2) { - int i = 0; - void* *tmp2; - sexp res; - if (! sexp_exact_integerp(arg0)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg0); - if (! (sexp_pointerp(arg1) && (sexp_pointer_tag(arg1) == SEXP_CPOINTER))) - return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg1); - for (res=arg2; sexp_pairp(res); res=sexp_cdr(res)) - if (! (sexp_pointerp(sexp_car(res)) && (sexp_pointer_tag(sexp_car(res)) == SEXP_CPOINTER))) - return sexp_xtype_exception(ctx, self, "not a list of void*s", arg2); - if (! sexp_nullp(res)) - return sexp_xtype_exception(ctx, self, "not a list of void*s", arg2); - tmp2 = (void**) 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] = (void*)sexp_cpointer_value(sexp_car(res)); - } - tmp2[i] = 0; - res = sexp_make_integer(ctx, internal_ffi_prep_cif(sexp_uint_value(arg0), (void**)sexp_cpointer_value(arg1), tmp2)); - free(tmp2); - return res; -} - -sexp sexp_get_ffi_type_pointer_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_pointer(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_void_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_void(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_double_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_double(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_float_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_float(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_ulong_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_ulong(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_long_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_long(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_uint_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_uint(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_int_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_int(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_ushort_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_ushort(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_short_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_short(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_uchar_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_uchar(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_char_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_char(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_uint64_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_uint64(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_int64_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_int64(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_uint32_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_uint32(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_int32_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_int32(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_uint16_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_uint16(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_int16_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_int16(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_uint8_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_uint8(), SEXP_FALSE, 0); - return res; -} - -sexp sexp_get_ffi_type_int8_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, get_ffi_type_int8(), SEXP_FALSE, 0); - 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_pointer_ref_c_pointer_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))) - 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, pointer_ref_c_pointer((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1)), SEXP_FALSE, 0); - return res; -} - -sexp sexp_pointer_ref_c_double_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))) - 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_flonum(ctx, pointer_ref_c_double((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_float_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))) - 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_flonum(ctx, pointer_ref_c_float((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_unsigned_long_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))) - 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, pointer_ref_c_unsigned_long((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_long_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))) - 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_integer(ctx, pointer_ref_c_long((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_unsigned_int_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))) - 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, pointer_ref_c_unsigned_int((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_int_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))) - 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_integer(ctx, pointer_ref_c_int((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_unsigned_short_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))) - 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, pointer_ref_c_unsigned_short((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_short_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))) - 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_integer(ctx, pointer_ref_c_short((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_unsigned_char_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))) - 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, pointer_ref_c_unsigned_char((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_char_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))) - 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_character(pointer_ref_c_char((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_uint64_t_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))) - 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, pointer_ref_c_uint64_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_int64_t_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))) - 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_integer(ctx, pointer_ref_c_int64_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_uint32_t_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))) - 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, pointer_ref_c_uint32_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_int32_t_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))) - 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_integer(ctx, pointer_ref_c_int32_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_uint16_t_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))) - 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, pointer_ref_c_uint16_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_int16_t_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))) - 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_integer(ctx, pointer_ref_c_int16_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_uint8_t_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))) - 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, pointer_ref_c_uint8_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_ref_c_int8_t_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))) - 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_integer(ctx, pointer_ref_c_int8_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1))); - return res; -} - -sexp sexp_pointer_set_c_pointer_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 = ((pointer_set_c_pointer((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), (void**)sexp_cpointer_maybe_null_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_double_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_flonump(arg2)) - return sexp_type_exception(ctx, self, SEXP_FLONUM, arg2); - res = ((pointer_set_c_double((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_flonum_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_float_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_flonump(arg2)) - return sexp_type_exception(ctx, self, SEXP_FLONUM, arg2); - res = ((pointer_set_c_float((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_flonum_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_unsigned_long_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_unsigned_long((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_uint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_long_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_long((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_sint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_unsigned_int_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_unsigned_int((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_uint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_int_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_int((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_sint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_unsigned_short_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_unsigned_short((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_uint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_short_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_short((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_sint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_unsigned_char_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_unsigned_char((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_uint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_char_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_charp(arg2)) - return sexp_type_exception(ctx, self, SEXP_CHAR, arg2); - res = ((pointer_set_c_char((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_unbox_character(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_uint64_t_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_uint64_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_uint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_int64_t_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_int64_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_sint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_uint32_t_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_uint32_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_uint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_int32_t_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_int32_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_sint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_uint16_t_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_uint16_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_uint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_int16_t_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_int16_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_sint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_uint8_t_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_uint8_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_uint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_set_c_int8_t_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_exact_integerp(arg2)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); - res = ((pointer_set_c_int8_t((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), sexp_sint_value(arg2))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_free_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 = ((pointer_free((void**)sexp_cpointer_maybe_null_value(arg0))), SEXP_VOID); - return res; -} - -sexp sexp_pointer_address_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) { - sexp res; - res = sexp_make_unsigned_integer(ctx, pointer_address(arg0)); - 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_pointer_allocate_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) { - void* *tmp; - sexp res; - if (! sexp_exact_integerp(arg0)) - return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg0); - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, pointer_allocate(sexp_sint_value(arg0)), SEXP_FALSE, 0); - return res; -} - -sexp sexp_is_pointer_null_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 = sexp_make_boolean(is_pointer_null((void**)sexp_cpointer_maybe_null_value(arg0))); - return res; -} - -sexp sexp_pointer_null_stub (sexp ctx, sexp self, sexp_sint_t n) { - void* *tmp; - sexp res; - res = sexp_make_cpointer(ctx, SEXP_CPOINTER, pointer_null(), SEXP_FALSE, 0); - 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_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_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_VOID; - sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM); - sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - 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_CPOINTER)); - } - op = sexp_define_foreign(ctx, env, "internal-ffi-prep-cif", 3, sexp_internal_ffi_prep_cif_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); - sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM); - sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-pointer", 0, sexp_get_ffi_type_pointer_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-void", 0, sexp_get_ffi_type_void_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-double", 0, sexp_get_ffi_type_double_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-float", 0, sexp_get_ffi_type_float_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-ulong", 0, sexp_get_ffi_type_ulong_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-long", 0, sexp_get_ffi_type_long_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-uint", 0, sexp_get_ffi_type_uint_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-int", 0, sexp_get_ffi_type_int_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-ushort", 0, sexp_get_ffi_type_ushort_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-short", 0, sexp_get_ffi_type_short_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-uchar", 0, sexp_get_ffi_type_uchar_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-char", 0, sexp_get_ffi_type_char_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-uint64", 0, sexp_get_ffi_type_uint64_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-int64", 0, sexp_get_ffi_type_int64_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-uint32", 0, sexp_get_ffi_type_uint32_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-int32", 0, sexp_get_ffi_type_int32_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-uint16", 0, sexp_get_ffi_type_uint16_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-int16", 0, sexp_get_ffi_type_int16_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-uint8", 0, sexp_get_ffi_type_uint8_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "get-ffi-type-int8", 0, sexp_get_ffi_type_int8_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - 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, "pointer-ref-c-pointer", 2, sexp_pointer_ref_c_pointer_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, "pointer-ref-c-double", 2, sexp_pointer_ref_c_double_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FLONUM); - 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, "pointer-ref-c-float", 2, sexp_pointer_ref_c_float_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FLONUM); - 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, "pointer-ref-c-unsigned-long", 2, sexp_pointer_ref_c_unsigned_long_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, "pointer-ref-c-long", 2, sexp_pointer_ref_c_long_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, "pointer-ref-c-unsigned-int", 2, sexp_pointer_ref_c_unsigned_int_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, "pointer-ref-c-int", 2, sexp_pointer_ref_c_int_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, "pointer-ref-c-unsigned-short", 2, sexp_pointer_ref_c_unsigned_short_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, "pointer-ref-c-short", 2, sexp_pointer_ref_c_short_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, "pointer-ref-c-unsigned-char", 2, sexp_pointer_ref_c_unsigned_char_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, "pointer-ref-c-char", 2, sexp_pointer_ref_c_char_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CHAR); - 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, "pointer-ref-c-uint64_t", 2, sexp_pointer_ref_c_uint64_t_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, "pointer-ref-c-int64_t", 2, sexp_pointer_ref_c_int64_t_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, "pointer-ref-c-uint32_t", 2, sexp_pointer_ref_c_uint32_t_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, "pointer-ref-c-int32_t", 2, sexp_pointer_ref_c_int32_t_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, "pointer-ref-c-uint16_t", 2, sexp_pointer_ref_c_uint16_t_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, "pointer-ref-c-int16_t", 2, sexp_pointer_ref_c_int16_t_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, "pointer-ref-c-uint8_t", 2, sexp_pointer_ref_c_uint8_t_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, "pointer-ref-c-int8_t", 2, sexp_pointer_ref_c_int8_t_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, "pointer-set-c-pointer!", 3, sexp_pointer_set_c_pointer_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, "pointer-set-c-double!", 3, sexp_pointer_set_c_double_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_FLONUM); - } - op = sexp_define_foreign(ctx, env, "pointer-set-c-float!", 3, sexp_pointer_set_c_float_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_FLONUM); - } - op = sexp_define_foreign(ctx, env, "pointer-set-c-unsigned-long!", 3, sexp_pointer_set_c_unsigned_long_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-set-c-long!", 3, sexp_pointer_set_c_long_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-set-c-unsigned-int!", 3, sexp_pointer_set_c_unsigned_int_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-set-c-int!", 3, sexp_pointer_set_c_int_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-set-c-unsigned-short!", 3, sexp_pointer_set_c_unsigned_short_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-set-c-short!", 3, sexp_pointer_set_c_short_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-set-c-unsigned-char!", 3, sexp_pointer_set_c_unsigned_char_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-set-c-char!", 3, sexp_pointer_set_c_char_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_CHAR); - } - op = sexp_define_foreign(ctx, env, "pointer-set-c-uint64_t!", 3, sexp_pointer_set_c_uint64_t_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-set-c-int64_t!", 3, sexp_pointer_set_c_int64_t_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-set-c-uint32_t!", 3, sexp_pointer_set_c_uint32_t_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-set-c-int32_t!", 3, sexp_pointer_set_c_int32_t_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-set-c-uint16_t!", 3, sexp_pointer_set_c_uint16_t_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-set-c-int16_t!", 3, sexp_pointer_set_c_int16_t_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-set-c-uint8_t!", 3, sexp_pointer_set_c_uint8_t_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-set-c-int8_t!", 3, sexp_pointer_set_c_int8_t_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-free", 1, sexp_pointer_free_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = SEXP_VOID; - sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "pointer-address", 1, sexp_pointer_address_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_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, "pointer-allocate", 1, sexp_pointer_allocate_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); - } - op = sexp_define_foreign(ctx, env, "is-pointer-null", 1, sexp_is_pointer_null_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_BOOLEAN); - sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - op = sexp_define_foreign(ctx, env, "pointer-null", 0, sexp_pointer_null_stub); - if (sexp_opcodep(op)) { - sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); - } - 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, "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); - } - sexp_gc_release3(ctx); - return SEXP_VOID; -} - diff --git a/snow/retropikzel/pffi/gauche/gauchelib.scm b/snow/retropikzel/pffi/gauche-src/gauchelib.scm similarity index 100% rename from snow/retropikzel/pffi/gauche/gauchelib.scm rename to snow/retropikzel/pffi/gauche-src/gauchelib.scm diff --git a/snow/retropikzel/pffi/gauche/gauche-pffi.c b/snow/retropikzel/pffi/gauche/gauche-pffi.c deleted file mode 100644 index e3875dd..0000000 --- a/snow/retropikzel/pffi/gauche/gauche-pffi.c +++ /dev/null @@ -1,692 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -void print_pointer(ScmObj obj, ScmPort* sink, ScmWriteContext* G1788 SCM_UNUSED) { - void* p = SCM_FOREIGN_POINTER_REF(void*, obj); - if(p == NULL) { - Scm_Printf(sink, "\n"); - } else { - Scm_Printf(sink, "\n", &p); - } -} - -void dprint_pointer(ScmObj obj, ScmPort* sink, ScmWriteContext* G1788 SCM_UNUSED) { - void* p = SCM_FOREIGN_POINTER_REF(void*, obj); - if(p == NULL) { - Scm_Printf(sink, "\n"); - } else { - Scm_Printf(sink, "\n", &p); - } -} - -ScmObj size_of_int8() { return Scm_MakeInteger(sizeof(int8_t)); } -ScmObj size_of_uint8() { return Scm_MakeInteger(sizeof(uint8_t)); } -ScmObj size_of_int16() { return Scm_MakeInteger(sizeof(int16_t)); } -ScmObj size_of_uint16() { return Scm_MakeInteger(sizeof(uint16_t)); } -ScmObj size_of_int32() { return Scm_MakeInteger(sizeof(int32_t)); } -ScmObj size_of_uint32() { return Scm_MakeInteger(sizeof(uint32_t)); } -ScmObj size_of_int64() { return Scm_MakeInteger(sizeof(int64_t)); } -ScmObj size_of_uint64() { return Scm_MakeInteger(sizeof(uint64_t)); } -ScmObj size_of_char() { return Scm_MakeInteger(sizeof(char)); } -ScmObj size_of_unsigned_char() { return Scm_MakeInteger(sizeof(unsigned char)); } -ScmObj size_of_short() { return Scm_MakeInteger(sizeof(short)); } -ScmObj size_of_unsigned_short() { return Scm_MakeInteger(sizeof(unsigned short)); } -ScmObj size_of_int() { return Scm_MakeInteger(sizeof(int)); } -ScmObj size_of_unsigned_int() { return Scm_MakeInteger(sizeof(unsigned int)); } -ScmObj size_of_long() { return Scm_MakeInteger(sizeof(long)); } -ScmObj size_of_unsigned_long() { return Scm_MakeInteger(sizeof(unsigned long)); } -ScmObj size_of_float() { return Scm_MakeInteger(sizeof(float)); } -ScmObj size_of_double() { return Scm_MakeInteger(sizeof(double)); } -ScmObj size_of_string() { return Scm_MakeInteger(sizeof(char*)); } -ScmObj size_of_pointer() { return Scm_MakeInteger(sizeof(void*)); } -ScmObj size_of_void() { return Scm_MakeInteger(sizeof(void)); } - -ScmModule* module = NULL; - -ScmObj shared_object_load(ScmString* path) { - 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, "pffi-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, "pffi-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) { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - void* p = malloc(size); - ScmObj pointer = Scm_MakeForeignPointer(pointer_class, p); - return pointer; -} - -ScmObj pointer_address(ScmObj object) { - if(!Scm_TypeP(object, SCM_CLASS_FOREIGN_POINTER)) { - Scm_Error("Can only get pointer address of a pointer"); - return SCM_UNDEFINED; - } - void* p = SCM_FOREIGN_POINTER_REF(void*, object); - return SCM_MAKE_INT(&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, "pffi-pointer", dprint_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, "pffi-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 pffi_dlerror() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-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 pffi_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, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, symbol); -} - -ScmObj get_ffi_type_int8() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint8); -} - -ScmObj get_ffi_type_uint8() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint8); -} - -ScmObj get_ffi_type_int16() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint16); -} - -ScmObj get_ffi_type_uint16() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint16); -} - -ScmObj get_ffi_type_int32() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint32); -} - -ScmObj get_ffi_type_uint32() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint32); -} - -ScmObj get_ffi_type_int64() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_sint64); -} - -ScmObj get_ffi_type_uint64() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint64); -} - -ScmObj get_ffi_type_char() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-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, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_uchar); -} - -ScmObj get_ffi_type_short() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-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, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_ushort); -} - -ScmObj get_ffi_type_int() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-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, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_uint); -} - -ScmObj get_ffi_type_long() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-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, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_ulong); -} - -ScmObj get_ffi_type_float() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_float); -} - -ScmObj get_ffi_type_double() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_double); -} - -ScmObj get_ffi_type_void() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-pointer", print_pointer, NULL, 0); - return Scm_MakeForeignPointer(pointer_class, &ffi_type_void); -} - -ScmObj get_ffi_type_pointer() { - ScmClass* pointer_class = Scm_MakeForeignPointerClass(module, "pffi-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, 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++) { - c_atypes[i] = SCM_FOREIGN_POINTER_REF(ffi_type*, Scm_ListRef(atypes, i, SCM_UNDEFINED)); - } - 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* c_rvalue = 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), c_rvalue, c_avalues); - - return SCM_UNDEFINED; -} - -/* -ScmObj procedure_to_pointer(ScmObj procedure) { - - return SCM_UNDEFINED; -}*/ - -void Scm_Init_gauche_pffi(void) -{ - SCM_INIT_EXTENSION(retropikzel.pffi.gauche); - module = SCM_MODULE(SCM_FIND_MODULE("retropikzel.pffi.gauche", TRUE)); - Scm_Init_gauchelib(); -} diff --git a/snow/retropikzel/pffi/shared/struct.scm b/snow/retropikzel/pffi/shared/struct.scm index 01938a5..2de0ebd 100644 --- a/snow/retropikzel/pffi/shared/struct.scm +++ b/snow/retropikzel/pffi/shared/struct.scm @@ -30,9 +30,6 @@ (let* ((member-type (cadr struct-member)) (member-name (car struct-member)) (member-size (pffi-size-of member-type))) - (display "HERE: ") - (write member-size) - (newline) (pffi-pointer-set! pointer member-type offset @@ -114,10 +111,6 @@ (error "Struct has no such member" (list struct member-name))) (let ((type (car (cdr (assoc member-name (pffi-struct-members struct))))) (offset (car (cdr (cdr (assoc member-name (pffi-struct-members struct))))))) - (map display (list "type: " type - ", offset: " offset - ", value: " (pffi-pointer-get (pffi-struct-pointer struct) type offset) - #\newline)) (pffi-pointer-get (pffi-struct-pointer struct) type offset))) (define (pffi-struct-set! struct member-name value) diff --git a/snow/srfi/170.scm b/snow/srfi/170.scm index af93f85..c03e23e 100644 --- a/snow/srfi/170.scm +++ b/snow/srfi/170.scm @@ -36,14 +36,55 @@ (pffi-define uv-fs-scandir libuv 'uv_fs_scandir 'int '(pointer pointer pointer int pointer)) (pffi-define uv-fs-scandir-next libuv 'uv_fs_scandir_next 'int '(pointer pointer)) (pffi-define uv-fs-get-ptr libuv 'uv_fs_get_ptr 'pointer '(pointer)) +(pffi-define uv-fs-realpath libuv 'uv_fs_realpath 'int '(pointer pointer pointer pointer)) +(pffi-define uv-fs-cleanup libuv 'uv_fs_req_cleanup 'void '(pointer)) ;(pffi-define uv-fs-scandir libuv 'uv_fs_scandir 'int '(pointer pointer pointer int pointer)) ;(pffi-define c-printf libc 'printf 'int '(string)) ;(pffi-define c-cos libc 'cos 'double '(double)) (define UV-FS 6) -(define uv-fs-t-make +(pffi-define-struct uv-fs-t-make + 'uv_fs_t + '((pointer . data) + (int . type) + (pointer . reserved1) + (pointer . reserved2) + (pointer . reserved3) + (pointer . reserved4) + (pointer . reserved5) + (pointer . reserved6) + (pointer . fs_type) + (pointer . loop) + (pointer . cb) + (int . result) + (pointer . ptr) + (pointer . path) + (int . statbuf) + (pointer . new_path) + (int . file) + (int . flags) + (int . mode) + (pointer . bufs) + (int . off) + (int . uid) + (int . gid) + (double . atime) + (double . mtime) + (pointer . work_req) + (pointer . bufsml1) + (pointer . bufsml2) + (pointer . bufsml3) + (pointer . bufsml4))) + +(define req-type (uv-fs-t-make)) + +;(pffi-struct-set! struct 'fs_type UV-FS) +#;(define uv-fs-t-make (lambda () - (let ((p (pffi-pointer-allocate (+ (pffi-size-of 'pointer) ; .loop + (let ((struct (uv-fs-t))) + (pffi-struct-set! struct 'fs_type UV-FS) + struct + #;(let ((p (pffi-pointer-allocate (+ (pffi-size-of 'pointer) ; .loop (pffi-size-of 'int) ; .uv_fs_type (pffi-size-of 'pointer) ; .path (pffi-size-of 'int) ; .result @@ -52,7 +93,11 @@ 512 ; Temporary fix )))) (pffi-pointer-set! p 'int (pffi-size-of 'pointer) UV-FS) - p))) + p)))) + +(pffi-define-struct uv-dirent-make + 'uv_dirent_t + '((pointer . name) (int . uv_dirent_type))) (define handle-errors (lambda (return-code . irritants) @@ -85,115 +130,105 @@ ; FIX make the "follow?" argument work (define file-info (lambda (fname/port follow?) - (let* ((req-type (uv-fs-t-make))) - (handle-errors (uv-fs-stat (uv-default-loop) - req-type - (pffi-string->pointer fname/port) - (pffi-pointer-null))) - (let ((stat-pointer (uv-fs-get-ptr req-type))) - (file-info-record-make (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 0)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 1)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 2)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 3)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 4)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 5)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 6)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 7)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 8)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 9)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 10)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 11)) - (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 12)) - fname/port - follow?))))) + (handle-errors (uv-fs-stat (uv-default-loop) + (pffi-struct-pointer req-type) + (pffi-string->pointer fname/port) + (pffi-pointer-null))) + (let* ((stat-pointer (uv-fs-get-ptr (pffi-struct-pointer req-type))) + (result (file-info-record-make (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 0)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 1)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 2)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 3)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 4)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 5)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 6)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 7)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 8)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 9)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 10)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 11)) + (pffi-pointer-get stat-pointer 'uint64 (* (pffi-size-of 'uint64) 12)) + fname/port + follow?))) + (uv-fs-cleanup (pffi-struct-pointer req-type)) + result))) (define file-info-directory? (lambda (file-info) ; Try to open the file-info path as directory, if it fails say it's not a directory - (let ((req-type (uv-fs-t-make))) - (let* ((file-path (file-info:fname/port file-info)) - (result (uv-fs-opendir (uv-default-loop) - req-type - (pffi-string->pointer file-path) - (pffi-pointer-null)))) - (cond ((not (file-exists? file-path)) #f) - ((not (= result -20)) #t) - ; If it is a dir then it's open and needs to be closed - (else (uv-fs-closedir (uv-default-loop) - req-type - (uv-fs-get-ptr req-type) - (pffi-pointer-null)) - #f)))))) + (let* ((file-path (file-info:fname/port file-info)) + (uv-result (uv-fs-opendir (uv-default-loop) + (pffi-struct-pointer req-type) + (pffi-string->pointer file-path) + (pffi-pointer-null)))) + (cond ((not (file-exists? file-path)) + (uv-fs-cleanup (pffi-struct-pointer req-type)) + #f) + ((not (= uv-result -20)) + (uv-fs-cleanup (pffi-struct-pointer req-type)) + #t) + ; If it is a dir then it's open and needs to be closed + (else (uv-fs-closedir (uv-default-loop) + (pffi-struct-pointer req-type) + (uv-fs-get-ptr (pffi-struct-pointer req-type)) + (pffi-pointer-null)) + (uv-fs-cleanup (pffi-struct-pointer req-type)) + #f))))) (define create-directory (lambda (fname . permission-bits) - (let ((req-type (uv-fs-t-make)) - (mode (if (null? permission-bits) #o775 (car permission-bits)))) + (let ((mode (if (null? permission-bits) #o775 (car permission-bits)))) (handle-errors (uv-fs-mkdir (uv-default-loop) - req-type + (pffi-struct-pointer req-type) (pffi-string->pointer fname) mode (pffi-pointer-null)) + (uv-fs-cleanup (pffi-struct-pointer req-type)) fname)))) (define delete-directory (lambda (fname) - (let ((req-type (uv-fs-t-make))) - (handle-errors - (uv-fs-rmdir (uv-default-loop) - req-type - (pffi-string->pointer fname) - (pffi-pointer-null)) - fname)))) + (handle-errors + (uv-fs-rmdir (uv-default-loop) + (pffi-struct-pointer req-type) + (pffi-string->pointer fname) + (pffi-pointer-null)) + (uv-fs-cleanup (pffi-struct-pointer req-type)) + fname))) (define directory-files (lambda (dir . args) (letrec* ((dotfiles? (if (null? args) #f (car args))) - (req-type (uv-fs-t-make)) (result (handle-errors (uv-fs-scandir (uv-default-loop) - req-type + (pffi-struct-pointer req-type) (pffi-string->pointer dir) 0 (pffi-pointer-null)) dir)) - (uv-dirent-t (pffi-pointer-allocate (+ (pffi-size-of 'pointer) - (pffi-size-of 'int) - 512))) + (uv-dirent-t (uv-dirent-make)) (files (list)) (looper (lambda () - (let ((next-file (uv-fs-scandir-next req-type uv-dirent-t))) + (let ((next-file (uv-fs-scandir-next (pffi-struct-pointer req-type) + (pffi-struct-pointer uv-dirent-t)))) (when (= next-file 0) ; End of file - (let ((file-name (string-copy (pffi-pointer->string (pffi-pointer-get uv-dirent-t 'pointer 0))))) + (let ((file-name (pffi-pointer->string (pffi-struct-get uv-dirent-t 'name)))) (if (and (> (string-length file-name) 0) (char=? (string-ref file-name 0) #\.)) (if dotfiles? (set! files (append files (list file-name)))) - (set! files (append files (list file-name))) - ) + (set! files (append files (list file-name)))) (looper))))))) (looper) - files - ;(write result) - ;(newline) - ;(write (uv-fs-scandir-next req-type uv-dirent-t)) - ;(newline) - ;(write (pffi-pointer->string (pffi-pointer-get uv-dirent-t 'pointer 0))) - ;(newline) + (uv-fs-cleanup (pffi-struct-pointer req-type)) + files))) +(define real-path + (lambda (path) + (let* ((result (uv-fs-realpath (uv-default-loop) + (pffi-struct-pointer req-type) + (pffi-string->pointer path) + (pffi-pointer-null))) + (realpath (pffi-pointer->string (uv-fs-get-ptr (pffi-struct-pointer req-type))))) + (uv-fs-cleanup (pffi-struct-pointer req-type)) + realpath))) - - - - - ;(write (uv-default-loop)) - ;(newline) - ;(write (uv-fs-scandir (uv-default-loop) (pffi-string->pointer ".") 0 (pffi-pointer-null))) - ;(newline) - ;(write (c-opendir (pffi-string->pointer "."))) - ;(newline) - ;(c-puts (pffi-string->pointer "Hello world")) - ;(c-printf (pffi-string->pointer "Hello world\n")) - ;(newline) - ;(c-cos 5.5) - ;#t - ))) diff --git a/snow/srfi/170.sld b/snow/srfi/170.sld index 6db5bcf..5f39945 100644 --- a/snow/srfi/170.sld +++ b/snow/srfi/170.sld @@ -3,7 +3,9 @@ (import (scheme base) (scheme write) (scheme file) - (retropikzel pffi)) + (retropikzel pffi) + (scheme process-context) + ) (export ;posix-error? ;posix-error-name ;posix-error-message @@ -46,7 +48,7 @@ ;open-directory ;read-directory ;close-directory - ;real-path + real-path ;file-space ;temp-file-prefix ;create-temp-file