From 6686cc194c2e5c6ebbb6b4fbd2a89ec550348211 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Wed, 9 Jul 2025 22:47:41 +0300 Subject: [PATCH] Update dependencies --- snow/foreign/c.sld | 14 +- snow/foreign/c/libc.scm | 16 +- snow/foreign/c/pointer.scm | 25 ++- snow/foreign/c/primitives/chibi.scm | 122 +---------- .../foreign/c/primitives/chibi/foreign-c.stub | 204 ++---------------- snow/foreign/c/primitives/gambit.scm | 15 +- .../gauche/foreign-c-primitives-gauche.h | 66 ++---- snow/foreign/c/primitives/mit-scheme.scm | 0 snow/foreign/c/primitives/mosh.scm | 44 ---- snow/srfi/170.scm | 14 -- 10 files changed, 100 insertions(+), 420 deletions(-) create mode 100644 snow/foreign/c/primitives/mit-scheme.scm diff --git a/snow/foreign/c.sld b/snow/foreign/c.sld index f70fa19..121c725 100644 --- a/snow/foreign/c.sld +++ b/snow/foreign/c.sld @@ -33,7 +33,7 @@ (scheme process-context) (cyclone foreign) (scheme cyclone primitives))) - #;(gambit + (gambit (import (scheme base) (scheme write) (scheme char) @@ -77,6 +77,13 @@ (scheme file) (scheme inexact) (scheme process-context))) + (mit-scheme + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context))) #;(larceny (import (scheme base) (scheme write) @@ -194,7 +201,7 @@ c-bytevector->bytevector ;;;; Utilities - libc + libc-name ;; TODO endianness native-endianness @@ -304,11 +311,12 @@ (include "c/primitives/chicken.scm")) (chicken-6 (include-relative "c/primitives/chicken.scm")) ;(cyclone (include "c/primitives/cyclone.scm")) - ;(gambit (include "c/primitives/gambit.scm")) + (gambit (include "c/primitives/gambit.scm")) (gauche (include "c/primitives/gauche/define-c-procedure.scm")) ;(gerbil (include "c/primitives/gerbil.scm")) (guile (include "./c/primitives/guile.scm")) (kawa (include "c/primitives/kawa.scm")) + (mit-scheme (include "c/primitives/mit-scheme.scm")) ;(larceny (include "c/primitives/larceny.scm")) (mosh (include "c/primitives/mosh.scm")) (racket (include "c/primitives/racket.scm")) diff --git a/snow/foreign/c/libc.scm b/snow/foreign/c/libc.scm index 661a5bf..27ec05f 100644 --- a/snow/foreign/c/libc.scm +++ b/snow/foreign/c/libc.scm @@ -1,13 +1,7 @@ (cond-expand - (windows (define-c-library libc - '("stdlib.h" "stdio.h" "string.h") - "ucrtbase" - '())) + (windows + (define libc-name "ucrtbase")) (else - (define c-library "c") - (when (get-environment-variable "BE_HOST_CPU") - (set! c-library "root")) - (define-c-library libc - '("stdlib.h" "stdio.h" "string.h") - "c" - '((additional-versions ("0" "6")))))) + (define libc-name + (cond ((get-environment-variable "BE_HOST_CPU") "root") ; Haiku + (else "c"))))) diff --git a/snow/foreign/c/pointer.scm b/snow/foreign/c/pointer.scm index 774860f..d33f40e 100644 --- a/snow/foreign/c/pointer.scm +++ b/snow/foreign/c/pointer.scm @@ -1,11 +1,28 @@ +(define-c-library libc + '("stdlib.h" "stdio.h" "string.h") + libc-name + '((additional-versions ("0" "6")))) + (define-c-procedure c-calloc libc 'calloc 'pointer '(int int)) (cond-expand - (chicken (define c-memset-address->pointer + (gambit + (define c-memset-address->pointer + (c-lambda (unsigned-int64 unsigned-int8 int) + (pointer void) + "___return(memset((void*)___arg1, ___arg2, ___arg3));"))) + (chicken + (define c-memset-address->pointer (lambda (address value offset) (address->pointer address)))) - (else (define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int)))) + (else + (define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int)))) (cond-expand + (gambit + (define c-memset-pointer->address + (c-lambda ((pointer void) unsigned-int8 int) + unsigned-int64 + "___return((uint64_t)memset(___arg1, ___arg2, ___arg3));"))) (chicken (define c-memset-pointer->address (lambda (pointer value offset) (pointer->address pointer)))) @@ -67,8 +84,8 @@ (bytevector->c-bytevector (string->utf8 (string-append string-var (string #\null)))))) (cond-expand - (kawa #t) ; FIXME (chicken #t) ; FIXME + (kawa #t) ; FIXME (else (define make-c-null (lambda () (cond-expand (stklos (let ((pointer (make-c-bytevector 1))) @@ -77,8 +94,8 @@ (else (c-memset-address->pointer 0 0 0))))))) (cond-expand - (kawa #t) ; FIXME (chicken #t) ; FIXME + (kawa #t) ; FIXME (else (define c-null? (lambda (pointer) (if (c-bytevector? pointer) diff --git a/snow/foreign/c/primitives/chibi.scm b/snow/foreign/c/primitives/chibi.scm index 76bfb05..e9ffc95 100644 --- a/snow/foreign/c/primitives/chibi.scm +++ b/snow/foreign/c/primitives/chibi.scm @@ -35,57 +35,6 @@ (or (equal? object #f) ; False can be null pointer (pointer? object)))) -#;(define c-free -(lambda (pointer) - (pointer-free pointer))) - -;(define c-bytevector-u8-set! pointer-set-c-uint8_t!) -;(define c-bytevector-u8-ref pointer-ref-c-uint8_t) - -#;(define pointer-set! - (lambda (pointer type offset value) - (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value)) - ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value)) - ((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value)) - ((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value)) - ((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value)) - ((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value)) - ((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value)) - ((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value)) - ((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value))) - ((equal? type 'short) (pointer-set-c-short! pointer offset value)) - ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value)) - ((equal? type 'int) (pointer-set-c-int! pointer offset value)) - ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value)) - ((equal? type 'long) (pointer-set-c-long! pointer offset value)) - ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value)) - ((equal? type 'float) (pointer-set-c-float! pointer offset value)) - ((equal? type 'double) (pointer-set-c-double! pointer offset value)) - ((equal? type 'void) (pointer-set-c-pointer! pointer offset value)) - ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) - -#;(define pointer-get - (lambda (pointer type offset) - (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset)) - ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset)) - ((equal? type 'int16) (pointer-ref-c-int16_t pointer offset)) - ((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset)) - ((equal? type 'int32) (pointer-ref-c-int32_t pointer offset)) - ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset)) - ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset)) - ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset)) - ((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset))) - ((equal? type 'short) (pointer-ref-c-short pointer offset)) - ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset)) - ((equal? type 'int) (pointer-ref-c-int pointer offset)) - ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset)) - ((equal? type 'long) (pointer-ref-c-long pointer offset)) - ((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset)) - ((equal? type 'float) (pointer-ref-c-float pointer offset)) - ((equal? type 'double) (pointer-ref-c-double pointer offset)) - ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) - ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) - (define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) 'int8_t) @@ -106,79 +55,26 @@ ((equal? type 'unsigned-long) 'unsigned-long) ((equal? type 'float) 'float) ((equal? type 'double) 'double) - ((equal? type 'pointer) '(maybe-null void*)) - ((equal? type 'pointer-address) '(maybe-null void*)) + ((equal? type 'pointer) '(maybe-null pointer void*)) + ((equal? type 'pointer-address) '(maybe-null pointer void*)) ((equal? type 'void) 'void) - ((equal? type 'callback) '(maybe-null void*)) + ((equal? type 'callback) '(maybe-null pointer void*)) (else (error "pffi-type->native-type -- No such pffi type" type))))) ;; define-c-procedure -#;(define type->libffi-type - (lambda (type) - (cond ((equal? type 'int8) (get-ffi-type-int8)) - ((equal? type 'uint8) (get-ffi-type-uint8)) - ((equal? type 'int16) (get-ffi-type-int16)) - ((equal? type 'uint16) (get-ffi-type-uint16)) - ((equal? type 'int32) (get-ffi-type-int32)) - ((equal? type 'uint32) (get-ffi-type-uint32)) - ((equal? type 'int64) (get-ffi-type-int64)) - ((equal? type 'uint64) (get-ffi-type-uint64)) - ((equal? type 'char) (get-ffi-type-char)) - ((equal? type 'unsigned-char) (get-ffi-type-uchar)) - ((equal? type 'bool) (get-ffi-type-int8)) - ((equal? type 'short) (get-ffi-type-short)) - ((equal? type 'unsigned-short) (get-ffi-type-ushort)) - ((equal? type 'int) (get-ffi-type-int)) - ((equal? type 'unsigned-int) (get-ffi-type-uint)) - ((equal? type 'long) (get-ffi-type-long)) - ((equal? type 'unsigned-long) (get-ffi-type-ulong)) - ((equal? type 'float) (get-ffi-type-float)) - ((equal? type 'double) (get-ffi-type-double)) - ((equal? type 'void) (get-ffi-type-void)) - ((equal? type 'pointer) (get-ffi-type-pointer)) - ((equal? type 'pointer-address) 1) - ((equal? type 'callback) (get-ffi-type-pointer))))) - -#;(define type->libffi-type - (lambda (type) - (cond ((equal? type 'int8) 1) - ((equal? type 'uint8) 2) - ((equal? type 'int16) 3) - ((equal? type 'uint16) 4) - ((equal? type 'int32) 5) - ((equal? type 'uint32) 6) - ((equal? type 'int64) 7) - ((equal? type 'uint64) 8) - ((equal? type 'char) 9) - ((equal? type 'unsigned-char) 10) - ((equal? type 'short) 11) - ((equal? type 'unsigned-short) 12) - ((equal? type 'int) 13) - ((equal? type 'unsigned-int) 14) - ((equal? type 'long) 15) - ((equal? type 'unsigned-long) 16) - ((equal? type 'float) 17) - ((equal? type 'double) 18) - ((equal? type 'void) 19) - ((equal? type 'pointer) 20) - ((equal? type 'pointer-address) 21) - ((equal? type 'callback) 22) - (else (error "Undefined type" type))))) - -#;(define argument->pointer - (lambda (value type) - (cond ((procedure? value) (scheme-procedure-to-pointer value)) - (else (let ((pointer (pointer-allocate (size-of-type type)))) - (pointer-set! pointer type 0 value) - pointer))))) - (define make-c-function (lambda (shared-object c-name return-type argument-types) (dlerror) ;; Clean all previous errors (let ((c-function (dlsym shared-object c-name)) (maybe-dlerror (dlerror))) (lambda arguments + (display "NAME: ") + (display c-name) + (newline) + (display "ARGS: ") + (write arguments) + (newline) (let* ((return-pointer (internal-ffi-call (length argument-types) (type->libffi-type-number return-type) diff --git a/snow/foreign/c/primitives/chibi/foreign-c.stub b/snow/foreign/c/primitives/chibi/foreign-c.stub index 1579a81..c332acc 100644 --- a/snow/foreign/c/primitives/chibi/foreign-c.stub +++ b/snow/foreign/c/primitives/chibi/foreign-c.stub @@ -4,6 +4,11 @@ (c-system-include "dlfcn.h") (c-system-include "stdio.h") (c-system-include "ffi.h") +(c-link "ffi") + +;; make-c-null +(c-declare "void* make_c_null() { return NULL; }") +(define-c (maybe-null pointer void*) make-c-null ()) ;; c-type-size (c-declare " @@ -53,203 +58,25 @@ (define-c (maybe-null pointer void*) dlopen (string int)) (define-c (maybe-null pointer void*) dlerror ()) -;(c-declare "void* pointer_null() { return NULL; }") -;(define-c (pointer void*) (pointer-null pointer_null) ()) - -;(c-declare "int is_pointer_null(void* pointer) { if(pointer == NULL) { return 1; } else { return 0; }; }") -;(define-c bool (is-pointer-null is_pointer_null) ((maybe-null pointer void*))) - -;(c-declare "void* pointer_allocate(int size) { return malloc(size); }") -;(define-c (maybe-null pointer void*) (pointer-allocate pointer_allocate) (int)) - (c-declare "sexp is_pointer(struct sexp_struct* object) { if(sexp_cpointerp(object)) { return SEXP_TRUE; } else { return SEXP_FALSE; } }") (define-c sexp (pointer? is_pointer) (sexp)) (c-declare "void c_bytevector_u8_set(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }") -(define-c void (c-bytevector-u8-set! c_bytevector_u8_set) ((pointer void*) int uint8_t)) +(define-c void (c-bytevector-u8-set! c_bytevector_u8_set) ((maybe-null pointer void*) int uint8_t)) (c-declare "int8_t c_bytevector_u8_ref (void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }") -(define-c int8_t (c-bytevector-u8-ref c_bytevector_u8_ref) ((pointer void*) int)) +(define-c int8_t (c-bytevector-u8-ref c_bytevector_u8_ref) ((maybe-null pointer void*) int)) (c-declare "void c_bytevector_pointer_set (void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }") (define-c void (c-bytevector-pointer-set! c_bytevector_pointer_set) ((pointer void*) int (maybe-null pointer void*))) (c-declare "void* c_bytevector_pointer_ref (void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }") -(define-c (maybe-null pointer void*) (c-bytevector-pointer-ref c_bytevector_pointer_ref) ((pointer void*) int)) - -#;(c-declare "void* pointer_address(struct sexp_struct* pointer) { - return &sexp_cpointer_value(pointer); - }") -;(define-c (maybe-null pointer void*) (pointer-address pointer_address) (sexp)) - -;(c-declare "void pointer_free(void* pointer) { free(pointer); }") -;(define-c void (pointer-free pointer_free) ((maybe-null pointer void*))) - -;; pointer-set! -;(c-declare "void pointer_set_c_int8_t(void* pointer, int offset, int8_t value) { *(int8_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-int8_t! pointer_set_c_int8_t) ((pointer void*) int int8_t)) -;(c-declare "void pointer_set_c_uint8_t(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-uint8_t! pointer_set_c_uint8_t) ((pointer void*) int uint8_t)) -; -;(c-declare "void pointer_set_c_int16_t(void* pointer, int offset, int16_t value) { *(int16_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-int16_t! pointer_set_c_int16_t) ((pointer void*) int int16_t)) -;(c-declare "void pointer_set_c_uint16_t(void* pointer, int offset, uint16_t value) { *(uint16_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-uint16_t! pointer_set_c_uint16_t) ((pointer void*) int uint16_t)) -; -;(c-declare "void pointer_set_c_int32_t(void* pointer, int offset, int32_t value) { *(int32_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-int32_t! pointer_set_c_int32_t) ((pointer void*) int int32_t)) -;(c-declare "void pointer_set_c_uint32_t(void* pointer, int offset, uint32_t value) { *(uint32_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-uint32_t! pointer_set_c_uint32_t) ((pointer void*) int uint32_t)) -; -;(c-declare "void pointer_set_c_int64_t(void* pointer, int offset, int64_t value) { *(int64_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-int64_t! pointer_set_c_int64_t) ((pointer void*) int int64_t)) -;(c-declare "void pointer_set_c_uint64_t(void* pointer, int offset, uint64_t value) { *(uint64_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-uint64_t! pointer_set_c_uint64_t) ((pointer void*) int uint64_t)) -; -;(c-declare "void pointer_set_c_char(void* pointer, int offset, int8_t value) { *((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int int8_t)) -;(c-declare "void pointer_set_c_unsigned_char(void* pointer, int offset, unsigned char value) { *(unsigned char*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-unsigned-char! pointer_set_c_unsigned_char) ((pointer void*) int unsigned-char)) -; -;(c-declare "void pointer_set_c_short(void* pointer, int offset, short value) { *(short*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-short! pointer_set_c_short) ((pointer void*) int short)) -;(c-declare "void pointer_set_c_unsigned_short(void* pointer, int offset, unsigned short value) { *(unsigned short*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-unsigned-short! pointer_set_c_unsigned_short) ((pointer void*) int unsigned-short)) -; -;(c-declare "void pointer_set_c_int(void* pointer, int offset, int value) { *(int*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-int! pointer_set_c_int) ((pointer void*) int int)) -;(c-declare "void pointer_set_c_unsigned_int(void* pointer, int offset, unsigned int value) { *(unsigned int*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-unsigned-int! pointer_set_c_unsigned_int) ((pointer void*) int unsigned-int)) -; -;(c-declare "void pointer_set_c_long(void* pointer, int offset, long value) { *(long*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-long! pointer_set_c_long) ((pointer void*) int long)) -;(c-declare "void pointer_set_c_unsigned_long(void* pointer, int offset, unsigned long value) { *(unsigned long*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-unsigned-long! pointer_set_c_unsigned_long) ((pointer void*) int unsigned-long)) -; -;(c-declare "void pointer_set_c_float(void* pointer, int offset, float value) { *(float*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-float! pointer_set_c_float) ((pointer void*) int float)) -; -;(c-declare "void pointer_set_c_double(void* pointer, int offset, double value) { *(double*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-double! pointer_set_c_double) ((pointer void*) int double)) -; -;(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }") -;(define-c void (pointer-set-c-pointer! pointer_set_c_pointer) ((pointer void*) int (maybe-null pointer void*))) -; -;;; pointer-get -;(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }") -;(define-c int8_t (pointer-ref-c-int8_t pointer_ref_c_int8_t) ((pointer void*) int)) -;(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { return *(uint8_t*)((char*)pointer + offset); }") -;(define-c uint8_t (pointer-ref-c-uint8_t pointer_ref_c_uint8_t) ((pointer void*) int)) -; -;(c-declare "int16_t pointer_ref_c_int16_t(void* pointer, int offset) { return *(int16_t*)((char*)pointer + offset); }") -;(define-c int16_t (pointer-ref-c-int16_t pointer_ref_c_int16_t) ((pointer void*) int)) -;(c-declare "uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { return *(uint16_t*)((char*)pointer + offset); }") -;(define-c uint16_t (pointer-ref-c-uint16_t pointer_ref_c_uint16_t) ((pointer void*) int)) -; -;(c-declare "int32_t pointer_ref_c_int32_t(void* pointer, int offset) { return *(int32_t*)((char*)pointer + offset); }") -;(define-c int32_t (pointer-ref-c-int32_t pointer_ref_c_int32_t) ((pointer void*) int)) -;(c-declare "uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { return *(uint32_t*)((char*)pointer + offset); }") -;(define-c uint32_t (pointer-ref-c-uint32_t pointer_ref_c_uint32_t) ((pointer void*) int)) -; -;(c-declare "int64_t pointer_ref_c_int64_t(void* pointer, int offset) { return *(int64_t*)((char*)pointer + offset); }") -;(define-c int64_t (pointer-ref-c-int64_t pointer_ref_c_int64_t) ((pointer void*) int)) -;(c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { return *(uint64_t*)((char*)pointer + offset); }") -;(define-c uint64_t (pointer-ref-c-uint64_t pointer_ref_c_uint64_t) ((pointer void*) int)) -; -;(c-declare "int8_t pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); }") -;(define-c int8_t (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int)) -;(c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { return *(unsigned char*)((char*)pointer + offset); }") -;(define-c unsigned-char (pointer-ref-c-unsigned-char pointer_ref_c_unsigned_char) ((pointer void*) int)) -; -;(c-declare "short pointer_ref_c_short(void* pointer, int offset) { return *(short*)((char*)pointer + offset); }") -;(define-c short (pointer-ref-c-short pointer_ref_c_short) ((pointer void*) int)) -;(c-declare "unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { return *(unsigned short*)((char*)pointer + offset); }") -;(define-c unsigned-short (pointer-ref-c-unsigned-short pointer_ref_c_unsigned_short) ((pointer void*) int)) -; -;(c-declare "int pointer_ref_c_int(void* pointer, int offset) { return *(int*)((char*)pointer + offset); }") -;(define-c int (pointer-ref-c-int pointer_ref_c_int) ((pointer void*) int)) -;(c-declare "unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { return *(unsigned int*)((char*)pointer + offset); }") -;(define-c unsigned-int (pointer-ref-c-unsigned-int pointer_ref_c_unsigned_int) ((pointer void*) int)) -; -;(c-declare "long pointer_ref_c_long(void* pointer, int offset) { return *(long*)((char*)pointer + offset); }") -;(define-c long (pointer-ref-c-long pointer_ref_c_long) ((pointer void*) long)) -;(c-declare "unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { return *(unsigned long*)((char*)pointer + offset); }") -;(define-c unsigned-long (pointer-ref-c-unsigned-long pointer_ref_c_unsigned_long) ((pointer void*) int)) -; -;(c-declare "float pointer_ref_c_float(void* pointer, int offset) { return *(float*)((char*)pointer + offset); }") -;(define-c float (pointer-ref-c-float pointer_ref_c_float) ((pointer void*) int)) -; -;(c-declare "double pointer_ref_c_double(void* pointer, int offset) { return *(double*)((char*)pointer + offset); }") -;(define-c double (pointer-ref-c-double pointer_ref_c_double) ((pointer void*) int)) -; -;(c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }") -;(define-c (maybe-null pointer void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int)) - -;; define-c-procedure +(define-c (maybe-null pointer void*) (c-bytevector-pointer-ref c_bytevector_pointer_ref) ((maybe-null pointer void*) int)) (c-declare "ffi_cif cif;") -(define-c (pointer void*) dlsym ((maybe-null pointer void*) string)) - -;(c-declare "void* get_ffi_type_int8() { return &ffi_type_sint8; }") -;(define-c (pointer void*) (get-ffi-type-int8 get_ffi_type_int8) ()) -;(c-declare "void* get_ffi_type_uint8() { return &ffi_type_uint8; }") -;(define-c (pointer void*) (get-ffi-type-uint8 get_ffi_type_uint8) ()) -; -;(c-declare "void* get_ffi_type_int16() { return &ffi_type_sint16; }") -;(define-c (pointer void*) (get-ffi-type-int16 get_ffi_type_int16) ()) -;(c-declare "void* get_ffi_type_uint16() { return &ffi_type_uint16; }") -;(define-c (pointer void*) (get-ffi-type-uint16 get_ffi_type_uint16) ()) -; -;(c-declare "void* get_ffi_type_int32() { return &ffi_type_sint32; }") -;(define-c (pointer void*) (get-ffi-type-int32 get_ffi_type_int32) ()) -;(c-declare "void* get_ffi_type_uint32() { return &ffi_type_uint32; }") -;(define-c (pointer void*) (get-ffi-type-uint32 get_ffi_type_uint32) ()) -; -;(c-declare "void* get_ffi_type_int64() { return &ffi_type_sint64; }") -;(define-c (pointer void*) (get-ffi-type-int64 get_ffi_type_int64) ()) -;(c-declare "void* get_ffi_type_uint64() { return &ffi_type_uint64; }") -;(define-c (pointer void*) (get-ffi-type-uint64 get_ffi_type_uint64) ()) -; -;(c-declare "void* get_ffi_type_char() { return &ffi_type_schar; }") -;(define-c (pointer void*) (get-ffi-type-char get_ffi_type_char) ()) -;(c-declare "void* get_ffi_type_uchar() { return &ffi_type_uchar; }") -;(define-c (pointer void*) (get-ffi-type-uchar get_ffi_type_uchar) ()) -; -;(c-declare "void* get_ffi_type_short() { return &ffi_type_sshort; }") -;(define-c (pointer void*) (get-ffi-type-short get_ffi_type_short) ()) -;(c-declare "void* get_ffi_type_ushort() { return &ffi_type_ushort; }") -;(define-c (pointer void*) (get-ffi-type-ushort get_ffi_type_ushort) ()) -; -;(c-declare "void* get_ffi_type_int() { return &ffi_type_sint; }") -;(define-c (pointer void*) (get-ffi-type-int get_ffi_type_int) ()) -;(c-declare "void* get_ffi_type_uint() { return &ffi_type_uint; }") -;(define-c (pointer void*) (get-ffi-type-uint get_ffi_type_uint) ()) -; -;(c-declare "void* get_ffi_type_long() { return &ffi_type_slong; }") -;(define-c (pointer void*) (get-ffi-type-long get_ffi_type_long) ()) -; -;(c-declare "void* get_ffi_type_ulong() { return &ffi_type_ulong; }") -;(define-c (pointer void*) (get-ffi-type-ulong get_ffi_type_ulong) ()) -; -;(c-declare "void* get_ffi_type_float() { return &ffi_type_float; }") -;(define-c (pointer void*) (get-ffi-type-float get_ffi_type_float) ()) -; -;(c-declare "void* get_ffi_type_double() { return &ffi_type_double; }") -;(define-c (pointer void*) (get-ffi-type-double get_ffi_type_double) ()) -; -;(c-declare "void* get_ffi_type_void() { return &ffi_type_void; }") -;(define-c (pointer void*) (get-ffi-type-void get_ffi_type_void) ()) -; -;(c-declare "void* get_ffi_type_pointer() { return &ffi_type_pointer; }") -;(define-c (pointer void*) (get-ffi-type-pointer get_ffi_type_pointer) ()) +(define-c (maybe-null pointer void*) dlsym ((maybe-null pointer void*) string)) (define-c-const int (FFI-OK "FFI_OK")) -#;(c-declare - "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); - }") -;(define-c int (internal-ffi-prep-cif internal_ffi_prep_cif) (unsigned-int (pointer void*) (array void*))) (c-declare "void* internal_ffi_call( unsigned int nargs, @@ -282,7 +109,9 @@ double vals18[nargs]; void* vals20[nargs]; + printf(\"nargs: %i\\n\", nargs); for(int i = 0; i < nargs; i++) { + printf(\"i: %i\\n\", i); void* arg = NULL; switch(atypes[i]) { case 1: @@ -365,18 +194,25 @@ case 17: c_atypes[i] = &ffi_type_float; vals17[i] = (float)sexp_flonum_value(avalues[i]); + c_avalues[i] = &vals17[i]; break; case 18: c_atypes[i] = &ffi_type_double; vals18[i] = (double)sexp_flonum_value(avalues[i]); + c_avalues[i] = &vals18[i]; break; case 19: c_atypes[i] = &ffi_type_void; arg = NULL; + c_avalues[i] = NULL; break; case 20: c_atypes[i] = &ffi_type_pointer; - vals20[i] = sexp_cpointer_value(avalues[i]); + if(sexp_cpointerp(avalues[i])) { + vals20[i] = sexp_cpointer_value(avalues[i]); + } else { + vals20[i] = NULL; + } c_avalues[i] = &vals20[i]; break; default: @@ -425,7 +261,7 @@ (unsigned-int unsigned-int (array unsigned-int) - (pointer void*) + (maybe-null pointer void*) unsigned-int (array sexp))) diff --git a/snow/foreign/c/primitives/gambit.scm b/snow/foreign/c/primitives/gambit.scm index 11d3e4d..cedc52c 100644 --- a/snow/foreign/c/primitives/gambit.scm +++ b/snow/foreign/c/primitives/gambit.scm @@ -46,6 +46,19 @@ ((eq? type 'void) (size-of-void*)) (else (error "Can not get size of unknown type" type))))) +#;(define-macro + (define-c-library name headers object-name options) + (display "HERE: ") + (write (cons `(define ,name #t) + (map (lambda (header) + `(c-declare ,(string-append "#include <" header ">"))) + (car (cdr headers))))) + (newline) + (cons `(define ,name #t) + (map (lambda (header) + `(c-declare ,(string-append "#include <" header ">"))) + (car (cdr headers))))) + (define-macro (define-c-library name headers object-name . options) (begin @@ -66,7 +79,7 @@ (lambda (x) #f) (lambda () (pointer? object))))))) -#;(define c-bytevector-u8-set! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define c-bytevector-u8-set! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) (define c-bytevector-u8-ref (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));")) (define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) diff --git a/snow/foreign/c/primitives/gauche/foreign-c-primitives-gauche.h b/snow/foreign/c/primitives/gauche/foreign-c-primitives-gauche.h index 8eb1ebf..bb0918b 100644 --- a/snow/foreign/c/primitives/gauche/foreign-c-primitives-gauche.h +++ b/snow/foreign/c/primitives/gauche/foreign-c-primitives-gauche.h @@ -1,10 +1,3 @@ -/* - * spigot.h - calculate pi and e by spigot algorithm - * - * Written by Shiro Kawai (shiro@acm.org) - * I put this program in public domain. Use it as you like. - */ - extern ScmObj size_of_int8(); extern ScmObj size_of_uint8(); extern ScmObj size_of_int16(); @@ -34,52 +27,32 @@ extern ScmObj shared_object_load(ScmString* path, ScmObj options); extern ScmObj is_pointer(ScmObj pointer); //extern ScmObj pointer_free(ScmObj pointer); + //extern ScmObj pointer_set_int8(ScmObj pointer, int offset, int8_t value); extern ScmObj pointer_set_uint8(ScmObj pointer, int offset, uint8_t value); /* -extern ScmObj pointer_set_int16(ScmObj pointer, int offset, int16_t value); -extern ScmObj pointer_set_uint16(ScmObj pointer, int offset, uint16_t value); -extern ScmObj pointer_set_int32(ScmObj pointer, int offset, int32_t value); -extern ScmObj pointer_set_uint32(ScmObj pointer, int offset, uint32_t value); -extern ScmObj pointer_set_int64(ScmObj pointer, int offset, int64_t value); -extern ScmObj pointer_set_uint64(ScmObj pointer, int offset, uint64_t value); -extern ScmObj pointer_set_char(ScmObj pointer, int offset, char value); -extern ScmObj pointer_set_unsigned_char(ScmObj pointer, int offset, unsigned char value); -extern ScmObj pointer_set_short(ScmObj pointer, int offset, short value); -extern ScmObj pointer_set_unsigned_short(ScmObj pointer, int offset, unsigned short value); -extern ScmObj pointer_set_int(ScmObj pointer, int offset, int value); -extern ScmObj pointer_set_unsigned_int(ScmObj pointer, int offset, unsigned int value); -extern ScmObj pointer_set_long(ScmObj pointer, int offset, long value); -extern ScmObj pointer_set_unsigned_long(ScmObj pointer, int offset, unsigned long value); -extern ScmObj pointer_set_float(ScmObj pointer, int offset, float value); -extern ScmObj pointer_set_double(ScmObj pointer, int offset, double value); -*/ -extern ScmObj pointer_set_pointer(ScmObj pointer, int offset, ScmObj value); + * extern ScmObj pointer_set_int16(ScmObj pointer, int offset, int16_t value); + * extern ScmObj pointer_set_uint16(ScmObj pointer, int offset, uint16_t value); + * extern ScmObj pointer_set_int32(ScmObj pointer, int offset, int32_t value); + * extern ScmObj pointer_set_uint32(ScmObj pointer, int offset, uint32_t value); + * extern ScmObj pointer_set_int64(ScmObj pointer, int offset, int64_t value); + * extern ScmObj pointer_set_uint64(ScmObj pointer, int offset, uint64_t value); + * extern ScmObj pointer_set_char(ScmObj pointer, int offset, char value); + * extern ScmObj pointer_set_unsigned_char(ScmObj pointer, int offset, unsigned char value); + * extern ScmObj pointer_set_short(ScmObj pointer, int offset, short value); + * extern ScmObj pointer_set_unsigned_short(ScmObj pointer, int offset, unsigned short value); + * extern ScmObj pointer_set_int(ScmObj pointer, int offset, int value); + * extern ScmObj pointer_set_unsigned_int(ScmObj pointer, int offset, unsigned int value); + * extern ScmObj pointer_set_long(ScmObj pointer, int offset, long value); + * extern ScmObj pointer_set_unsigned_long(ScmObj pointer, int offset, unsigned long value); + * extern ScmObj pointer_set_float(ScmObj pointer, int offset, float value); + * extern ScmObj pointer_set_double(ScmObj pointer, int offset, double value); + * */ -//extern ScmObj pointer_get_int8(ScmObj pointer, int offset); -extern ScmObj pointer_get_uint8(ScmObj pointer, int offset); -/* -extern ScmObj pointer_get_int16(ScmObj pointer, int offset); -extern ScmObj pointer_get_uint16(ScmObj pointer, int offset); -extern ScmObj pointer_get_int32(ScmObj pointer, int offset); -extern ScmObj pointer_get_uint32(ScmObj pointer, int offset); -extern ScmObj pointer_get_int64(ScmObj pointer, int offset); -extern ScmObj pointer_get_uint64(ScmObj pointer, int offset); -extern ScmObj pointer_get_char(ScmObj pointer, int offset); -extern ScmObj pointer_get_unsigned_char(ScmObj pointer, int offset); -extern ScmObj pointer_get_short(ScmObj pointer, int offset); -extern ScmObj pointer_get_unsigned_short(ScmObj pointer, int offset); -extern ScmObj pointer_get_int(ScmObj pointer, int offset); -extern ScmObj pointer_get_unsigned_int(ScmObj pointer, int offset); -extern ScmObj pointer_get_long(ScmObj pointer, int offset); -extern ScmObj pointer_get_unsigned_long(ScmObj pointer, int offset); -extern ScmObj pointer_get_float(ScmObj pointer, int offset); -extern ScmObj pointer_get_double(ScmObj pointer, int offset); -*/ extern ScmObj pointer_get_pointer(ScmObj pointer, int offset); - //extern ScmObj string_to_pointer(ScmObj string); //extern ScmObj pointer_to_string(ScmObj pointer); + extern ScmObj internal_dlerror(); extern ScmObj internal_dlsym(ScmObj shared_object, ScmObj c_name); extern ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, ScmObj rvalue, ScmObj avalues); @@ -107,3 +80,4 @@ extern ScmObj get_ffi_type_void(); extern ScmObj get_ffi_type_pointer(); extern void Scm_Init_gauchelib(void); + diff --git a/snow/foreign/c/primitives/mit-scheme.scm b/snow/foreign/c/primitives/mit-scheme.scm new file mode 100644 index 0000000..e69de29 diff --git a/snow/foreign/c/primitives/mosh.scm b/snow/foreign/c/primitives/mosh.scm index 1fcbfbb..b9bb7bf 100644 --- a/snow/foreign/c/primitives/mosh.scm +++ b/snow/foreign/c/primitives/mosh.scm @@ -36,50 +36,6 @@ (define c-bytevector-pointer-set! pointer-set-c-pointer!) (define c-bytevector-pointer-ref pointer-ref-c-pointer) -#;(define pointer-set! - (lambda (pointer type offset value) - (cond ((equal? type 'int8) (pointer-set-c-int8! pointer offset value)) - ((equal? type 'uint8) (pointer-set-c-uint8! pointer offset value)) - ((equal? type 'int16) (pointer-set-c-int16! pointer offset value)) - ((equal? type 'uint16) (pointer-set-c-uint16! pointer offset value)) - ((equal? type 'int32) (pointer-set-c-int32! pointer offset value)) - ((equal? type 'uint32) (pointer-set-c-uint32! pointer offset value)) - ((equal? type 'int64) (pointer-set-c-int64! pointer offset value)) - ((equal? type 'uint64) (pointer-set-c-uint64! pointer offset value)) - ((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value))) - ((equal? type 'short) (pointer-set-c-short! pointer offset value)) - ((equal? type 'unsigned-short) (pointer-set-c-short! pointer offset value)) - ((equal? type 'int) (pointer-set-c-int! pointer offset value)) - ((equal? type 'unsigned-int) (pointer-set-c-int! pointer offset value)) - ((equal? type 'long) (pointer-set-c-long! pointer offset value)) - ((equal? type 'unsigned-long) (pointer-set-c-long! pointer offset value)) - ((equal? type 'float) (pointer-set-c-float! pointer offset value)) - ((equal? type 'double) (pointer-set-c-double! pointer offset value)) - ((equal? type 'void) (pointer-set-c-pointer! pointer offset value)) - ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) - -#;(define pointer-get - (lambda (pointer type offset) - (cond ((equal? type 'int8) (pointer-ref-c-int8 pointer offset)) - ((equal? type 'uint8) (pointer-ref-c-uint8 pointer offset)) - ((equal? type 'int16) (pointer-ref-c-int16 pointer offset)) - ((equal? type 'uint16) (pointer-ref-c-uint16 pointer offset)) - ((equal? type 'int32) (pointer-ref-c-int32 pointer offset)) - ((equal? type 'uint32) (pointer-ref-c-uint32 pointer offset)) - ((equal? type 'int64) (pointer-ref-c-int64 pointer offset)) - ((equal? type 'uint64) (pointer-ref-c-uint64 pointer offset)) - ((equal? type 'char) (integer->char (pointer-ref-c-signed-char pointer offset))) - ((equal? type 'short) (pointer-ref-c-signed-short pointer offset)) - ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset)) - ((equal? type 'int) (pointer-ref-c-signed-int pointer offset)) - ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset)) - ((equal? type 'long) (pointer-ref-c-signed-long pointer offset)) - ((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset)) - ((equal? type 'float) (pointer-ref-c-float pointer offset)) - ((equal? type 'double) (pointer-ref-c-double pointer offset)) - ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) - ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) - (define type->native-type (lambda (type) (cond ((equal? type 'int8) 'int8_t) diff --git a/snow/srfi/170.scm b/snow/srfi/170.scm index ef10d96..67efce7 100644 --- a/snow/srfi/170.scm +++ b/snow/srfi/170.scm @@ -1,19 +1,5 @@ (define slash (cond-expand (windows "\\") (else "/"))) -(cond-expand - (windows (define-c-library srfi-170-libc - '("dirent.h" "stdlib.h" "stdio.h" "string.h") - "ucrtbase" - '())) - (else - (define c-library "c") - (when (get-environment-variable "BE_HOST_CPU") - (set! c-library "root")) - (define-c-library srfi-170-libc - '("dirent.h" "stdlib.h" "stdio.h" "string.h") - "c" - '((additional-versions ("0" "6")))))) - (define-c-procedure c-perror libc 'perror 'void '(pointer)) (define-c-procedure c-mkdir libc 'mkdir 'int '(pointer int)) (define-c-procedure c-rmdir libc 'rmdir 'int '(pointer))