From 339ad3c408b7d233c0c81cad9bc7f2560ff7a52f Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 11 Jul 2025 23:48:27 +0300 Subject: [PATCH] Move towards using chibi --- .gitignore | 2 +- Makefile | 56 +- snow/foreign/c.sld | 393 ------ snow/foreign/c/Makefile | 69 -- snow/foreign/c/array.scm | 58 - snow/foreign/c/c-bytevectors.scm | 1075 ----------------- snow/foreign/c/internal.scm | 50 - snow/foreign/c/libc.scm | 7 - snow/foreign/c/main.scm | 164 --- snow/foreign/c/pointer.scm | 138 --- snow/foreign/c/primitives/chibi.scm | 104 -- .../foreign/c/primitives/chibi/foreign-c.stub | 277 ----- snow/foreign/c/primitives/chicken.scm | 226 ---- snow/foreign/c/primitives/cyclone.scm | 372 ------ snow/foreign/c/primitives/gambit.scm | 252 ---- snow/foreign/c/primitives/gauche.scm | 182 --- .../primitives/gauche/define-c-procedure.scm | 25 - .../gauche/foreign-c-primitives-gauche.h | 83 -- .../foreign/c/primitives/gauche/gauchelib.scm | 101 -- snow/foreign/c/primitives/gerbil.scm | 29 - snow/foreign/c/primitives/guile.scm | 126 -- snow/foreign/c/primitives/kawa.scm | 196 --- snow/foreign/c/primitives/larceny-util.scm | 88 -- snow/foreign/c/primitives/larceny.scm | 76 -- snow/foreign/c/primitives/mit-scheme.scm | 0 snow/foreign/c/primitives/mosh.scm | 79 -- snow/foreign/c/primitives/racket.scm | 83 -- snow/foreign/c/primitives/sagittarius.scm | 124 -- snow/foreign/c/primitives/skint.scm | 3 - snow/foreign/c/primitives/stklos.scm | 110 -- snow/foreign/c/primitives/tr7.scm | 3 - snow/foreign/c/primitives/ypsilon.scm | 188 --- snow/foreign/c/struct.scm | 101 -- snow/srfi/170.scm | 143 --- snow/srfi/170.sld | 85 -- snow/srfi/srfi-170.scm | 86 -- 36 files changed, 12 insertions(+), 5142 deletions(-) delete mode 100644 snow/foreign/c.sld delete mode 100644 snow/foreign/c/Makefile delete mode 100644 snow/foreign/c/array.scm delete mode 100644 snow/foreign/c/c-bytevectors.scm delete mode 100644 snow/foreign/c/internal.scm delete mode 100644 snow/foreign/c/libc.scm delete mode 100644 snow/foreign/c/main.scm delete mode 100644 snow/foreign/c/pointer.scm delete mode 100644 snow/foreign/c/primitives/chibi.scm delete mode 100644 snow/foreign/c/primitives/chibi/foreign-c.stub delete mode 100644 snow/foreign/c/primitives/chicken.scm delete mode 100644 snow/foreign/c/primitives/cyclone.scm delete mode 100644 snow/foreign/c/primitives/gambit.scm delete mode 100644 snow/foreign/c/primitives/gauche.scm delete mode 100644 snow/foreign/c/primitives/gauche/define-c-procedure.scm delete mode 100644 snow/foreign/c/primitives/gauche/foreign-c-primitives-gauche.h delete mode 100644 snow/foreign/c/primitives/gauche/gauchelib.scm delete mode 100644 snow/foreign/c/primitives/gerbil.scm delete mode 100644 snow/foreign/c/primitives/guile.scm delete mode 100644 snow/foreign/c/primitives/kawa.scm delete mode 100644 snow/foreign/c/primitives/larceny-util.scm delete mode 100644 snow/foreign/c/primitives/larceny.scm delete mode 100644 snow/foreign/c/primitives/mit-scheme.scm delete mode 100644 snow/foreign/c/primitives/mosh.scm delete mode 100644 snow/foreign/c/primitives/racket.scm delete mode 100644 snow/foreign/c/primitives/sagittarius.scm delete mode 100644 snow/foreign/c/primitives/skint.scm delete mode 100644 snow/foreign/c/primitives/stklos.scm delete mode 100644 snow/foreign/c/primitives/tr7.scm delete mode 100644 snow/foreign/c/primitives/ypsilon.scm delete mode 100644 snow/foreign/c/struct.scm delete mode 100644 snow/srfi/170.scm delete mode 100644 snow/srfi/170.sld delete mode 100644 snow/srfi/srfi-170.scm diff --git a/.gitignore b/.gitignore index 5c65cab..c908259 100644 --- a/.gitignore +++ b/.gitignore @@ -10,5 +10,5 @@ test *.so !src *.rkt -README.txt +README.html *.import.* diff --git a/Makefile b/Makefile index 85b82bc..5cb8008 100644 --- a/Makefile +++ b/Makefile @@ -1,56 +1,22 @@ PREFIX=/usr/local -build: - csc -R r7rs -X r7rs -I snow/foreign/c -I snow/foreign/c/primitives -static -c -J -unit foreign.c -o foreign.c.o snow/foreign/c.sld - ar rcs foreign.c.a foreign.c.o - csc -R r7rs -X r7rs -static -c -J -unit srfi-170 -o srfi-170.o snow/srfi/170.sld - ar rcs srfi-170.a srfi-170.o - csc -R r7rs -X r7rs -static -c -J -unit libs.util -o libs.util.o libs/util.sld - ar rcs libs.util.a libs.util.o - csc -R r7rs -X r7rs -static -c -J -unit libs.library-util -o libs.library-util.o libs/library-util.sld - ar rcs libs.library-util.a libs.library-util.o - csc -R r7rs -X r7rs -static -c -J -unit libs.data -o libs.data.o libs/data.sld - ar rcs libs.data.a libs.data.o - csc -R r7rs -X r7rs -I snow/foreign/c -static \ - -o compile-r7rs \ - -uses libs.util \ - -uses libs.library-util \ - -uses libs.data \ - -uses foreign.c \ - -uses srfi-170 \ - compile-r7rs.scm +all: build -# 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 - #cp compile-r7rs.scm ${PREFIX}/lib/compile-r7rs/main.scm +build: + markdown README.md > README.html + echo "#!/bin/sh" > compile-r7rs + echo "chibi-scheme -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/main.scm" >> compile-r7rs + +install: + mkdir -p ${PREFIX}/lib/compile-r7rs + cp -r libs ${PREFIX}/lib/compile-r7rs/libs + cp compile-r7rs.scm ${PREFIX}/lib/compile-r7rs/main.scm install compile-r7rs ${PREFIX}/bin/compile-r7rs -snow: - mkdir -p snow - cp -r ../foreign-c/foreign snow/ - cp -r ../foreign-c-srfi-170/srfi snow/ - -clean-snow: - rm -rf snow - -install-compile-r7rs-docker: - install compile-r7rs-docker.sh ${PREFIX}/bin/compile-r7rs-docker - uninstall: - rm -rf ${PREFIX}/lib/compile-r7rs/snow + rm -rf ${PREFIX}/lib/compile-r7rs rm -rf ${PREFIX}/bin/compile-r7rs -dist: - mkdir -p dist - -# Uses wine and innosetup -installer-exe: dist - cp README.md README.txt - wine "${HOME}/.wine/drive_c/Program Files (x86)/Inno Setup 6./Compil32.exe" /cc installer.iss - test-r6rs: rm -rf /tmp/compile-r7rs-test-result.txt mkdir -p test diff --git a/snow/foreign/c.sld b/snow/foreign/c.sld deleted file mode 100644 index 655a8a2..0000000 --- a/snow/foreign/c.sld +++ /dev/null @@ -1,393 +0,0 @@ -(define-library - (foreign c) - (cond-expand - (chibi - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme process-context) - (chibi ast) - (scheme inexact) - (chibi)) - (include-shared "c/primitives/chibi/foreign-c")) - (chicken - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (chicken base) - (chicken foreign) - (chicken locative) - (chicken syntax) - (chicken memory) - (chicken random))) - #;(cyclone - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (cyclone foreign) - (scheme cyclone primitives))) - (gambit - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (only (gambit) c-declare c-lambda c-define define-macro))) - (gauche - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (gauche base) - (foreign c primitives gauche))) - #;(gerbil - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context))) - (guile - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (system foreign) - (system foreign-library) - (only (guile) include-from-path) - (only (rnrs bytevectors) - bytevector-uint-set! - bytevector-uint-ref))) - (kawa - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context))) - (mit-scheme - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context))) - #;(larceny - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (rename (primitives r5rs:require) (r5rs:require require)) - (primitives std-ffi) - (primitives foreign-procedure) - (primitives foreign-file) - (primitives foreign-stdlib) - (primitives system-interface))) - (mosh - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme inexact) - (scheme process-context) - (mosh ffi))) - (racket - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (only (racket base) system-type) - (ffi winapi) - (compatibility mlist) - (ffi unsafe) - (ffi vector))) - (sagittarius - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (except (sagittarius ffi) c-free c-malloc) - (sagittarius))) - #;(skint - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context))) - (stklos - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (only (stklos) - %make-callback - make-external-function - allocate-bytes - free-bytes - cpointer? - cpointer-null? - cpointer-data - cpointer-data-set! - cpointer-set! - cpointer-ref - void?)) - (export ; calculate-struct-size-and-offsets - ;struct-make - get-environment-variable - file-exists? - make-external-function - foreign-c:string-split - c-bytevector-pointer-set! - c-bytevector-pointer-ref)) - #;(tr7 - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - ;(scheme inexact) - (scheme process-context))) - (ypsilon - (import (scheme base) - (scheme write) - (scheme char) - (scheme file) - (scheme inexact) - (scheme process-context) - (ypsilon c-ffi) - (ypsilon c-types) - (only (core) define-macro syntax-case)))) - (export ;;;; Primitives 1 - c-type-size - define-c-library - define-c-procedure - c-bytevector? - c-bytevector-u8-set! - c-bytevector-u8-ref - c-bytevector-pointer-set! - c-bytevector-pointer-ref - - ;;;; Primitives 2 - define-c-callback - - ;;;; c-bytevector - make-c-null - c-null? - c-free - call-with-address-of - - bytevector->c-bytevector - c-bytevector->bytevector - - ;;;; Utilities - libc-name - - ;; TODO endianness - native-endianness - make-c-bytevector - ;; TODO c-bytevector=? - ;; TODO c-bytevector-fill! - ;; TODO c-bytevector-copy! - ;; TODO c-bytevector-copy - c-bytevector-s8-set! - c-bytevector-s8-ref - ;; TODO c-bytevector->u8-list - ;; TODO u8-list->c-bytevector - - c-bytevector-uchar-ref - c-bytevector-char-ref - c-bytevector-char-set! - c-bytevector-uchar-set! - - c-bytevector-uint-ref - c-bytevector-sint-ref - c-bytevector-sint-set! - c-bytevector-uint-set! - ;; TODO bytevector->uint-list - ;; TODO bytevector->sint-list - ;; TODO uint-list->bytevector - ;; TODO sint-list->bytevector - - c-bytevector-u16-ref - c-bytevector-s16-ref - c-bytevector-u16-native-ref - c-bytevector-s16-native-ref - c-bytevector-u16-set! - c-bytevector-s16-set! - c-bytevector-u16-native-set! - c-bytevector-s16-native-set! - - c-bytevector-u32-ref - c-bytevector-s32-ref - c-bytevector-u32-native-ref - c-bytevector-s32-native-ref - c-bytevector-u32-set! - c-bytevector-s32-set! - c-bytevector-u32-native-set! - c-bytevector-s32-native-set! - - c-bytevector-u64-ref - c-bytevector-s64-ref - c-bytevector-s64-native-ref - c-bytevector-u64-native-ref - c-bytevector-u64-set! - c-bytevector-s64-set! - c-bytevector-u64-native-set! - c-bytevector-s64-native-set! - - c-bytevector-ieee-single-native-ref - c-bytevector-ieee-single-ref - - c-bytevector-ieee-double-native-ref - c-bytevector-ieee-double-ref - - c-bytevector-ieee-single-native-set! - c-bytevector-ieee-single-set! - - c-bytevector-ieee-double-native-set! - c-bytevector-ieee-double-set! - - string->c-utf8 - ;; TODO string->c-utf16 - ;; TODO string->c-utf32 - - c-utf8->string - ;; TODO c-utf16->string - ;; TODO c-utf32->string - - - ;c-string-length ;; TODO Documentation, Testing - - ;; c-struct - ;pffi-define-struct;define-c-struct - ;pffi-struct-pointer;c-struct-bytevector - ;pffi-struct-offset-get;c-struct-offset - ;pffi-struct-set!;c-struct-set! - ;pffi-struct-get;c-struct-get - - ;; c-array - ;define-c-array (?) - ;pffi-array-allocate;make-c-array - ;pffi-array-pointer;c-array-pointer - ;pffi-array?;c-array? - ;pffi-pointer->array;c-bytevector->array - ;pffi-array-get;c-array-get - ;pffi-array-set!;c-array-set! - ;pffi-list->array;list->c-array - ;pffi-array->list;c-array->list - - ;; c-variable - ;define-c-variable (?) - ) - (begin - (define type->libffi-type-number - (lambda (type) - (cond ((equal? type 'int8) 1) - ((equal? type 'uint8) 2) - ((equal? type 'int16) 3) - ((equal? type 'uint16) 4) - ((equal? type 'int32) 5) - ((equal? type 'uint32) 6) - ((equal? type 'int64) 7) - ((equal? type 'uint64) 8) - ((equal? type 'char) 9) - ((equal? type 'unsigned-char) 10) - ((equal? type 'short) 11) - ((equal? type 'unsigned-short) 12) - ((equal? type 'int) 13) - ((equal? type 'unsigned-int) 14) - ((equal? type 'long) 15) - ((equal? type 'unsigned-long) 16) - ((equal? type 'float) 17) - ((equal? type 'double) 18) - ((equal? type 'void) 19) - ((equal? type 'pointer) 20) - ((equal? type 'pointer-address) 21) - ((equal? type 'callback) 22) - (else (error "Undefined type" type))))) - (define c-bytevector-get - (lambda (pointer type offset) - (cond ((equal? type 'int8) (c-bytevector-s8-ref pointer offset)) - ((equal? type 'uint8) (c-bytevector-u8-ref pointer offset)) - ((equal? type 'int16) (c-bytevector-s16-ref pointer offset)) - ((equal? type 'uint16) (c-bytevector-u16-ref pointer offset)) - ((equal? type 'int32) (c-bytevector-s32-ref pointer offset)) - ((equal? type 'uint32) (c-bytevector-u32-ref pointer offset)) - ((equal? type 'int64) (c-bytevector-s64-ref pointer offset)) - ((equal? type 'uint64) (c-bytevector-u64-ref pointer offset)) - ((equal? type 'char) (integer->char (c-bytevector-s8-ref pointer offset))) - ((equal? type 'unsigned-char) (integer->char (c-bytevector-u8-ref pointer offset))) - ((equal? type 'short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'short))) - ((equal? type 'unsigned-short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-short))) - ((equal? type 'int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'int))) - ((equal? type 'unsigned-int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-int))) - ((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'long))) - ((equal? type 'unsigned-long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-long))) - ((equal? type 'float) (c-bytevector-ieee-single-native-ref pointer offset)) - ((equal? type 'double) (c-bytevector-ieee-double-native-ref pointer offset)) - ((equal? type 'pointer) (c-bytevector-pointer-ref pointer offset)) - ((not (equal? type 'void)) (error "No such foreign type" type)) - ;; Return unspecified on purpose if type is void - )))) - #;(cond-expand - (chicken-6 (include-relative "c/internal.scm")) - (else (include "c/internal.scm"))) - (cond-expand - (chibi (include "c/primitives/chibi.scm")) - (chicken-5 (export foreign-declare - foreign-safe-lambda - void) - (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")) - (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")) - (sagittarius (include "c/primitives/sagittarius.scm")) - ;(skint (include "c/primitives/skint.scm")) - (stklos (include "c/primitives/stklos.scm")) - ;(tr7 (include "c/primitives/tr7.scm")) - (ypsilon (export c-function c-callback) - (include "c/primitives/ypsilon.scm"))) - (cond-expand - (chicken-6 (include-relative "c/main.scm") - (include-relative "c/libc.scm") - (include-relative "c/c-bytevectors.scm") - (include-relative "c/pointer.scm") - ;(include-relative "c/array.scm") - ;(include-relative "c/struct.scm") - ) - (else (include "c/main.scm") - (include "c/libc.scm") - ;(include "c/struct.scm") - (include "c/c-bytevectors.scm") - (include "c/pointer.scm") - ;(include "c/array.scm") - ))) diff --git a/snow/foreign/c/Makefile b/snow/foreign/c/Makefile deleted file mode 100644 index 3d4d0e2..0000000 --- a/snow/foreign/c/Makefile +++ /dev/null @@ -1,69 +0,0 @@ -CC=gcc - -chibi: foreign/c/primitives/chibi/foreign-c.stub - chibi-ffi foreign/c/primitives/chibi/foreign-c.stub - ${CC} \ - -g3 \ - -o foreign/c/primitives/chibi/foreign-c.so \ - foreign/c/primitives/chibi/foreign-c.c \ - -fPIC \ - -lffi \ - -shared - -chicken: - @echo "Nothing to build for Chicken" - -cyclone: - @echo "Nothing to build for Cyclone" - -gambit: - @echo "Nothing to build for Gambit" - -gauche: primitives/gauche/foreign-c-primitives-gauche.c primitives/gauche/gauchelib.scm - gauche-package compile \ - --srcdir=primitives/gauche \ - --cc=${CC} \ - --cflags="-I./primitives/include" \ - --libs=-lffi \ - foreign-c-primitives-gauche foreign-c-primitives-gauche.c gauchelib.scm - mkdir -p lib - mv foreign-c-primitives-gauche.so lib/gauche.so - mv foreign-c-primitives-gauche.o lib/gauche.o - - -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" - -clean: - @rm -rf primitives/chibi/foreign-c.c - @rm -rf lib diff --git a/snow/foreign/c/array.scm b/snow/foreign/c/array.scm deleted file mode 100644 index 9d4bd7e..0000000 --- a/snow/foreign/c/array.scm +++ /dev/null @@ -1,58 +0,0 @@ -(define-record-type - (array-make type size pointer) - pffi-array? - (type pffi-array-type) - (size pffi-array-size) - (pointer pffi-array-pointer)) - -(define pffi-list->array - (lambda (type list-arg) - (let* ((array-size (length list-arg)) - (type-size (c-size-of type)) - (array (make-c-bytevector (* type-size array-size))) - (offset 0)) - (for-each - (lambda (item) - (pffi-pointer-set! array type offset item) - (set! offset (+ offset type-size))) - list-arg) - (array-make type array-size array)))) - -(define pffi-pointer->array - (lambda (pointer type size) - (array-make type size pointer))) - -(define pffi-array->list - (lambda (array) - (letrec* ((type (pffi-array-type array)) - (type-size (c-size-of type)) - (max-offset (* type-size (pffi-array-size array))) - (array-pointer (pffi-array-pointer array)) - (looper (lambda (offset result) - (if (= offset max-offset) - result - (looper (+ offset type-size) - (append result - (list (pffi-pointer-get array-pointer - type - offset)))))))) - (looper 0 (list))))) - -(define pffi-array-allocate - (lambda (type size) - (array-make type size (pffi-pointer-allocate-calloc size (c-size-of type))))) - -(define pffi-array-get - (lambda (array index) - (let ((type (pffi-array-type array))) - (pffi-pointer-get (pffi-array-pointer array) - type - (* (c-size-of type) index))))) - -(define pffi-array-set! - (lambda (array index value) - (let ((type (pffi-array-type array))) - (pffi-pointer-set! (pffi-array-pointer array) - type - (* (c-size-of type) index) - value)))) diff --git a/snow/foreign/c/c-bytevectors.scm b/snow/foreign/c/c-bytevectors.scm deleted file mode 100644 index 1712e9d..0000000 --- a/snow/foreign/c/c-bytevectors.scm +++ /dev/null @@ -1,1075 +0,0 @@ -;;; Copyright 2025 Retropikzel -;;; -;;; Permission to copy this software, in whole or in part, to use this -;;; software for any lawful purpose, and to redistribute this software -;;; is granted subject to the restriction that all copies made of this -;;; software must include this copyright and permission notice in full. -;;; -;;; This is R6RS c-Bytevectors library, modified to work with C pointers. -;;; Mostly just by adding c- prefix to each word "bytevector". -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright 2015 William D Clinger. -;;; -;;; Permission to copy this software, in whole or in part, to use this -;;; software for any lawful purpose, and to redistribute this software -;;; is granted subject to the restriction that all copies made of this -;;; software must include this copyright and permission notice in full. -;;; -;;; I also request that you send me a copy of any improvements that you -;;; make to this software so that they may be incorporated within it to -;;; the benefit of the Scheme community. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This R7RS-portable implementation of (rnrs bytevectors) is -;;; mostly derived from Larceny's src/Lib/Common/bytevector.sch. -;;; -;;; The R6RS requires implementations to select a native endianness. -;;; That choice is arbitrary, intended to affect performance but not -;;; behavior. In this implementation, the native endianness is -;;; obtained via cond-expand, which should coincide with the -;;; endianness obtained by calling the features procedure. Of the -;;; R7RS systems I've tested, only one omits endianness from its -;;; (features), and it's a slow interpreter for which the native -;;; endianness probably won't affect performance. -;;; -;;; This implementation defines a 53-bit exact integer constant, -;;; and the procedures that work with byte fields of arbitrary -;;; width may create even larger exact integers. -;;; -;;; FIXME: It should be possible to delay creation of that 53-bit -;;; constant until it's needed, which might be better for systems -;;; that don't support exact 53-bit integers. It looks as though -;;; most systems R7RS systems either support exact 53-bit integers -;;; or overflow into inexact 53-bit integers; if the constant turns -;;; out to be inexact, then the procedure that needs it will fail -;;; when it is called, which is what would happen if creation of -;;; that constant were delayed. - -;;; Local stuff. - -(define (complain who . irritants) - (apply error - (string-append "illegal arguments passed to " - (symbol->string who)) - irritants)) - -; Help syntax and procedures; not exported. - -(define-syntax unspecified - (syntax-rules () - ((_) (if #f #f)))) - -(define-syntax c-bytevector:div - (syntax-rules () - ((_ x y) (quotient x y)))) - -(define-syntax c-bytevector:mod - (syntax-rules () - ((_ x y) (remainder x y)))) - -(define-syntax u8->s8 - (syntax-rules () - ((_ octet0) - (let ((octet octet0)) - (if (> octet 127) - (- octet 256) - octet))))) - -(define-syntax s8->u8 - (syntax-rules () - ((_ val0) - (let ((val val0)) - (if (negative? val) - (+ val 256) - val))))) - -(define (make-uint-ref size) - (lambda (c-bytevector k endianness) - (c-bytevector-uint-ref c-bytevector k endianness size))) - -(define (make-sint-ref size) - (lambda (c-bytevector k endianness) - (c-bytevector-sint-ref c-bytevector k endianness size))) - -(define (make-uint-set! size) - (lambda (c-bytevector k n endianness) - (c-bytevector-uint-set! c-bytevector k n endianness size))) - -(define (make-sint-set! size) - (lambda (c-bytevector k n endianness) - (c-bytevector-sint-set! c-bytevector k n endianness size))) - -(define (make-ref/native base base-ref) - (lambda (c-bytevector index) - (ensure-aligned index base) - (base-ref c-bytevector index (native-endianness)))) - -(define (make-set!/native base base-set!) - (lambda (c-bytevector index val) - (ensure-aligned index base) - (base-set! c-bytevector index val (native-endianness)))) - -(define (ensure-aligned index base) - (if (not (zero? (c-bytevector:mod index base))) - (error "non-aligned c-bytevector access" index base))) - -#;(define (make-c-bytevector->int-list c-bytevector-ref) - (lambda (b endness size) - (let ((ref (lambda (i) (c-bytevector-ref b i endness size))) - (length (c-bytevector-length b))) - (let loop ((i 0) (r '())) - (if (>= i length) - (reverse r) - (loop (+ i size) - (cons (ref i) r))))))) - -(define (make-int-list->c-bytevector c-bytevector-set!) - (lambda (l endness size) - (let* ((c-bytevector (make-c-bytevector (* size (length l)))) - (setter! (lambda (i n) - (c-bytevector-set! c-bytevector i n endness size)))) - (let loop ((i 0) (l l)) - (if (null? l) - c-bytevector - (begin - (setter! i (car l)) - (loop (+ i size) (cdr l)))))))) - -;;; Magic numbers for IEEE-754 single and double precision: -;;; -;;; the largest biased exponent (255 or 2047) -;;; the exponent bias (127 or 1023) -;;; the integer value of the hidden bit (2^23 or 2^52) - -(define c-bytevector:single-maxexponent 255) -(define c-bytevector:single-bias - (c-bytevector:div c-bytevector:single-maxexponent 2)) -(define c-bytevector:single-hidden-bit (expt 2 23)) - -(define c-bytevector:double-maxexponent 2047) -(define c-bytevector:double-bias - (c-bytevector:div c-bytevector:double-maxexponent 2)) -(define c-bytevector:double-hidden-bit (expt 2 52)) ; must be exact integer - -(define two^48 (expt 2 48)) -(define two^40 (expt 2 40)) -(define two^32 (expt 2 32)) -(define two^24 (expt 2 24)) -(define two^16 (expt 2 16)) -(define two^8 (expt 2 8)) - -;;; Given four exact integers, returns -;;; -;;; (-1)^sign * (2^exponent) * p/q -;;; -;;; as an inexact real. -;;; -;;; FIXME: this procedure is not used, but it might eventually -;;; become relevant to a rewrite of this implementation so I'm -;;; just commenting it out. - -#; -(define (c-bytevector:normalized sign exponent p q) - (let* ((p/q (inexact (/ p q))) - (x (* p/q (expt 2.0 exponent)))) - (cond ((= sign 0) x) - ((= x 0.0) -0.0) - (else (- x))))) - -;;; Given exact positive integers p and q, -;;; returns three values: -;;; exact integers exponent, p2, and q2 such that -;;; q2 <= p2 < q2+q2 -;;; p / q = (p2 * 2^exponent) / q2 - -(define (c-bytevector:normalized-ieee-parts p q) - (cond ((< p q) - (do ((p p (+ p p)) - (e 0 (- e 1))) - ((>= p q) - (values e p q)))) - ((<= (+ q q) p) - (do ((q q (+ q q)) - (e 0 (+ e 1))) - ((< p (+ q q)) - (values e p q)))) - (else - (values 0 p q)))) - -;;; Given an inexact real x, an exponent bias, and an exact positive -;;; integer q that is a power of 2 representing the integer value of -;;; the hidden bit, returns three exact integers: -;;; -;;; sign -;;; biased-exponent -;;; p -;;; -;;; If x is normalized, then 0 < biased-exponent <= bias+bias, -;;; q <= p < 2*q, and -;;; -;;; x = (-1)^sign * (2^(biased-exponent - bias)) * p/q -;;; -;;; If x is denormalized, then p < q and the equation holds. -;;; If x is zero, then biased-exponent and p are zero. -;;; If x is infinity, then biased-exponent = bias+bias+1 and p=0. -;;; If x is a NaN, then biased-exponent = bias+bias+1 and p>0. -;;; - -(define (c-bytevector:ieee-parts x bias q) - (cond ((nan? x) - (values 0 (+ bias bias 1) (- q 1))) - ((infinite? x) - (values (if (positive? x) 0 1) (+ bias bias 1) 0)) - ((zero? x) - (values (if (eqv? x -0.0) 1 0) 0 0)) - (else - (let* ((sign (if (negative? x) 1 0)) - (y (exact (abs x))) - (num (numerator y)) - (den (denominator y))) - (call-with-values - (lambda () (c-bytevector:normalized-ieee-parts num den)) - (lambda (exponent num den) - (let ((biased-exponent (+ exponent bias))) - (cond ((< 0 biased-exponent (+ bias bias 1)) - ; within the range of normalized numbers - (if (<= den q) - (let* ((factor (/ q den)) - (num*factor (* num factor))) - (if (integer? factor) - (values sign biased-exponent num*factor) - (error 'c-bytevector:ieee-parts - "this shouldn't happen: " x bias q))) - (let* ((factor (/ den q)) - (num*factor (/ num factor))) - (values sign - biased-exponent - (round num*factor))))) - ((>= biased-exponent (+ bias bias 1)) - ; infinity - (values (if (positive? x) 0 1) (+ bias bias 1) 0)) - (else - ; denormalized - ; FIXME: this has the double rounding bug - (do ((biased biased-exponent (+ biased 1)) - (num (round (/ (* q num) den)) - (round (c-bytevector:div num 2)))) - ((and (< num q) (= biased 1)) - (values sign biased num)))))))))))) - -;;; This procedure should work even if -;;; exact integers are limited to as little as 20 bits -;;; inexact reals are limited to IEEE single precision -;;; -;;; If inexact reals are limited to single precision, then -;;; the result might overflow, but we can't help that. - -(define (c-bytevector-ieee-double-big-endian-ref c-bytevector k) - (let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 0))) - (byte1 (c-bytevector-u8-ref c-bytevector (+ k 1))) - (byte2 (c-bytevector-u8-ref c-bytevector (+ k 2))) - (byte3 (c-bytevector-u8-ref c-bytevector (+ k 3))) - (byte4 (c-bytevector-u8-ref c-bytevector (+ k 4))) - (byte5 (c-bytevector-u8-ref c-bytevector (+ k 5))) - (byte6 (c-bytevector-u8-ref c-bytevector (+ k 6))) - (byte7 (c-bytevector-u8-ref c-bytevector (+ k 7))) - (sign (quotient byte0 128)) - (biased-exponent (+ (* 16 (remainder byte0 128)) - (quotient byte1 16))) - (hibits (+ (* 65536 (remainder byte1 16)) - (* 256 byte2) - byte3)) - (midbits (+ (* 256 byte4) byte5)) - (lobits (+ (* 256 byte6) byte7))) - (make-ieee-double sign biased-exponent hibits midbits lobits))) - -(define (c-bytevector-ieee-double-little-endian-ref c-bytevector k) - (let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 7))) - (byte1 (c-bytevector-u8-ref c-bytevector (+ k 6))) - (byte2 (c-bytevector-u8-ref c-bytevector (+ k 5))) - (byte3 (c-bytevector-u8-ref c-bytevector (+ k 4))) - (byte4 (c-bytevector-u8-ref c-bytevector (+ k 3))) - (byte5 (c-bytevector-u8-ref c-bytevector (+ k 2))) - (byte6 (c-bytevector-u8-ref c-bytevector (+ k 1))) - (byte7 (c-bytevector-u8-ref c-bytevector (+ k 0))) - (sign (quotient byte0 128)) - (biased-exponent (+ (* 16 (remainder byte0 128)) - (quotient byte1 16))) - (hibits (+ (* 65536 (remainder byte1 16)) - (* 256 byte2) - byte3)) - (midbits (+ (* 256 byte4) byte5)) - (lobits (+ (* 256 byte6) byte7))) - (make-ieee-double sign biased-exponent hibits midbits lobits))) - -;;; This procedure should work even if -;;; exact integers are limited to as little as 23 bits -;;; inexact reals are limited to IEEE single precision - -(define (c-bytevector-ieee-single-big-endian-ref c-bytevector k) - (let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 0))) - (byte1 (c-bytevector-u8-ref c-bytevector (+ k 1))) - (byte2 (c-bytevector-u8-ref c-bytevector (+ k 2))) - (byte3 (c-bytevector-u8-ref c-bytevector (+ k 3))) - (sign (quotient byte0 128)) - (biased-exponent (+ (* 2 (remainder byte0 128)) - (quotient byte1 128))) - (bits (+ (* 65536 (remainder byte1 128)) - (* 256 byte2) - byte3))) - (make-ieee-single sign biased-exponent bits))) - -(define (c-bytevector-ieee-single-little-endian-ref c-bytevector k) - (let* ((byte0 (c-bytevector-u8-ref c-bytevector (+ k 3))) - (byte1 (c-bytevector-u8-ref c-bytevector (+ k 2))) - (byte2 (c-bytevector-u8-ref c-bytevector (+ k 1))) - (byte3 (c-bytevector-u8-ref c-bytevector (+ k 0))) - (sign (quotient byte0 128)) - (biased-exponent (+ (* 2 (remainder byte0 128)) - (quotient byte1 128))) - (bits (+ (* 65536 (remainder byte1 128)) - (* 256 byte2) - byte3))) - (make-ieee-single sign biased-exponent bits))) - -;;; Given -;;; -;;; the sign bit -;;; biased exponent -;;; integer value of the 20 high order bits without the hidden bit -;;; integer value of the 16 mid-order bits -;;; integer value of the 16 low-order bits -;;; -;;; returns an inexact real approximating the IEEE double precision -;;; number with the given representation. If an implementation -;;; implements inexact reals using IEEE double precision, and -;;; implements IEEE-754 arithmetic correctly, and the arguments -;;; do not imply a NaN, then the inexact real that's returned -;;; should be exactly right. - -(define (make-ieee-double sign biased-exponent hibits midbits lobits) - (cond ((= biased-exponent c-bytevector:double-maxexponent) - (if (zero? (+ hibits midbits lobits)) - (if (= 0 sign) - +inf.0 - -inf.0) - (if (= 0 sign) - +nan.0 - -nan.0))) - ((= 0 biased-exponent) - (if (and (= 0 hibits) - (= 0 midbits) - (= 0 lobits)) - (if (= 0 sign) - +0.0 - -0.0) - (let* ((x (inexact hibits)) - (x (+ (* 65536.0 x) - (inexact midbits))) - (x (+ (* 65536.0 x) - (inexact lobits))) - (two^51 2.251799813685248e15) - (x (/ x two^51)) - (x (* x (expt 2.0 (- c-bytevector:double-bias))))) - (if (= 0 sign) - x - (- x))))) - (else - (let* ((hibits (+ #x100000 ; hidden bit - hibits)) - (x (inexact hibits)) - (x (+ (* 65536.0 x) - (inexact midbits))) - (x (+ (* 65536.0 x) - (inexact lobits))) - (two^52 4.503599627370496e15) - (x (/ x two^52)) - (x (* x (expt 2.0 - (- biased-exponent c-bytevector:double-bias))))) - (if (= 0 sign) - x - (- x)))))) - -;;; Given -;;; -;;; the sign bit -;;; biased exponent -;;; integer value of the 23-bit mantissa without the hidden bit -;;; -;;; returns an inexact real approximating the IEEE single precision -;;; number with the given representation. If an implementation -;;; implements inexact reals using IEEE single or double precision, -;;; and implements IEEE-754 arithmetic correctly, and the arguments -;;; do not imply a NaN, then the inexact real that's returned -;;; should be exactly right. - -(define (make-ieee-single sign biased-exponent bits) - (cond ((= biased-exponent c-bytevector:single-maxexponent) - (if (zero? bits) - (if (= 0 sign) - +inf.0 - -inf.0) - (if (= 0 sign) - +nan.0 - -nan.0))) - ((= 0 biased-exponent) - (if (= 0 bits) - (if (= 0 sign) - +0.0 - -0.0) - (let* ((x (inexact bits)) - (two^22 4194304.0) - (x (/ x two^22)) - (x (* x (expt 2.0 (- c-bytevector:single-bias))))) - (if (= 0 sign) - x - (- x))))) - (else - (let* ((bits (+ #x800000 ; hidden bit - bits)) - (x (inexact bits)) - (two^23 8388608.0) - (x (/ x two^23)) - (x (* x (expt 2.0 - (- biased-exponent c-bytevector:single-bias))))) - (if (= 0 sign) - x - (- x)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Exported stuff. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; The R6RS allows implementations to support other symbols as well. - -(define-syntax endianness - (syntax-rules () - ((_ big) - (quote big)) - ((_ little) - (quote little)))) - -(cond-expand - (little-endian - (define (native-endianness) - 'little)) - (else - (define (native-endianness) - 'big))) - -;;; Already defined by (scheme base): -;;; -;;; c-bytevector? make-c-bytevector c-bytevector-length - -(define (c-bytevector=? bv1 bv2) - (if (and (c-bytevector? bv1) - (c-bytevector? bv2)) - (equal? bv1 bv2) - (complain 'c-bytevector=? bv1 bv2))) - -#;(define (c-bytevector-fill! b fill) - (if (<= -128 fill -1) - (c-bytevector-fill! b (+ fill 256)) - (let ((n (c-bytevector-length b))) - (do ((i 0 (+ i 1))) - ((= i n)) - (c-bytevector-u8-set! b i fill))))) - -(define (r6rs:c-bytevector-copy! source source-start target target-start count) - (if (>= source-start target-start) - (do ((i 0 (+ i 1))) - ((>= i count)) - (c-bytevector-u8-set! target - (+ target-start i) - (c-bytevector-u8-ref source (+ source-start i)))) - (do ((i (- count 1) (- i 1))) - ((< i 0)) - (c-bytevector-u8-set! target - (+ target-start i) - (c-bytevector-u8-ref source (+ source-start i)))))) - -;;; Already defined by (scheme base), perhaps in greater generality: -;;; -;;; c-bytevector-copy -;;; c-bytevector-u8-ref -;;; c-bytevector-u8-set! - -(define (c-bytevector-s8-ref b k) - (u8->s8 (c-bytevector-u8-ref b k))) - -(define (c-bytevector-s8-set! b k val) - (c-bytevector-u8-set! b k (s8->u8 val))) - -#;(define (c-bytevector->u8-list b) - (let ((n (c-bytevector-length b))) - (do ((i (- n 1) (- i 1)) - (result '() (cons (c-bytevector-u8-ref b i) result))) - ((< i 0) - result)))) - -(define (u8-list->c-bytevector vals) - (let* ((n (length vals)) - (b (make-c-bytevector n))) - (do ((vals vals (cdr vals)) - (i 0 (+ i 1))) - ((null? vals)) - (c-bytevector-u8-set! b i (car vals))) - b)) - -(define (c-bytevector-uchar-ref c-bytevector index) - (integer->char (c-bytevector-u8-ref c-bytevector index))) - -(define (c-bytevector-uchar-set! c-bytevector index char) - (c-bytevector-u8-set! c-bytevector index (char->integer char))) - -(define (c-bytevector-char-ref c-bytevector index) - (integer->char (c-bytevector-s8-ref c-bytevector index))) - -(define (c-bytevector-char-set! c-bytevector index char) - (c-bytevector-s8-set! c-bytevector index (char->integer char))) - -(define (c-bytevector-uint-ref c-bytevector index endness size) - (case endness - ((big) - (do ((i 0 (+ i 1)) - (result 0 (+ (* 256 result) - (c-bytevector-u8-ref c-bytevector (+ index i))))) - ((>= i size) - result))) - ((little) - (do ((i (- size 1) (- i 1)) - (result 0 (+ (* 256 result) - (c-bytevector-u8-ref c-bytevector (+ index i))))) - ((< i 0) - result))) - (else - (c-bytevector-uint-ref c-bytevector index (native-endianness) size)))) - -(define (c-bytevector-sint-ref c-bytevector index endness size) - (let* ((high-byte (c-bytevector-u8-ref c-bytevector - (if (eq? endness 'big) - index - (+ index size -1)))) - (uresult (c-bytevector-uint-ref c-bytevector index endness size))) - (if (> high-byte 127) - (- uresult (expt 256 size)) - uresult))) - -; FIXME: Some of these procedures may not do enough range checking. - -(define (c-bytevector-uint-set! c-bytevector index val endness size) - (case endness - ((little) - (do ((i 0 (+ i 1)) - (val val (c-bytevector:div val 256))) - ((>= i size) - (unspecified)) - (c-bytevector-u8-set! c-bytevector (+ index i) (c-bytevector:mod val 256)))) - ((big) - (do ((i (- size 1) (- i 1)) - (val val (c-bytevector:div val 256))) - ((< i 0) - (unspecified)) - (c-bytevector-u8-set! c-bytevector (+ index i) (c-bytevector:mod val 256)))) - (else - (c-bytevector-uint-set! c-bytevector index val (native-endianness) size)))) - -(define (c-bytevector-sint-set! c-bytevector index val endness size) - (let ((uval (if (< val 0) - (+ val (expt 256 size)) - val))) - (c-bytevector-uint-set! c-bytevector index uval endness size))) - -;(define c-bytevector->uint-list (make-c-bytevector->int-list c-bytevector-uint-ref)) -;(define c-bytevector->sint-list (make-c-bytevector->int-list c-bytevector-sint-ref)) - -;(define uint-list->c-bytevector (make-int-list->c-bytevector c-bytevector-uint-set!)) -;(define sint-list->c-bytevector (make-int-list->c-bytevector c-bytevector-sint-set!)) - -(define c-bytevector-u16-ref (make-uint-ref 2)) -(define c-bytevector-s16-ref (make-sint-ref 2)) -(define c-bytevector-u16-set! (make-uint-set! 2)) -(define c-bytevector-s16-set! (make-sint-set! 2)) -(define c-bytevector-u16-native-ref (make-ref/native 2 c-bytevector-u16-ref)) -(define c-bytevector-s16-native-ref (make-ref/native 2 c-bytevector-s16-ref)) -(define c-bytevector-u16-native-set! (make-set!/native 2 c-bytevector-u16-set!)) -(define c-bytevector-s16-native-set! (make-set!/native 2 c-bytevector-s16-set!)) - -(define c-bytevector-u32-ref (make-uint-ref 4)) -(define c-bytevector-s32-ref (make-sint-ref 4)) -(define c-bytevector-u32-set! (make-uint-set! 4)) -(define c-bytevector-s32-set! (make-sint-set! 4)) -(define c-bytevector-u32-native-ref (make-ref/native 4 c-bytevector-u32-ref)) -(define c-bytevector-s32-native-ref (make-ref/native 4 c-bytevector-s32-ref)) -(define c-bytevector-u32-native-set! (make-set!/native 4 c-bytevector-u32-set!)) -(define c-bytevector-s32-native-set! (make-set!/native 4 c-bytevector-s32-set!)) - -(define c-bytevector-u64-ref (make-uint-ref 8)) -(define c-bytevector-s64-ref (make-sint-ref 8)) -(define c-bytevector-u64-set! (make-uint-set! 8)) -(define c-bytevector-s64-set! (make-sint-set! 8)) -(define c-bytevector-u64-native-ref (make-ref/native 8 c-bytevector-u64-ref)) -(define c-bytevector-s64-native-ref (make-ref/native 8 c-bytevector-s64-ref)) -(define c-bytevector-u64-native-set! (make-set!/native 8 c-bytevector-u64-set!)) -(define c-bytevector-s64-native-set! (make-set!/native 8 c-bytevector-s64-set!)) - -(cond-expand - (little-endian - (define (c-bytevector-ieee-single-native-ref c-bytevector k) - (if (not (= 0 (remainder k 4))) - (complain 'c-bytevector-ieee-single-native-ref c-bytevector k)) - (c-bytevector-ieee-single-little-endian-ref c-bytevector k)) - (define (c-bytevector-ieee-double-native-ref c-bytevector k) - (if (not (= 0 (remainder k 8))) - (complain 'c-bytevector-ieee-double-native-ref c-bytevector k)) - (c-bytevector-ieee-double-little-endian-ref c-bytevector k)) - (define (c-bytevector-ieee-single-native-set! c-bytevector k x) - (if (not (= 0 (remainder k 4))) - (complain 'c-bytevector-ieee-single-native-set! c-bytevector k x)) - (c-bytevector-ieee-single-set! c-bytevector k x 'little)) - (define (c-bytevector-ieee-double-native-set! c-bytevector k x) - (if (not (= 0 (remainder k 8))) - (complain 'c-bytevector-ieee-double-native-set! c-bytevector k x)) - (c-bytevector-ieee-double-set! c-bytevector k x 'little))) - (else - (define (c-bytevector-ieee-single-native-ref c-bytevector k) - (if (not (= 0 (remainder k 4))) - (complain 'c-bytevector-ieee-single-native-ref c-bytevector k)) - (c-bytevector-ieee-single-big-endian-ref c-bytevector k)) - (define (c-bytevector-ieee-double-native-ref c-bytevector k) - (if (not (= 0 (remainder k 8))) - (complain 'c-bytevector-ieee-double-native-ref c-bytevector k)) - (c-bytevector-ieee-double-big-endian-ref c-bytevector k)) - (define (c-bytevector-ieee-single-native-set! c-bytevector k x) - (if (not (= 0 (remainder k 4))) - (complain 'c-bytevector-ieee-single-native-set! c-bytevector k x)) - (c-bytevector-ieee-single-set! c-bytevector k x 'big)) - (define (c-bytevector-ieee-double-native-set! c-bytevector k x) - (if (not (= 0 (remainder k 8))) - (complain 'c-bytevector-ieee-double-native-set! c-bytevector k x)) - (c-bytevector-ieee-double-set! c-bytevector k x 'big)))) - -(define (c-bytevector-ieee-single-ref c-bytevector k endianness) - (case endianness - ((big) - (c-bytevector-ieee-single-big-endian-ref c-bytevector k)) - ((little) - (c-bytevector-ieee-single-little-endian-ref c-bytevector k)) - (else - (complain 'c-bytevector-ieee-single-ref c-bytevector k endianness)))) - -(define (c-bytevector-ieee-double-ref c-bytevector k endianness) - (case endianness - ((big) - (c-bytevector-ieee-double-big-endian-ref c-bytevector k)) - ((little) - (c-bytevector-ieee-double-little-endian-ref c-bytevector k)) - (else - (complain 'c-bytevector-ieee-double-ref c-bytevector k endianness)))) - -(define (c-bytevector-ieee-single-set! c-bytevector k x endianness) - (call-with-values - (lambda () - (c-bytevector:ieee-parts x - c-bytevector:single-bias - c-bytevector:single-hidden-bit)) - (lambda (sign biased-exponent frac) - (define (store! sign biased-exponent frac) - (if (eq? 'big endianness) - (begin - (c-bytevector-u8-set! c-bytevector k - (+ (* 128 sign) - (c-bytevector:div biased-exponent 2))) - (c-bytevector-u8-set! c-bytevector (+ k 1) - (+ (* 128 (c-bytevector:mod biased-exponent 2)) - (c-bytevector:div frac (* 256 256)))) - (c-bytevector-u8-set! c-bytevector (+ k 2) - (c-bytevector:div - (c-bytevector:mod frac (* 256 256)) 256)) - (c-bytevector-u8-set! c-bytevector (+ k 3) - (c-bytevector:mod frac 256))) - (begin - (c-bytevector-u8-set! c-bytevector (+ k 3) - (+ (* 128 sign) - (c-bytevector:div biased-exponent 2))) - (c-bytevector-u8-set! c-bytevector (+ k 2) - (+ (* 128 (c-bytevector:mod biased-exponent 2)) - (c-bytevector:div frac (* 256 256)))) - (c-bytevector-u8-set! c-bytevector (+ k 1) - (c-bytevector:div - (c-bytevector:mod frac (* 256 256)) 256)) - (c-bytevector-u8-set! c-bytevector k - (c-bytevector:mod frac 256)))) - (unspecified)) - (cond ((= biased-exponent c-bytevector:single-maxexponent) - (store! sign biased-exponent frac)) - ((< frac c-bytevector:single-hidden-bit) - (store! sign 0 frac)) - (else - (store! sign biased-exponent - (- frac c-bytevector:single-hidden-bit))))))) - -(define (c-bytevector-ieee-double-set! c-bytevector k x endianness) - (call-with-values - (lambda () - (c-bytevector:ieee-parts x - c-bytevector:double-bias - c-bytevector:double-hidden-bit)) - (lambda (sign biased-exponent frac) - - (define (store! sign biased-exponent frac) - (c-bytevector-u8-set! c-bytevector (+ k 7) - (+ (* 128 sign) - (c-bytevector:div biased-exponent 16))) - (c-bytevector-u8-set! c-bytevector (+ k 6) - (+ (* 16 (c-bytevector:mod biased-exponent 16)) - (c-bytevector:div frac two^48))) - (c-bytevector-u8-set! c-bytevector (+ k 5) - (c-bytevector:div (c-bytevector:mod frac two^48) - two^40)) - (c-bytevector-u8-set! c-bytevector (+ k 4) - (c-bytevector:div (c-bytevector:mod frac two^40) - two^32)) - (c-bytevector-u8-set! c-bytevector (+ k 3) - (c-bytevector:div (c-bytevector:mod frac two^32) - two^24)) - (c-bytevector-u8-set! c-bytevector (+ k 2) - (c-bytevector:div (c-bytevector:mod frac two^24) - two^16)) - (c-bytevector-u8-set! c-bytevector (+ k 1) - (c-bytevector:div (c-bytevector:mod frac two^16) - 256)) - (c-bytevector-u8-set! c-bytevector k - (c-bytevector:mod frac 256)) - (if (not (eq? endianness 'little)) - (begin (swap! (+ k 0) (+ k 7)) - (swap! (+ k 1) (+ k 6)) - (swap! (+ k 2) (+ k 5)) - (swap! (+ k 3) (+ k 4)))) - (unspecified)) - - (define (swap! i j) - (let ((bi (c-bytevector-u8-ref c-bytevector i)) - (bj (c-bytevector-u8-ref c-bytevector j))) - (c-bytevector-u8-set! c-bytevector i bj) - (c-bytevector-u8-set! c-bytevector j bi))) - - (cond ((= biased-exponent c-bytevector:double-maxexponent) - (store! sign biased-exponent frac)) - ((< frac c-bytevector:double-hidden-bit) - (store! sign 0 frac)) - (else - (store! sign biased-exponent - (- frac c-bytevector:double-hidden-bit))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; -; Conversions between c-bytevectors and strings. -; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Already defined by (scheme base), with greater generality: -;;; -;;; string->utf8 -;;; utf8->string - -; (utf-16-codec) might write a byte order mark, -; so it's better not to use textual i/o for this. - -(define (string->utf16 string . rest) - (let* ((endianness (cond ((null? rest) - 'big) - ((not (null? (cdr rest))) - (apply complain 'string->utf16 string rest)) - ((eq? (car rest) 'big) - 'big) - ((eq? (car rest) 'little) - 'little) - (else - (apply complain 'string->utf16 string rest)))) - - ; endianness-dependent adjustments to indexing - - (hi (if (eq? 'big endianness) 0 1)) - (lo (- 1 hi)) - - (n (string-length string))) - - (define (result-length) - (do ((i 0 (+ i 1)) - (k 0 (let ((sv (char->integer (string-ref string i)))) - (if (< sv #x10000) (+ k 2) (+ k 4))))) - ((= i n) k))) - - (let ((bv (make-c-bytevector (result-length)))) - - (define (loop i k) - (if (< i n) - (let ((sv (char->integer (string-ref string i)))) - (if (< sv #x10000) - (let ((hibits (quotient sv 256)) - (lobits (remainder sv 256))) - (c-bytevector-u8-set! bv (+ k hi) hibits) - (c-bytevector-u8-set! bv (+ k lo) lobits) - (loop (+ i 1) (+ k 2))) - (let* ((x (- sv #x10000)) - (hibits (quotient x 1024)) - (lobits (remainder x 1024)) - (hi16 (+ #xd800 hibits)) - (lo16 (+ #xdc00 lobits)) - (hi1 (quotient hi16 256)) - (lo1 (remainder hi16 256)) - (hi2 (quotient lo16 256)) - (lo2 (remainder lo16 256))) - (c-bytevector-u8-set! bv (+ k hi) hi1) - (c-bytevector-u8-set! bv (+ k lo) lo1) - (c-bytevector-u8-set! bv (+ k hi 2) hi2) - (c-bytevector-u8-set! bv (+ k lo 2) lo2) - (loop (+ i 1) (+ k 4))))))) - - (loop 0 0) - bv))) - -;;; The second argument to utf16->string should be optional, -;;; and was optional in the R5.94RS draft, but was made mandatory -;;; in the R5.95RS draft by someone who misinterpreted John Cowan's -;;; response of 27 May 2007 to an ambiguous question posed by -;;; Mike Sperber. This error was not spotted by anyone, and -;;; made its way into the ratified R6RS. -;;; -;;; This implementation does not perpetuate that error. In this -;;; implementation, the second argument is optional. -;;; -;;; The R6RS also contradicts itself by saying the c-bytevector -;;; will be decoded according to UTF-16BE or UTF-16LE, which -;;; implies any BOM must be ignored. I believe the intended -;;; specification was along these lines: -;;; -;;; c-Bytevector is decoded acccording to UTF-16, UTF-16BE, -;;; UTF-16LE, or a fourth encoding scheme that differs from -;;; all three of those, depending upon the optional arguments -;;; endianness and endianness-mandatory. If endianness -;;; is the symbol big and endianness-mandatory is absent -;;; or false, then c-bytevector is decoded according to -;;; UTF-16. If endianness is the symbol big and -;;; endianness-mandatory is #t, then c-bytevector is decoded -;;; according to UTF-16BE. If endianness is the symbol -;;; little and endianness-mandatory is #t, then c-bytevector -;;; is decoded according to UTF-16LE. If endianness is -;;; the symbol little and endianness-mandatory is absent -;;; or #f, then the c-bytevector is decoded according to -;;; UTF-16 if it begins with a BOM but is decoded according -;;; to UTF-16LE if it does not begin with a BOM; note that -;;; this fourth decoding does not correspond to any of the -;;; Unicode encoding schemes that are defined by the Unicode -;;; standard. -;;; -;;; That is the specification implemented here. - -#;(define (utf16->string c-bytevector . rest) - (let* ((n (c-bytevector-length c-bytevector)) - - (begins-with-bom? - (and (<= 2 n) - (let ((b0 (c-bytevector-u8-ref c-bytevector 0)) - (b1 (c-bytevector-u8-ref c-bytevector 1))) - (or (and (= b0 #xfe) (= b1 #xff) 'big) - (and (= b0 #xff) (= b1 #xfe) 'little))))) - - (mandatory? (cond ((or (null? rest) (null? (cdr rest))) - #f) - ((and (null? (cddr rest)) - (boolean? (cadr rest))) - (cadr rest)) - (else - (apply complain 'utf16->string c-bytevector rest)))) - - (endianness (cond ((null? rest) - (or begins-with-bom? 'big)) - ((eq? (car rest) 'big) - (if mandatory? - 'big - (or begins-with-bom? 'big))) - ((eq? (car rest) 'little) - (if mandatory? - 'little - (or begins-with-bom? 'little))) - (else (apply complain - 'utf16->string - c-bytevector rest)))) - - (begins-with-bom? (if mandatory? #f begins-with-bom?)) - - (endianness (if mandatory? (car rest) endianness)) - - ; endianness-dependent adjustments to indexing - - (hi (if (eq? 'big endianness) 0 1)) - (lo (- 1 hi)) - - (replacement-character (integer->char #xfffd))) - - ; computes the length of the encoded string - - (define (result-length) - (define (loop i k) - (if (>= i n) - k - (let ((octet (c-bytevector-u8-ref c-bytevector i))) - (cond ((< octet #xd8) - (loop (+ i 2) (+ k 1))) - ((< octet #xdc) - (let* ((i2 (+ i 2)) - (octet2 (if (< i2 n) - (c-bytevector-u8-ref c-bytevector i2) - 0))) - (if (<= #xdc octet2 #xdf) - (loop (+ i 4) (+ k 1)) - ; bad surrogate pair, becomes replacement character - (loop i2 (+ k 1))))) - (else (loop (+ i 2) (+ k 1))))))) - (if begins-with-bom? - (loop (+ hi 2) 0) - (loop hi 0))) - - (if (odd? n) - (error "c-bytevector passed to utf16->string has odd length" c-bytevector)) - - (let ((s (make-string (result-length)))) - (define (loop i k) - (if (< i n) - (let ((hibits (c-bytevector-u8-ref c-bytevector (+ i hi))) - (lobits (c-bytevector-u8-ref c-bytevector (+ i lo)))) - (cond ((< hibits #xd8) - (let ((c (integer->char - (+ (* hibits 256) - lobits)))) - (string-set! s k c)) - (loop (+ i 2) (+ k 1))) - ((< hibits #xdc) - (let* ((i2 (+ i hi 2)) - (i3 (+ i lo 2)) - (octet2 (if (< i2 n) - (c-bytevector-u8-ref c-bytevector i2) - 0)) - (octet3 (if (< i2 n) - (c-bytevector-u8-ref c-bytevector i3) - 0))) - (if (<= #xdc octet2 #xdf) - (let* ((sv (+ #x10000 - (* #x0400 - (remainder - (+ (* hibits 256) - lobits) - #x0400)) - (remainder - (+ (* octet2 256) - octet3) - #x0400))) - (c (if (<= #x10000 sv #x10ffff) - (integer->char sv) - replacement-character))) - (string-set! s k c) - (loop (+ i 4) (+ k 1))) - ; bad surrogate pair - (begin (string-set! s k replacement-character) - (loop (+ i 2) (+ k 1)))))) - ((< hibits #xe0) - ; second surrogate not preceded by a first surrogate - (string-set! s k replacement-character) - (loop (+ i 2) (+ k 1))) - (else - (let ((c (integer->char - (+ (* hibits 256) - lobits)))) - (string-set! s k c)) - (loop (+ i 2) (+ k 1))))))) - (if begins-with-bom? - (loop 2 0) - (loop 0 0)) - s))) - -;;; There is no utf-32-codec, so we can't use textual i/o for this. - -(define (string->utf32 string . rest) - (let* ((endianness (cond ((null? rest) 'big) - ((eq? (car rest) 'big) 'big) - ((eq? (car rest) 'little) 'little) - (else (apply complain - 'string->utf32 - string - rest)))) - (n (string-length string)) - (result (make-c-bytevector (* 4 n)))) - (do ((i 0 (+ i 1))) - ((= i n) result) - (c-bytevector-u32-set! result - (* 4 i) - (char->integer (string-ref string i)) - endianness)))) - -;;; There is no utf-32-codec, so we can't use textual i/o for this. - -#;(define (utf32->string c-bytevector . rest) - (let* ((n (c-bytevector-length c-bytevector)) - - (begins-with-bom? - (and (<= 4 n) - (let ((b0 (c-bytevector-u8-ref c-bytevector 0)) - (b1 (c-bytevector-u8-ref c-bytevector 1)) - (b2 (c-bytevector-u8-ref c-bytevector 2)) - (b3 (c-bytevector-u8-ref c-bytevector 3))) - (or (and (= b0 0) (= b1 0) (= b2 #xfe) (= b3 #xff) - 'big) - (and (= b0 #xff) (= b1 #xfe) (= b2 0) (= b3 0) - 'little))))) - - (mandatory? (cond ((or (null? rest) (null? (cdr rest))) - #f) - ((and (null? (cddr rest)) - (boolean? (cadr rest))) - (cadr rest)) - (else - (apply complain 'utf32->string c-bytevector rest)))) - - (endianness (cond ((null? rest) - (or begins-with-bom? 'big)) - ((eq? (car rest) 'big) - (if mandatory? - 'big - (or begins-with-bom? 'big))) - ((eq? (car rest) 'little) - (if mandatory? - 'little - (or begins-with-bom? 'little))) - (else (apply complain - 'utf32->string - c-bytevector - rest)))) - - (begins-with-bom? (if mandatory? #f begins-with-bom?)) - - (endianness (if mandatory? (car rest) endianness)) - - (i0 (if begins-with-bom? 4 0)) - - (result (if (zero? (remainder n 4)) - (make-string (quotient (- n i0) 4)) - (complain - "c-bytevector passed to utf32->string has bad length" - c-bytevector)))) - - (do ((i i0 (+ i 4)) - (j 0 (+ j 1))) - ((= i n) result) - (let* ((sv (c-bytevector-u32-ref c-bytevector i endianness)) - (sv (cond ((< sv #xd800) sv) - ((< sv #xe000) #xfffd) ; replacement character - ((< sv #x110000) sv) - (else #xfffd))) ; replacement character - (c (integer->char sv))) - (string-set! result j c))))) diff --git a/snow/foreign/c/internal.scm b/snow/foreign/c/internal.scm deleted file mode 100644 index ff8be0b..0000000 --- a/snow/foreign/c/internal.scm +++ /dev/null @@ -1,50 +0,0 @@ -(define type->libffi-type-number - (lambda (type) - (cond ((equal? type 'int8) 1) - ((equal? type 'uint8) 2) - ((equal? type 'int16) 3) - ((equal? type 'uint16) 4) - ((equal? type 'int32) 5) - ((equal? type 'uint32) 6) - ((equal? type 'int64) 7) - ((equal? type 'uint64) 8) - ((equal? type 'char) 9) - ((equal? type 'unsigned-char) 10) - ((equal? type 'short) 11) - ((equal? type 'unsigned-short) 12) - ((equal? type 'int) 13) - ((equal? type 'unsigned-int) 14) - ((equal? type 'long) 15) - ((equal? type 'unsigned-long) 16) - ((equal? type 'float) 17) - ((equal? type 'double) 18) - ((equal? type 'void) 19) - ((equal? type 'pointer) 20) - ((equal? type 'pointer-address) 21) - ((equal? type 'callback) 22) - (else (error "Undefined type" type))))) - -(define c-bytevector-get - (lambda (pointer type offset) - (cond ((equal? type 'int8) (c-bytevector-s8-ref pointer offset)) - ((equal? type 'uint8) (c-bytevector-u8-ref pointer offset)) - ((equal? type 'int16) (c-bytevector-s16-ref pointer offset)) - ((equal? type 'uint16) (c-bytevector-u16-ref pointer offset)) - ((equal? type 'int32) (c-bytevector-s32-ref pointer offset)) - ((equal? type 'uint32) (c-bytevector-u32-ref pointer offset)) - ((equal? type 'int64) (c-bytevector-s64-ref pointer offset)) - ((equal? type 'uint64) (c-bytevector-u64-ref pointer offset)) - ((equal? type 'char) (integer->char (c-bytevector-s8-ref pointer offset))) - ((equal? type 'unsigned-char) (integer->char (c-bytevector-u8-ref pointer offset))) - ((equal? type 'short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'short))) - ((equal? type 'unsigned-short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-short))) - ((equal? type 'int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'int))) - ((equal? type 'unsigned-int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-int))) - ((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'long))) - ((equal? type 'unsigned-long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-long))) - ((equal? type 'float) (c-bytevector-ieee-single-native-ref pointer offset)) - ((equal? type 'double) (c-bytevector-ieee-double-native-ref pointer offset)) - ((equal? type 'pointer) (c-bytevector-pointer-ref pointer offset)) - ((not (equal? type 'void)) (error "No such foreign type" type)) - ;; Return unspecified on purpose if type is void - ))) diff --git a/snow/foreign/c/libc.scm b/snow/foreign/c/libc.scm deleted file mode 100644 index 27ec05f..0000000 --- a/snow/foreign/c/libc.scm +++ /dev/null @@ -1,7 +0,0 @@ -(cond-expand - (windows - (define libc-name "ucrtbase")) - (else - (define libc-name - (cond ((get-environment-variable "BE_HOST_CPU") "root") ; Haiku - (else "c"))))) diff --git a/snow/foreign/c/main.scm b/snow/foreign/c/main.scm deleted file mode 100644 index af2782c..0000000 --- a/snow/foreign/c/main.scm +++ /dev/null @@ -1,164 +0,0 @@ -(define c-type-size - (lambda (type) - (size-of-type type))) - -(define foreign-c:string-split - (lambda (str mark) - (let* ((str-l (string->list str)) - (res (list)) - (last-index 0) - (index 0) - (splitter (lambda (c) - (cond ((char=? c mark) - (begin - (set! res (append res (list (string-copy str last-index index)))) - (set! last-index (+ index 1)))) - ((equal? (length str-l) (+ index 1)) - (set! res (append res (list (string-copy str last-index (+ index 1))))))) - (set! index (+ index 1))))) - (for-each splitter str-l) - res))) - -(cond-expand - (gambit #t) ; Defined in gambit.scm - (chicken #t) ; Defined in chicken.scm - (cyclone #t) ; Defined in cyclone.scm - (else - (define-syntax define-c-library - (syntax-rules () - ((_ scheme-name headers object-name options) - (define scheme-name - (let* ((internal-options (if (null? 'options) - (list) - (cadr 'options))) - (additional-paths (if (assoc 'additional-paths internal-options) - (cadr (assoc 'additional-paths internal-options)) - (list))) - (additional-versions (if (assoc 'additional-versions internal-options) - (map (lambda (version) - (if (number? version) - (number->string version) - version)) - (cadr (assoc 'additional-versions internal-options))) - (list))) - (slash (cond-expand (windows (string #\\)) (else "/"))) - (auto-load-paths - (cond-expand - (windows - (append - (if (get-environment-variable "FOREIGN_C_LOAD_PATH") - (foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\;) - (list)) - (if (get-environment-variable "SYSTEM") - (list (get-environment-variable "SYSTEM")) - (list)) - (if (get-environment-variable "WINDIR") - (list (get-environment-variable "WINDIR")) - (list)) - (if (get-environment-variable "WINEDLLDIR0") - (list (get-environment-variable "WINEDLLDIR0")) - (list)) - (if (get-environment-variable "SystemRoot") - (list (string-append - (get-environment-variable "SystemRoot") - slash - "system32")) - (list)) - (list ".") - (if (get-environment-variable "PATH") - (foreign-c:string-split (get-environment-variable "PATH") #\;) - (list)) - (if (get-environment-variable "PWD") - (list (get-environment-variable "PWD")) - (list)))) - (else - (append - (if (get-environment-variable "FOREIGN_C_LOAD_PATH") - (foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\:) - (list)) - ; Guix - (list (if (get-environment-variable "GUIX_ENVIRONMENT") - (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") - "") - "/run/current-system/profile/lib") - ; Debian - (if (get-environment-variable "LD_LIBRARY_PATH") - (foreign-c:string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) - (list)) - (list - ;;; x86-64 - ; Debian - "/lib/x86_64-linux-gnu" - "/usr/lib/x86_64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - ;;; aarch64 - ; Debian - "/lib/aarch64-linux-gnu" - "/usr/lib/aarch64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - ; NetBSD - "/usr/pkg/lib" - ; Haiku - "/boot/system/lib"))))) - (auto-load-versions (list "")) - (paths (append auto-load-paths additional-paths)) - (versions (append additional-versions auto-load-versions)) - (platform-lib-prefix (cond-expand (windows "") (else "lib"))) - (platform-file-extension (cond-expand (windows ".dll") (else ".so"))) - (shared-object #f) - (searched-paths (list))) - (for-each - (lambda (path) - (for-each - (lambda (version) - (let ((library-path - (string-append path - slash - platform-lib-prefix - object-name - (cond-expand - (windows "") - (else platform-file-extension)) - (if (string=? version "") - "" - (string-append - (cond-expand (windows "-") - (else ".")) - version)) - (cond-expand - (windows platform-file-extension) - (else "")))) - (library-path-without-suffixes (string-append path - slash - platform-lib-prefix - object-name))) - (set! searched-paths (append searched-paths (list library-path))) - (when (and (not shared-object) - (file-exists? library-path)) - (set! shared-object - (cond-expand (racket library-path-without-suffixes) - (else library-path)))))) - versions)) - paths) - (if (not shared-object) - (begin - (display "Could not load shared object: ") - (write (list (cons 'object object-name) - (cons 'paths paths) - (cons 'platform-file-extension platform-file-extension) - (cons 'versions versions))) - (newline) - (display "Searched paths: ") - (write searched-paths) - (newline) - (exit 1)) - (cond-expand - (stklos shared-object) - (else (shared-object-load shared-object - `((additional-versions ,additional-versions))))))))))))) diff --git a/snow/foreign/c/pointer.scm b/snow/foreign/c/pointer.scm deleted file mode 100644 index d33f40e..0000000 --- a/snow/foreign/c/pointer.scm +++ /dev/null @@ -1,138 +0,0 @@ -(define-c-library libc - '("stdlib.h" "stdio.h" "string.h") - libc-name - '((additional-versions ("0" "6")))) - -(define-c-procedure c-calloc libc 'calloc 'pointer '(int int)) -(cond-expand - (gambit - (define c-memset-address->pointer - (c-lambda (unsigned-int64 unsigned-int8 int) - (pointer void) - "___return(memset((void*)___arg1, ___arg2, ___arg3));"))) - (chicken - (define c-memset-address->pointer - (lambda (address value offset) - (address->pointer address)))) - (else - (define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int)))) - -(cond-expand - (gambit - (define c-memset-pointer->address - (c-lambda ((pointer void) unsigned-int8 int) - unsigned-int64 - "___return((uint64_t)memset(___arg1, ___arg2, ___arg3));"))) - (chicken (define c-memset-pointer->address - (lambda (pointer value offset) - (pointer->address pointer)))) - (else (define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int)))) -;(define-c-procedure c-memset-address libc 'memset 'pointer '(uint64 uint8 int)) -;(define-c-procedure c-printf libc 'printf 'int '(pointer pointer)) -(define-c-procedure c-malloc libc 'malloc 'pointer '(int)) -(define-c-procedure c-strlen libc 'strlen 'int '(pointer)) - -(define make-c-bytevector - (lambda (k . byte) - (if (null? byte) - (c-malloc k) - (bytevector->c-bytevector (make-bytevector k (car byte)))))) - -(define c-bytevector - (lambda bytes - (bytevector->c-bytevector (apply bytevector bytes)))) - -(cond-expand - (else (define-c-procedure c-free libc 'free 'void '(pointer)))) - -(define bytevector->c-bytevector - (lambda (bytes) - (letrec* ((bytes-length (bytevector-length bytes)) - (pointer (make-c-bytevector bytes-length)) - (looper (lambda (index) - (when (< index bytes-length) - (c-bytevector-u8-set! pointer - index - (bytevector-u8-ref bytes index)) - (looper (+ index 1)))))) - (looper 0) - pointer))) - -(define c-bytevector->bytevector - (lambda (pointer size) - (letrec* ((bytes (make-bytevector size)) - (looper (lambda (index) - (let ((byte (c-bytevector-u8-ref pointer index))) - (if (= index size) - bytes - (begin - (bytevector-u8-set! bytes index byte) - (looper (+ index 1)))))))) - (looper 0)))) - -(define c-string-length - (lambda (bytevector-var) - (c-strlen bytevector-var))) - -(define c-utf8->string - (lambda (c-bytevector) - (let ((size (c-strlen c-bytevector))) - (utf8->string (c-bytevector->bytevector c-bytevector size))))) - -(define string->c-utf8 - (lambda (string-var) - (bytevector->c-bytevector (string->utf8 (string-append string-var (string #\null)))))) - -(cond-expand - (chicken #t) ; FIXME - (kawa #t) ; FIXME - (else (define make-c-null - (lambda () - (cond-expand (stklos (let ((pointer (make-c-bytevector 1))) - (free-bytes pointer) - pointer)) - (else (c-memset-address->pointer 0 0 0))))))) - -(cond-expand - (chicken #t) ; FIXME - (kawa #t) ; FIXME - (else (define c-null? - (lambda (pointer) - (if (c-bytevector? pointer) - (= (c-memset-pointer->address pointer 0 0) 0) - #f))))) - -#;(define c-bytevector->address - (lambda (c-bytevector) - (c-memset-pointer->address c-bytevector 0 0))) - -#;(define address->c-bytevector - (lambda (address) - (c-memset-address->pointer address 0 0))) - -#;(define c-bytevector-pointer-set! - (lambda (c-bytevector k pointer) - (c-bytevector-uint-set! c-bytevector - 0 - (c-bytevector->address pointer) - (native-endianness) - (c-type-size 'pointer)))) - -#;(define c-bytevector-pointer-ref - (lambda (c-bytevector k) - (address->c-bytevector (c-bytevector-uint-ref c-bytevector - 0 - (native-endianness) - (c-type-size 'pointer))))) - -(cond-expand - ;(kawa #t) ; Defined in kawa.scm - (else (define-syntax call-with-address-of - (syntax-rules () - ((_ input-pointer thunk) - (let ((address-pointer (make-c-bytevector (c-type-size 'pointer)))) - (c-bytevector-pointer-set! address-pointer 0 input-pointer) - (let ((result (apply thunk (list address-pointer)))) - (set! input-pointer (c-bytevector-pointer-ref address-pointer 0)) - (c-free address-pointer) - result))))))) diff --git a/snow/foreign/c/primitives/chibi.scm b/snow/foreign/c/primitives/chibi.scm deleted file mode 100644 index e9ffc95..0000000 --- a/snow/foreign/c/primitives/chibi.scm +++ /dev/null @@ -1,104 +0,0 @@ -(define size-of-type - (lambda (type) - (cond ((eq? type 'int8) (size-of-int8_t)) - ((eq? type 'uint8) (size-of-uint8_t)) - ((eq? type 'int16) (size-of-int16_t)) - ((eq? type 'uint16) (size-of-uint16_t)) - ((eq? type 'int32) (size-of-int32_t)) - ((eq? type 'uint32) (size-of-uint32_t)) - ((eq? type 'int64) (size-of-int64_t)) - ((eq? type 'uint64) (size-of-uint64_t)) - ((eq? type 'char) (size-of-char)) - ((eq? type 'unsigned-char) (size-of-char)) - ((eq? type 'short) (size-of-short)) - ((eq? type 'unsigned-short) (size-of-unsigned-short)) - ((eq? type 'int) (size-of-int)) - ((eq? type 'unsigned-int) (size-of-unsigned-int)) - ((eq? type 'long) (size-of-long)) - ((eq? type 'unsigned-long) (size-of-unsigned-long)) - ((eq? type 'float) (size-of-float)) - ((eq? type 'double) (size-of-double)) - ((eq? type 'pointer) (size-of-pointer)) - ((eq? type 'pointer-address) (size-of-pointer)) - ((eq? type 'callback) (size-of-pointer)) - ((eq? type 'void) 0) - (else #f)))) - -(define shared-object-load - (lambda (path options) - (let ((shared-object (dlopen path RTLD-NOW)) - (maybe-error (dlerror))) - shared-object))) - -(define c-bytevector? - (lambda (object) - (or (equal? object #f) ; False can be null pointer - (pointer? object)))) - -(define pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'int8_t) - ((equal? type 'uint8) 'uint8_t) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32_t) - ((equal? type 'uint32) 'uint32_t) - ((equal? type 'int64) 'int64_t) - ((equal? type 'uint64) 'uint64_t) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) '(maybe-null pointer void*)) - ((equal? type 'pointer-address) '(maybe-null pointer void*)) - ((equal? type 'void) 'void) - ((equal? type 'callback) '(maybe-null pointer void*)) - (else (error "pffi-type->native-type -- No such pffi type" type))))) - -;; define-c-procedure - -(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) - (map type->libffi-type-number argument-types) - c-function - (c-type-size return-type) - arguments))) - (c-bytevector-get return-pointer return-type 0)))))) - -(define-syntax define-c-procedure - (syntax-rules () - ((_ scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (make-c-function shared-object - (symbol->string c-name) - return-type - argument-types))))) - -(define make-c-callback - (lambda (return-type argument-types procedure) - (scheme-procedure-to-pointer procedure))) - -(define-syntax define-c-callback - (syntax-rules () - ((_ scheme-name return-type argument-types procedure) - (define scheme-name - (make-c-callback return-type 'argument-types procedure))))) diff --git a/snow/foreign/c/primitives/chibi/foreign-c.stub b/snow/foreign/c/primitives/chibi/foreign-c.stub deleted file mode 100644 index c332acc..0000000 --- a/snow/foreign/c/primitives/chibi/foreign-c.stub +++ /dev/null @@ -1,277 +0,0 @@ -; vim: ft=scheme - -(c-system-include "stdint.h") -(c-system-include "dlfcn.h") -(c-system-include "stdio.h") -(c-system-include "ffi.h") -(c-link "ffi") - -;; make-c-null -(c-declare "void* make_c_null() { return NULL; }") -(define-c (maybe-null pointer void*) make-c-null ()) - -;; c-type-size -(c-declare " - int size_of_int8_t() { return sizeof(int8_t); } - int size_of_uint8_t() { return sizeof(uint8_t); } - int size_of_int16_t() { return sizeof(int16_t); } - int size_of_uint16_t() { return sizeof(uint16_t); } - int size_of_int32_t() { return sizeof(int32_t); } - int size_of_uint32_t() { return sizeof(uint32_t); } - int size_of_int64_t() { return sizeof(int64_t); } - int size_of_uint64_t() { return sizeof(uint64_t); } - int size_of_char() { return sizeof(char); } - int size_of_unsigned_char() { return sizeof(unsigned char); } - int size_of_short() { return sizeof(short); } - int size_of_unsigned_short() { return sizeof(unsigned short); } - int size_of_int() { return sizeof(int); } - int size_of_unsigned_int() { return sizeof(unsigned int); } - int size_of_long() { return sizeof(long); } - int size_of_unsigned_long() { return sizeof(unsigned long); } - int size_of_float() { return sizeof(float); } - int size_of_double() { return sizeof(double); } - int size_of_pointer() { return sizeof(void*); } -") - -(define-c int (size-of-int8_t size_of_int8_t) ()) -(define-c int (size-of-uint8_t size_of_uint8_t) ()) -(define-c int (size-of-int16_t size_of_int16_t) ()) -(define-c int (size-of-uint16_t size_of_uint16_t) ()) -(define-c int (size-of-int32_t size_of_int32_t) ()) -(define-c int (size-of-uint32_t size_of_uint32_t) ()) -(define-c int (size-of-int64_t size_of_int64_t) ()) -(define-c int (size-of-uint64_t size_of_uint64_t) ()) -(define-c int (size-of-char size_of_char) ()) -(define-c int (size-of-unsigned-char size_of_unsigned_char) ()) -(define-c int (size-of-short size_of_short) ()) -(define-c int (size-of-unsigned-short size_of_unsigned_short) ()) -(define-c int (size-of-int size_of_int) ()) -(define-c int (size-of-unsigned-int size_of_unsigned_int) ()) -(define-c int (size-of-long size_of_long) ()) -(define-c int (size-of-unsigned-long size_of_unsigned_long) ()) -(define-c int (size-of-float size_of_float) ()) -(define-c int (size-of-double size_of_double) ()) -(define-c int (size-of-pointer size_of_pointer) ()) - -;; shared-object-load -(define-c-const int (RTLD-NOW "RTLD_NOW")) -(define-c (maybe-null pointer void*) dlopen (string int)) -(define-c (maybe-null pointer void*) dlerror ()) - -(c-declare "sexp is_pointer(struct sexp_struct* object) { if(sexp_cpointerp(object)) { return SEXP_TRUE; } else { return SEXP_FALSE; } }") -(define-c sexp (pointer? is_pointer) (sexp)) - -(c-declare "void c_bytevector_u8_set(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }") -(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) ((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) ((maybe-null pointer void*) int)) - -(c-declare "ffi_cif cif;") -(define-c (maybe-null pointer void*) dlsym ((maybe-null pointer void*) string)) - -(define-c-const int (FFI-OK "FFI_OK")) -(c-declare - "void* internal_ffi_call( - unsigned int nargs, - unsigned int rtype, - unsigned int atypes[], - void* fn, - unsigned int rvalue_size, - struct sexp_struct* avalues[]) - { - ffi_type* c_atypes[nargs]; - void* c_avalues[nargs]; - - int8_t vals1[nargs]; - uint8_t vals2[nargs]; - int16_t vals3[nargs]; - uint16_t vals4[nargs]; - int32_t vals5[nargs]; - uint32_t vals6[nargs]; - int64_t vals7[nargs]; - uint64_t vals8[nargs]; - char vals9[nargs]; - unsigned char vals10[nargs]; - short vals11[nargs]; - unsigned short vals12[nargs]; - int vals13[nargs]; - unsigned int vals14[nargs]; - long vals15[nargs]; - unsigned long vals16[nargs]; - float vals17[nargs]; - double vals18[nargs]; - void* vals20[nargs]; - - printf(\"nargs: %i\\n\", nargs); - for(int i = 0; i < nargs; i++) { - printf(\"i: %i\\n\", i); - void* arg = NULL; - switch(atypes[i]) { - case 1: - c_atypes[i] = &ffi_type_sint8; - vals1[i] = (int8_t)sexp_sint_value(avalues[i]); - c_avalues[i] = &vals1[i]; - break; - case 2: - c_atypes[i] = &ffi_type_uint8; - vals2[i] = (uint8_t)sexp_uint_value(avalues[i]); - c_avalues[i] = &vals2[i]; - break; - case 3: - c_atypes[i] = &ffi_type_sint16; - vals3[i] = (int16_t)sexp_sint_value(avalues[i]); - c_avalues[i] = &vals3[i]; - break; - case 4: - c_atypes[i] = &ffi_type_uint16; - vals4[i] = (uint16_t)sexp_uint_value(avalues[i]); - c_avalues[i] = &vals4[i]; - break; - case 5: - c_atypes[i] = &ffi_type_sint32; - vals5[i] = (int32_t)sexp_sint_value(avalues[i]); - c_avalues[i] = &vals5[i]; - break; - case 6: - c_atypes[i] = &ffi_type_uint32; - vals6[i] = (int64_t)sexp_uint_value(avalues[i]); - c_avalues[i] = &vals6[i]; - break; - case 7: - c_atypes[i] = &ffi_type_sint64; - vals7[i] = (int64_t) sexp_sint_value(avalues[i]); - c_avalues[i] = &vals7[i]; - break; - case 8: - c_atypes[i] = &ffi_type_uint64; - vals8[i] = (uint64_t)sexp_uint_value(avalues[i]); - c_avalues[i] = &vals8[i]; - break; - case 9: - c_atypes[i] = &ffi_type_schar; - vals9[i] = (char)sexp_sint_value(avalues[i]); - c_avalues[i] = &vals9[i]; - break; - case 10: - c_atypes[i] = &ffi_type_uchar; - vals10[i] = (unsigned char)sexp_uint_value(avalues[i]); - break; - case 11: - c_atypes[i] = &ffi_type_sshort; - vals11[i] = (short)sexp_sint_value(avalues[i]); - break; - case 12: - c_atypes[i] = &ffi_type_ushort; - vals12[i] = (unsigned short)sexp_uint_value(avalues[i]); - break; - case 13: - c_atypes[i] = &ffi_type_sint; - vals13[i] = (int)sexp_sint_value(avalues[i]); - c_avalues[i] = &vals13[i]; - break; - case 14: - c_atypes[i] = &ffi_type_uint; - vals14[i] = (unsigned int)sexp_uint_value(avalues[i]); - c_avalues[i] = &vals14[i]; - break; - case 15: - c_atypes[i] = &ffi_type_slong; - vals15[i] = (long)sexp_sint_value(avalues[i]); - c_avalues[i] = &vals15[i]; - break; - case 16: - c_atypes[i] = &ffi_type_ulong; - vals16[i] = (unsigned long)sexp_uint_value(avalues[i]); - c_avalues[i] = &vals16[i]; - break; - case 17: - c_atypes[i] = &ffi_type_float; - vals17[i] = (float)sexp_flonum_value(avalues[i]); - c_avalues[i] = &vals17[i]; - break; - case 18: - c_atypes[i] = &ffi_type_double; - vals18[i] = (double)sexp_flonum_value(avalues[i]); - c_avalues[i] = &vals18[i]; - break; - case 19: - c_atypes[i] = &ffi_type_void; - arg = NULL; - c_avalues[i] = NULL; - break; - case 20: - c_atypes[i] = &ffi_type_pointer; - if(sexp_cpointerp(avalues[i])) { - vals20[i] = sexp_cpointer_value(avalues[i]); - } else { - vals20[i] = NULL; - } - c_avalues[i] = &vals20[i]; - break; - default: - printf(\"Undefined argument type integer: %i, index: %i\\n\", atypes[i], i); - //c_avalues[i] = sexp_cpointer_value(avalues[i]); - break; - } - } - - ffi_type* c_rtype = &ffi_type_void; - switch(rtype) { - case 1: c_rtype = &ffi_type_sint8; break; - case 2: c_rtype = &ffi_type_uint8; break; - case 3: c_rtype = &ffi_type_sint16; break; - case 4: c_rtype = &ffi_type_uint16; break; - case 5: c_rtype = &ffi_type_sint32; break; - case 6: c_rtype = &ffi_type_uint32; break; - case 7: c_rtype = &ffi_type_sint64; break; - case 8: c_rtype = &ffi_type_uint64; break; - case 9: c_rtype = &ffi_type_schar; break; - case 10: c_rtype = &ffi_type_uchar; break; - case 11: c_rtype = &ffi_type_sshort; break; - case 12: c_rtype = &ffi_type_ushort; break; - case 13: c_rtype = &ffi_type_sint; break; - case 14: c_rtype = &ffi_type_uint; break; - case 15: c_rtype = &ffi_type_slong; break; - case 16: c_rtype = &ffi_type_ulong; break; - case 17: c_rtype = &ffi_type_float; break; - case 18: c_rtype = &ffi_type_double; break; - case 19: c_rtype = &ffi_type_void; break; - case 20: c_rtype = &ffi_type_pointer; break; - default: - printf(\"Undefined return type: %i\\n\", rtype); - c_rtype = &ffi_type_pointer; - break; - } - - int r = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, c_rtype, c_atypes); - - void* rvalue = malloc(rvalue_size); - ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues); - return rvalue; - }") -(define-c (maybe-null pointer void*) - (internal-ffi-call internal_ffi_call) - (unsigned-int - unsigned-int - (array unsigned-int) - (maybe-null pointer void*) - unsigned-int - (array sexp))) - -(c-declare - "void* scheme_procedure_to_pointer(sexp proc) { - if(sexp_procedurep(proc) == 1) { - return 0; //&sexp_unbox_fixnum(proc); - } else { - printf(\"NOT A FUNCTION\\n\"); - } - return (void*)proc; - }") -(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp)) diff --git a/snow/foreign/c/primitives/chicken.scm b/snow/foreign/c/primitives/chicken.scm deleted file mode 100644 index f4a17bd..0000000 --- a/snow/foreign/c/primitives/chicken.scm +++ /dev/null @@ -1,226 +0,0 @@ - -(define type->native-type ; Chicken has this procedure in three places - (lambda (type) - (cond ((equal? type 'int8) 'byte) - ((equal? type 'uint8) 'unsigned-byte) - ((equal? type 'int16) 'short) - ((equal? type 'uint16) 'unsigned-short) - ((equal? type 'int32) 'integer32) - ((equal? type 'uint32) 'unsigned-integer32) - ((equal? type 'int64) 'integer64) - ((equal? type 'uint64) 'unsigned-integer64) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'unsigned-char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) 'c-pointer) - ((equal? type 'void) 'void) - ((equal? type 'callback) 'c-pointer) - ((equal? type 'struct) 'c-pointer) - (else (error "type->native-type -- No such pffi type" type))))) - -(define c-bytevector? - (lambda (object) - (pointer? object))) - -(define-syntax define-c-procedure - (er-macro-transformer - (lambda (expr rename compare) - (let* ((type->native-type ; Chicken has this procedure in three places - (lambda (type) - (cond ((equal? type 'int8) 'byte) - ((equal? type 'uint8) 'unsigned-byte) - ((equal? type 'int16) 'short) - ((equal? type 'uint16) 'unsigned-short) - ((equal? type 'int32) 'integer32) - ((equal? type 'uint32) 'unsigned-integer32) - ((equal? type 'int64) 'integer64) - ((equal? type 'uint64) 'unsigned-integer64) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'unsigned-char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) 'c-pointer) - ((equal? type 'void) 'void) - ((equal? type 'callback) 'c-pointer) - ((equal? type 'struct) 'c-pointer) - (else (error "type->native-type -- No such pffi type" type))))) - (scheme-name (list-ref expr 1)) - (c-name (symbol->string (cadr (list-ref expr 3)))) - (return-type (type->native-type (cadr (list-ref expr 4)))) - (argument-types (if (null? (cdr (list-ref expr 5))) - (list) - (map type->native-type - (cadr (list-ref expr 5)))))) - (if (null? argument-types) - `(define ,scheme-name - (foreign-safe-lambda ,return-type ,c-name)) - `(define ,scheme-name - (foreign-safe-lambda ,return-type ,c-name ,@ argument-types))))))) - -(define-syntax define-c-callback - (er-macro-transformer - (lambda (expr rename compare) - (let* ((type->native-type ; Chicken has this procedure in three places - (lambda (type) - (cond ((equal? type 'int8) 'byte) - ((equal? type 'uint8) 'unsigned-byte) - ((equal? type 'int16) 'short) - ((equal? type 'uint16) 'unsigned-short) - ((equal? type 'int32) 'integer32) - ((equal? type 'uint32) 'unsigned-integer32) - ((equal? type 'int64) 'integer64) - ((equal? type 'uint64) 'unsigned-integer64) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'unsigned-char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) 'c-pointer) - ((equal? type 'void) 'void) - ((equal? type 'callback) 'c-pointer) - ((equal? type 'struct) 'c-pointer) - (else (error "type->native-type -- No such pffi type" type))))) - (scheme-name (list-ref expr 1)) - (return-type (type->native-type (cadr (list-ref expr 2)))) - (argument-types (map type->native-type (cadr (list-ref expr 3)))) - (argument-names (cadr (list-ref expr 4))) - (arguments (map - (lambda (name type) - `(,name ,type)) - argument-types argument-names)) - (procedure-body (cdr (cdr (list-ref expr 4))))) - `(begin (define-external ,(cons 'external_123456789 arguments) - ,return-type - (begin ,@ procedure-body)) - (define ,scheme-name (location external_123456789))))))) - -(define size-of-type - (lambda (type) - (cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int)) - ((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int)) - ((equal? type 'int16) (foreign-value "sizeof(int16_t)" int)) - ((equal? type 'uint16) (foreign-value "sizeof(uint16_t)" int)) - ((equal? type 'int32) (foreign-value "sizeof(int32_t)" int)) - ((equal? type 'uint32) (foreign-value "sizeof(uint32_t)" int)) - ((equal? type 'int64) (foreign-value "sizeof(int64_t)" int)) - ((equal? type 'uint64) (foreign-value "sizeof(uint64_t)" int)) - ((equal? type 'char) (foreign-value "sizeof(char)" int)) - ((equal? type 'unsigned-char) (foreign-value "sizeof(unsigned char)" int)) - ((equal? type 'short) (foreign-value "sizeof(short)" int)) - ((equal? type 'unsigned-short) (foreign-value "sizeof(unsigned short)" int)) - ((equal? type 'int) (foreign-value "sizeof(int)" int)) - ((equal? type 'unsigned-int) (foreign-value "sizeof(unsigned int)" int)) - ((equal? type 'long) (foreign-value "sizeof(long)" int)) - ((equal? type 'unsigned-long) (foreign-value "sizeof(unsigned long)" int)) - ((equal? type 'float) (foreign-value "sizeof(float)" int)) - ((equal? type 'double) (foreign-value "sizeof(double)" int)) - ((equal? type 'pointer) (foreign-value "sizeof(void*)" int)) - ((equal? type 'string) (foreign-value "sizeof(void*)" int)) - ((equal? type 'callback) (foreign-value "sizeof(void*)" int))))) - -(define make-c-null - (lambda () - (address->pointer 0))) - -(define-syntax define-c-library - (syntax-rules () - ((_ scheme-name headers object-name options) - (begin - (define scheme-name #t) - (shared-object-load headers))))) - -(define-syntax shared-object-load - (er-macro-transformer - (lambda (expr rename compare) - (let* ((headers (cadr (car (cdr expr))))) - `(begin - ,@ (map - (lambda (header) - `(foreign-declare ,(string-append "#include <" header ">"))) - headers)))))) - -(define c-null? - (lambda (pointer) - (if (and (not (pointer? pointer)) - pointer) - #f - (or (not pointer) ; #f counts as null pointer on Chicken - (= (pointer->address pointer) 0))))) - -(define c-bytevector-u8-ref - (lambda (c-bytevector k) - (pointer-u8-ref (pointer+ c-bytevector k)))) - -(define c-bytevector-u8-set! - (lambda (c-bytevector k byte) - (pointer-u8-set! (pointer+ c-bytevector k) byte))) - -(define c-bytevector-pointer-ref - (lambda (c-bytevector k) - (address->pointer (pointer-u64-ref (pointer+ c-bytevector k))))) - -(define c-bytevector-pointer-set! - (lambda (c-bytevector k pointer) - (pointer-u64-set! (pointer+ c-bytevector k) (pointer->address pointer)))) - -#;(define pffi-pointer-set! - (lambda (pointer type offset value) - (cond - ((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value)) - ((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value)) - ((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value)) - ((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value)) - ((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value)) - ((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value)) - ((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value)) - ((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) (char->integer value))) - ((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value)) - ((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value)) - ((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value)) - ((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value)) - ((equal? type 'float) (pointer-f32-set! (pointer+ pointer offset) value)) - ((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value)) - ((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value)))))) - -#;(define pffi-pointer-get - (lambda (pointer type offset) - (cond - ((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset))) - ((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset))) - ((equal? type 'int16) (pointer-s16-ref (pointer+ pointer offset))) - ((equal? type 'uint16) (pointer-u16-ref (pointer+ pointer offset))) - ((equal? type 'int32) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset))) - ((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset))) - ((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset))) - ((equal? type 'char) (integer->char (pointer-s8-ref (pointer+ pointer offset)))) - ((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset))) - ((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset))) - ((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset))) - ((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset))) - ((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset))) - ((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset))) - ((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset))))))) diff --git a/snow/foreign/c/primitives/cyclone.scm b/snow/foreign/c/primitives/cyclone.scm deleted file mode 100644 index e52feda..0000000 --- a/snow/foreign/c/primitives/cyclone.scm +++ /dev/null @@ -1,372 +0,0 @@ -(define type->native-type - (lambda (type) - (cond ((equal? type 'int8) int) - ((equal? type 'uint8) int) - ((equal? type 'int16) int) - ((equal? type 'uint16) int) - ((equal? type 'int32) int) - ((equal? type 'uint32) int) - ((equal? type 'int64) int) - ((equal? type 'uint64) int) - ((equal? type 'char) char) - ((equal? type 'unsigned-char) char) - ((equal? type 'short) int) - ((equal? type 'unsigned-short) int) - ((equal? type 'int) int) - ((equal? type 'unsigned-int) int) - ((equal? type 'long) int) - ((equal? type 'unsigned-long) int) - ((equal? type 'float) float) - ((equal? type 'double) double) - ((equal? type 'pointer) opaque) - ((equal? type 'void) c-void) - ((equal? type 'callback) opaque) - (else (error "type->native-type -- No such type" type))))) - -(define c-bytevector? - (lambda (object) - (opaque? object))) - -(define-syntax define-c-procedure - (er-macro-transformer - (lambda (expr rename compare) - (let* ((type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'int) - ((equal? type 'uint8) 'int) - ((equal? type 'int16) 'int) - ((equal? type 'uint16) 'int) - ((equal? type 'int32) 'int) - ((equal? type 'uint32) 'int) - ((equal? type 'int64) 'int) - ((equal? type 'uint64) 'int) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'unsigned-char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) 'opaque) - ((equal? type 'void) 'c-void) - ((equal? type 'callback) 'opaque) - (else (error "type->native-type -- No such type" type))))) - (scheme-name (cadr expr)) - (c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr)))))))) - (return-type (type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))) - (argument-types - (let ((types (cadr (car (cdr (cdr (cdr (cdr (cdr expr))))))))) - (if (null? types) - '() - (map type->native-type types))))) - (if (null? argument-types) - `(c-define ,scheme-name ,return-type ,c-name) - `(c-define ,scheme-name - ,return-type ,c-name ,@argument-types)))))) - -(define define-c-callback - (lambda (scheme-name return-type argument-types procedure) - (error "define-callback not yet implemented on Cyclone"))) - -(define size-of-type - (lambda (type) - (cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int)) - ((equal? type 'uint8) (c-value "sizeof(uint8_t)" int)) - ((equal? type 'int16) (c-value "sizeof(int16_t)" int)) - ((equal? type 'uint16) (c-value "sizeof(uint16_t)" int)) - ((equal? type 'int32) (c-value "sizeof(int32_t)" int)) - ((equal? type 'uint32) (c-value "sizeof(uint32_t)" int)) - ((equal? type 'int64) (c-value "sizeof(int64_t)" int)) - ((equal? type 'uint64) (c-value "sizeof(uint64_t)" int)) - ((equal? type 'char) (c-value "sizeof(char)" int)) - ((equal? type 'unsigned-char) (c-value "sizeof(unsigned char)" int)) - ((equal? type 'short) (c-value "sizeof(short)" int)) - ((equal? type 'unsigned-short) (c-value "sizeof(unsigned short)" int)) - ((equal? type 'int) (c-value "sizeof(int)" int)) - ((equal? type 'unsigned-int) (c-value "sizeof(unsigned int)" int)) - ((equal? type 'long) (c-value "sizeof(long)" int)) - ((equal? type 'unsigned-long) (c-value "sizeof(unsigned long)" int)) - ((equal? type 'float) (c-value "sizeof(float)" int)) - ((equal? type 'double) (c-value "sizeof(double)" int)) - ((equal? type 'pointer) (c-value "sizeof(void*)" int))))) - -(define-c pointer-address - "(void *data, int argc, closure _, object k, object pointer)" - "make_c_opaque(opq, &(void*)opaque_ptr(pointer)); - return_closcall1(data, k, &opq);") - -(define pointer-null - (lambda () - (make-opaque))) - -(define-syntax define-c-library - (syntax-rules () - ((_ scheme-name headers object-name options) - (begin - (define scheme-name #t) - (shared-object-load headers))))) - -(define-syntax shared-object-load - (er-macro-transformer - (lambda (expr rename compare) - (let* ((headers (cadr (cadr expr))) - (includes (map - (lambda (header) - `(include-c-header ,(string-append "<" header ">"))) - headers))) - `(,@includes))))) - -(define pointer-null? - (lambda (pointer) - (and (opaque? pointer) - (opaque-null? pointer)))) - -(define-c pointer-int8-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-uint8-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-int16-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-uint16-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-int32-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-uint32-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-int64-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-uint64-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-char-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "char* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2char(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-short-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "short* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-unsigned-short-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-int-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "int* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-unsigned-int-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-long-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "long* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-unsigned-long-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = obj_obj2int(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-float-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "float* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = double_value(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-double-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "double* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = double_value(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define-c pointer-pointer-set! - "(void *data, int argc, closure _, object k, object pointer, object offset, object value)" - "uintptr_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - *p = (uintptr_t)&opaque_ptr(value); - return_closcall1(data, k, make_boolean(boolean_t));") - -(define pointer-set! - (lambda (pointer type offset value) - (cond - ((equal? type 'int8) (pointer-int8-set! pointer offset value)) - ((equal? type 'uint8) (pointer-uint8-set! pointer offset value)) - ((equal? type 'int16) (pointer-int16-set! pointer offset value)) - ((equal? type 'uint16) (pointer-uint16-set! pointer offset value)) - ((equal? type 'int32) (pointer-int32-set! pointer offset value)) - ((equal? type 'uint32) (pointer-uint32-set! pointer offset value)) - ((equal? type 'int64) (pointer-int64-set! pointer offset value)) - ((equal? type 'uint64) (pointer-uint64-set! pointer offset value)) - ((equal? type 'char) (pointer-char-set! pointer offset value)) - ((equal? type 'short) (pointer-short-set! pointer offset value)) - ((equal? type 'unsigned-short) (pointer-unsigned-short-set! pointer offset value)) - ((equal? type 'int) (pointer-int-set! pointer offset value)) - ((equal? type 'unsigned-int) (pointer-unsigned-int-set! pointer offset value)) - ((equal? type 'long) (pointer-long-set! pointer offset value)) - ((equal? type 'unsigned-long) (pointer-unsigned-long-set! pointer offset value)) - ((equal? type 'float) (pointer-float-set! pointer offset value)) - ((equal? type 'double) (pointer-double-set! pointer offset value)) - ((equal? type 'pointer) (pointer-pointer-set! pointer offset value))))) - -(define-c pointer-int8-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-uint8-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-int16-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-uint16-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-int32-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-uint32-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-int64-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-uint64-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-char-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "char* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_char2obj(*p));") - -(define-c pointer-short-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "short* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-unsigned-short-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-int-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "int* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-unsigned-int-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-long-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "long* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-unsigned-long-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset); - return_closcall1(data, k, obj_int2obj(*p));") - -(define-c pointer-float-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "float* p = opaque_ptr(pointer) + obj_obj2int(offset); - alloca_double(d, *p); - return_closcall1(data, k, d);") - -(define-c pointer-double-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "double* p = opaque_ptr(pointer) + obj_obj2int(offset); - alloca_double(d, *p); - return_closcall1(data, k, d);") - -(define-c pointer-pointer-get - "(void *data, int argc, closure _, object k, object pointer, object offset)" - "make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset)); - return_closcall1(data, k, &opq);") - -#;(define c-bytevector-u8-set! pointer-uint8-set!) -(define c-bytevector-u8-ref pointer-uint8-get) - -(define pointer-get - (lambda (pointer type offset) - (cond - ((equal? type 'int8) (pointer-int8-get pointer offset)) - ((equal? type 'uint8) (pointer-uint8-get pointer offset)) - ((equal? type 'int16) (pointer-int16-get pointer offset)) - ((equal? type 'uint16) (pointer-uint16-get pointer offset)) - ((equal? type 'int32) (pointer-int32-get pointer offset)) - ((equal? type 'uint32) (pointer-uint32-get pointer offset)) - ((equal? type 'int64) (pointer-int64-get pointer offset)) - ((equal? type 'uint64) (pointer-uint64-get pointer offset)) - ((equal? type 'char) (pointer-char-get pointer offset)) - ((equal? type 'short) (pointer-short-get pointer offset)) - ((equal? type 'unsigned-short) (pointer-unsigned-short-get pointer offset)) - ((equal? type 'int) (pointer-int-get pointer offset)) - ((equal? type 'unsigned-int) (pointer-unsigned-int-get pointer offset)) - ((equal? type 'long) (pointer-long-get pointer offset)) - ((equal? type 'unsigned-long) (pointer-unsigned-long-get pointer offset)) - ((equal? type 'float) (pointer-float-get pointer offset)) - ((equal? type 'double) (pointer-double-get pointer offset)) - ((equal? type 'pointer) (pointer-pointer-get pointer offset))))) diff --git a/snow/foreign/c/primitives/gambit.scm b/snow/foreign/c/primitives/gambit.scm deleted file mode 100644 index cedc52c..0000000 --- a/snow/foreign/c/primitives/gambit.scm +++ /dev/null @@ -1,252 +0,0 @@ -(c-declare "#include ") -(c-declare "#include ") - -(define size-of-int8_t (c-lambda () int "___return(sizeof(int8_t));")) -(define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_t));")) -(define size-of-int16_t (c-lambda () int "___return(sizeof(int16_t));")) -(define size-of-uint16_t (c-lambda () int "___return(sizeof(uint16_t));")) -(define size-of-int32_t (c-lambda () int "___return(sizeof(int32_t));")) -(define size-of-uint32_t (c-lambda () int "___return(sizeof(uint32_t));")) -(define size-of-int64_t (c-lambda () int "___return(sizeof(int64_t));")) -(define size-of-uint64_t (c-lambda () int "___return(sizeof(uint64_t));")) -(define size-of-char (c-lambda () int "___return(sizeof(char));")) -(define size-of-unsigned-char (c-lambda () int "___return(sizeof(unsigned char));")) -(define size-of-short (c-lambda () int "___return(sizeof(short));")) -(define size-of-unsigned-short (c-lambda () int "___return(sizeof(unsigned short));")) -(define size-of-int (c-lambda () int "___return(sizeof(int));")) -(define size-of-unsigned-int (c-lambda () int "___return(sizeof(unsigned int));")) -(define size-of-long (c-lambda () int "___return(sizeof(long));")) -(define size-of-unsigned-long (c-lambda () int "___return(sizeof(unsigned long));")) -(define size-of-float (c-lambda () int "___return(sizeof(float));")) -(define size-of-double (c-lambda () int "___return(sizeof(double));")) -(define size-of-void* (c-lambda () int "___return(sizeof(void*));")) - -(define size-of-type - (lambda (type) - (cond ((eq? type 'int8) (size-of-int8_t)) - ((eq? type 'uint8) (size-of-uint8_t)) - ((eq? type 'int16) (size-of-int16_t)) - ((eq? type 'uint16) (size-of-uint16_t)) - ((eq? type 'int32) (size-of-int32_t)) - ((eq? type 'uint32) (size-of-uint32_t)) - ((eq? type 'int64) (size-of-int64_t)) - ((eq? type 'uint64) (size-of-uint64_t)) - ((eq? type 'char) (size-of-char)) - ((eq? type 'unsigned-char) (size-of-char)) - ((eq? type 'short) (size-of-short)) - ((eq? type 'unsigned-short) (size-of-unsigned-short)) - ((eq? type 'int) (size-of-int)) - ((eq? type 'unsigned-int) (size-of-unsigned-int)) - ((eq? type 'long) (size-of-long)) - ((eq? type 'unsigned-long) (size-of-unsigned-long)) - ((eq? type 'float) (size-of-float)) - ((eq? type 'double) (size-of-double)) - ((eq? type 'pointer) (size-of-void*)) - ((eq? type 'callback) (size-of-void*)) - ((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 - (let ((c-code (apply string-append - (map - (lambda (header) - (string-append "#include <" header ">" (string #\newline))) - (car (cdr headers)))))) - `(begin (define ,name #t) (c-declare ,c-code))))) - - -(define pointer? (c-lambda ((pointer void)) bool "___return(1);")) -(define c-bytevector? - (lambda (object) - (call-with-current-continuation - (lambda (k) - (with-exception-handler - (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-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;")) -(define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-int16_t! (c-lambda ((pointer void) int int16) void "*(int16_t*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-uint16_t! (c-lambda ((pointer void) int unsigned-int16) void "*(uint16_t*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-int32_t! (c-lambda ((pointer void) int int32) void "*(int32_t*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-uint32_t! (c-lambda ((pointer void) int unsigned-int32) void "*(uint32_t*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-int64_t! (c-lambda ((pointer void) int int64) void "*(int64_t*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-uint64_t! (c-lambda ((pointer void) int unsigned-int64) void "*(uint64_t*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-char! (c-lambda ((pointer void) int char) void "*((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-short! (c-lambda ((pointer void) int short) void "*(short*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-unsigned-short! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned short*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-int! (c-lambda ((pointer void) int int) void "*(int*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-unsigned-int! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned int*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-long! (c-lambda ((pointer void) int long) void "*(long*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-unsigned-long! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned long*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-float! (c-lambda ((pointer void) int float) void "*(float*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-double! (c-lambda ((pointer void) int double) void "*(double*)((char*)___arg1 + ___arg2) = ___arg3;")) -(define pointer-set-c-pointer! (c-lambda ((pointer void) int (pointer void)) void "{ char* p = (char*)___arg1 + ___arg2; *(char**)p = ___arg3; }")) - -(define pffi-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 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-ref-c-int8_t (c-lambda ((pointer void) int) int8 "___return(*(int8_t*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-uint8_t (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-int16_t (c-lambda ((pointer void) int) int16 "___return(*(int16_t*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-uint16_t (c-lambda ((pointer void) int) unsigned-int16 "___return(*(uint16_t*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-int32_t (c-lambda ((pointer void) int) int32 "___return(*(int32_t*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-uint32_t (c-lambda ((pointer void) int) unsigned-int32 "___return(*(uint32_t*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-int64_t (c-lambda ((pointer void) int) int64 "___return(*(int64_t*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-uint64_t (c-lambda ((pointer void) int) unsigned-int64 "___return(*(uint64_t*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-char (c-lambda ((pointer void) int) char "___return(*((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-short (c-lambda ((pointer void) int) short "___return(*(short*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-unsigned-short (c-lambda ((pointer void) int) unsigned-short "___return(*(unsigned short*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-int (c-lambda ((pointer void) int) int "___return(*(int*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-unsigned-int (c-lambda ((pointer void) int) unsigned-int "___return(*(unsigned int*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-long (c-lambda ((pointer void) int) long "___return(*(long*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-unsigned-long (c-lambda ((pointer void) int) unsigned-long "___return(*(unsigned long*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-float (c-lambda ((pointer void) int) float "___return(*(float*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-double (c-lambda ((pointer void) int) double "___return(*(double*)((char*)___arg1 + ___arg2));")) -(define pointer-ref-c-pointer (c-lambda ((pointer void) int) (pointer void) " char* p = (char*)___arg1 + ___arg2; ___return(*(char**)p);")) - - -(define pffi-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) (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-macro - (define-c-procedure scheme-name shared-object c-name return-type argument-types) - (begin - (letrec* ((pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'byte) - ((equal? type 'uint8) 'unsigned-int8) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32) - ((equal? type 'uint32) 'unsigned-int32) - ((equal? type 'int64) 'int64) - ((equal? type 'uint64) 'unsigned-int64) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'unsigned-char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) '(pointer void)) - ((equal? type 'void) 'void) - ((equal? type 'callback) '(pointer void)) - (else (error "pffi-type->native-type -- No such pffi type" type))))) - (native-argument-types - (if (equal? '(list) argument-types) - (list) - (let ((types (map pffi-type->native-type (cadr argument-types)))) - (if (null? types) types types)))) - (native-return-type (pffi-type->native-type (cadr return-type))) - (argument-count (length native-argument-types)) - (c-arguments (lambda (index result) - (if (>= index argument-count) - result - (c-arguments (+ index 1) - (string-append result - "___arg" - (number->string (+ index 1)) - (if (<= index (- argument-count 2)) - ", " - "")))))) - (c-code (string-append - (if (equal? 'void (cadr return-type)) "" "___return(") - (symbol->string (cadr c-name)) - "(" (c-arguments 0 "") ")" - (if (equal? 'void (cadr return-type)) "" ")") - ";"))) - `(define ,scheme-name - (c-lambda ,native-argument-types - ,native-return-type - ,c-code))))) - -(define-macro - (define-c-callback scheme-name return-type argument-types procedure) - (let* ((type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'byte) - ((equal? type 'uint8) 'unsigned-int8) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32) - ((equal? type 'uint32) 'unsigned-int32) - ((equal? type 'int64) 'int64) - ((equal? type 'uint64) 'unsigned-int64) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'unsigned-char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) '(pointer void)) - ((equal? type 'void) 'void) - ((equal? type 'callback) '(pointer void)) - (else (error "pffi-type->native-type -- No such pffi type" type))))) - (native-return-type (type->native-type (cadr return-type))) - (native-argument-types (map type->native-type (cadr argument-types)))) - `(define ,scheme-name ,procedure - #;(c-callback ,native-return-type ,native-argument-types ,procedure)))) diff --git a/snow/foreign/c/primitives/gauche.scm b/snow/foreign/c/primitives/gauche.scm deleted file mode 100644 index 3dcfc2c..0000000 --- a/snow/foreign/c/primitives/gauche.scm +++ /dev/null @@ -1,182 +0,0 @@ -(define-module foreign.c.primitives.gauche - (export size-of-type - shared-object-load - c-bytevector-u8-set! - c-bytevector-u8-ref - c-bytevector-pointer-set! - c-bytevector-pointer-ref - ;pointer-null - ;pointer-null? - ;make-c-bytevector - ;pointer-address - c-bytevector? - c-free - ;pointer-set! - ;pointer-get - ;define-c-procedure - define-c-callback - dlerror - dlsym - internal-ffi-call - )) - -(select-module foreign.c.primitives.gauche) -(dynamic-load "foreign/c/lib/gauche") - -(define size-of-type - (lambda (type) - (cond - ((equal? type 'int8) (size-of-int8)) - ((equal? type 'uint8) (size-of-uint8)) - ((equal? type 'int16) (size-of-int16)) - ((equal? type 'uint16) (size-of-uint16)) - ((equal? type 'int32) (size-of-int32)) - ((equal? type 'uint32) (size-of-uint32)) - ((equal? type 'int64) (size-of-int64)) - ((equal? type 'uint64) (size-of-uint64)) - ((equal? type 'char) (size-of-char)) - ((equal? type 'unsigned-char) (size-of-unsigned-char)) - ((equal? type 'short) (size-of-short)) - ((equal? type 'unsigned-short) (size-of-unsigned-short)) - ((equal? type 'int) (size-of-int)) - ((equal? type 'unsigned-int) (size-of-unsigned-int)) - ((equal? type 'long) (size-of-long)) - ((equal? type 'unsigned-long) (size-of-unsigned-long)) - ((equal? type 'float) (size-of-float)) - ((equal? type 'double) (size-of-double)) - ((equal? type 'string) (size-of-string)) - ((equal? type 'pointer) (size-of-pointer)) - ((equal? type 'void) (size-of-void))))) - -#;(define shared-object-load - (lambda (path options) - (shared-object-load path))) - -#;(define make-c-bytevector - (lambda (size) - (pointer-allocate size))) - -(define c-bytevector? - (lambda (pointer) - (pointer? pointer))) - -#;(define c-free - (lambda (pointer) - (pointer-free pointer))) - -(define c-bytevector-u8-set! pointer-set-uint8!) -(define c-bytevector-u8-ref pointer-get-uint8) -(define c-bytevector-pointer-set! pointer-set-pointer!) -(define c-bytevector-pointer-ref pointer-get-pointer) - -#;(define pointer-set! - (lambda (pointer type offset value) - (cond ((equal? type 'int8) (pointer-set-int8! pointer offset value)) - ((equal? type 'uint8) (pointer-set-uint8! pointer offset value)) - ((equal? type 'int16) (pointer-set-int16! pointer offset value)) - ((equal? type 'uint16) (pointer-set-uint16! pointer offset value)) - ((equal? type 'int32) (pointer-set-int32! pointer offset value)) - ((equal? type 'uint32) (pointer-set-uint32! pointer offset value)) - ((equal? type 'int64) (pointer-set-int64! pointer offset value)) - ((equal? type 'uint64) (pointer-set-uint64! pointer offset value)) - ((equal? type 'char) (pointer-set-char! pointer offset value)) - ((equal? type 'short) (pointer-set-short! pointer offset value)) - ((equal? type 'unsigned-short) (pointer-set-unsigned-short! pointer offset value)) - ((equal? type 'int) (pointer-set-int! pointer offset value)) - ((equal? type 'unsigned-int) (pointer-set-unsigned-int! pointer offset value)) - ((equal? type 'long) (pointer-set-long! pointer offset value)) - ((equal? type 'unsigned-long) (pointer-set-unsigned-long! pointer offset value)) - ((equal? type 'float) (pointer-set-float! pointer offset value)) - ((equal? type 'double) (pointer-set-double! pointer offset value)) - ((equal? type 'void) (pointer-set-pointer! pointer offset value)) - ((equal? type 'pointer) (pointer-set-pointer! pointer offset value))))) - -#;(define pointer-get - (lambda (pointer type offset) - (cond ((equal? type 'int8) (pointer-get-int8 pointer offset)) - ((equal? type 'uint8) (pointer-get-uint8 pointer offset)) - ((equal? type 'int16) (pointer-get-int16 pointer offset)) - ((equal? type 'uint16) (pointer-get-uint16 pointer offset)) - ((equal? type 'int32) (pointer-get-int32 pointer offset)) - ((equal? type 'uint32) (pointer-get-uint32 pointer offset)) - ((equal? type 'int64) (pointer-get-int64 pointer offset)) - ((equal? type 'uint64) (pointer-get-uint64 pointer offset)) - ((equal? type 'char) (integer->char (pointer-get-char pointer offset))) - ((equal? type 'short) (pointer-get-short pointer offset)) - ((equal? type 'unsigned-short) (pointer-get-unsigned-short pointer offset)) - ((equal? type 'int) (pointer-get-int pointer offset)) - ((equal? type 'unsigned-int) (pointer-get-unsigned-int pointer offset)) - ((equal? type 'long) (pointer-get-long pointer offset)) - ((equal? type 'unsigned-long) (pointer-get-unsigned-long pointer offset)) - ((equal? type 'float) (pointer-get-float pointer offset)) - ((equal? type 'double) (pointer-get-double pointer offset)) - ((equal? type 'void) (pointer-get-pointer pointer offset)) - ((equal? type 'pointer) (pointer-get-pointer pointer offset))))) - -#;(define type->libffi-type - (lambda (type) - (cond ((equal? type 'int8) (get-ffi-type-int8)) - ((equal? type 'uint8) (get-ffi-type-uint8)) - ((equal? type 'int16) (get-ffi-type-int16)) - ((equal? type 'uint16) (get-ffi-type-uint16)) - ((equal? type 'int32) (get-ffi-type-int32)) - ((equal? type 'uint32) (get-ffi-type-uint32)) - ((equal? type 'int64) (get-ffi-type-int64)) - ((equal? type 'uint64) (get-ffi-type-uint64)) - ((equal? type 'char) (get-ffi-type-char)) - ((equal? type 'unsigned-char) (get-ffi-type-uchar)) - ((equal? type 'bool) (get-ffi-type-int8)) - ((equal? type 'short) (get-ffi-type-short)) - ((equal? type 'unsigned-short) (get-ffi-type-ushort)) - ((equal? type 'int) (get-ffi-type-int)) - ((equal? type 'unsigned-int) (get-ffi-type-uint)) - ((equal? type 'long) (get-ffi-type-long)) - ((equal? type 'unsigned-long) (get-ffi-type-ulong)) - ((equal? type 'float) (get-ffi-type-float)) - ((equal? type 'double) (get-ffi-type-double)) - ((equal? type 'void) (get-ffi-type-void)) - ((equal? type 'pointer) (get-ffi-type-pointer)) - ((equal? type 'callback) (get-ffi-type-pointer))))) - -#;(define 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 'bool) 11) - ((equal? type 'short) 12) - ((equal? type 'unsigned-short) 13) - ((equal? type 'int) 14) - ((equal? type 'unsigned-int) 15) - ((equal? type 'long) 16) - ((equal? type 'unsigned-long) 17) - ((equal? type 'float) 18) - ((equal? type 'double) 19) - ((equal? type 'void) 20) - ((equal? type 'pointer) 21) - ((equal? type 'callback) 21)))) - -#;(define argument->pointer - (lambda (value type) - (cond ((procedure? value) (scheme-procedure-to-pointer value)) - (else (let ((pointer (make-c-bytevector (size-of-type type)))) - (pointer-set! pointer type 0 value) - pointer))))) - - -(define make-c-callback - (lambda (return-type argument-types procedure) - (scheme-procedure-to-pointer procedure))) - -(define-syntax define-c-callback - (syntax-rules () - ((_ scheme-name return-type argument-types procedure) - (define scheme-name - (make-c-callback return-type 'argument-types procedure))))) diff --git a/snow/foreign/c/primitives/gauche/define-c-procedure.scm b/snow/foreign/c/primitives/gauche/define-c-procedure.scm deleted file mode 100644 index 685aadb..0000000 --- a/snow/foreign/c/primitives/gauche/define-c-procedure.scm +++ /dev/null @@ -1,25 +0,0 @@ -;;;; This file is dependent on content of other files added trough (include...) -;;;; And that's why it is separated - -(define make-c-function - (lambda (shared-object c-name return-type argument-types) - (dlerror) ;; Clean all previous errors - (let ((c-function (dlsym shared-object c-name)) - (maybe-dlerror (dlerror))) - (lambda arguments - (let ((return-pointer (internal-ffi-call (length argument-types) - (type->libffi-type-number return-type) - (map type->libffi-type-number argument-types) - c-function - (size-of-type return-type) - arguments))) - (c-bytevector-get return-pointer return-type 0)))))) - -(define-syntax define-c-procedure - (syntax-rules () - ((_ scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (make-c-function shared-object - (symbol->string c-name) - return-type - argument-types))))) diff --git a/snow/foreign/c/primitives/gauche/foreign-c-primitives-gauche.h b/snow/foreign/c/primitives/gauche/foreign-c-primitives-gauche.h deleted file mode 100644 index bb0918b..0000000 --- a/snow/foreign/c/primitives/gauche/foreign-c-primitives-gauche.h +++ /dev/null @@ -1,83 +0,0 @@ -extern ScmObj size_of_int8(); -extern ScmObj size_of_uint8(); -extern ScmObj size_of_int16(); -extern ScmObj size_of_uint16(); -extern ScmObj size_of_int32(); -extern ScmObj size_of_uint32(); -extern ScmObj size_of_int64(); -extern ScmObj size_of_uint64(); -extern ScmObj size_of_char(); -extern ScmObj size_of_unsigned_char(); -extern ScmObj size_of_short(); -extern ScmObj size_of_unsigned_short(); -extern ScmObj size_of_int(); -extern ScmObj size_of_unsigned_int(); -extern ScmObj size_of_long(); -extern ScmObj size_of_unsigned_long(); -extern ScmObj size_of_float(); -extern ScmObj size_of_double(); -extern ScmObj size_of_string(); -extern ScmObj size_of_pointer(); -extern ScmObj size_of_void(); -extern ScmObj shared_object_load(ScmString* path, ScmObj options); -//extern ScmObj pointer_null(); -//extern ScmObj is_pointer_null(); -//extern ScmObj pointer_allocate(int size); -//extern ScmObj pointer_address(ScmObj pointer); -extern ScmObj is_pointer(ScmObj pointer); -//extern ScmObj pointer_free(ScmObj pointer); - - -//extern ScmObj pointer_set_int8(ScmObj pointer, int offset, int8_t value); -extern ScmObj pointer_set_uint8(ScmObj pointer, int offset, uint8_t value); -/* - * extern ScmObj pointer_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_pointer(ScmObj pointer, int offset); -//extern ScmObj string_to_pointer(ScmObj string); -//extern ScmObj pointer_to_string(ScmObj pointer); - -extern ScmObj internal_dlerror(); -extern ScmObj internal_dlsym(ScmObj shared_object, ScmObj c_name); -extern ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, ScmObj rvalue, ScmObj avalues); -extern ScmObj scheme_procedure_to_pointer(ScmObj procedure); - -extern ScmObj get_ffi_type_int8(); -extern ScmObj get_ffi_type_uint8(); -extern ScmObj get_ffi_type_int16(); -extern ScmObj get_ffi_type_uint16(); -extern ScmObj get_ffi_type_int32(); -extern ScmObj get_ffi_type_uint32(); -extern ScmObj get_ffi_type_int64(); -extern ScmObj get_ffi_type_uint64(); -extern ScmObj get_ffi_type_char(); -extern ScmObj get_ffi_type_unsigned_char(); -extern ScmObj get_ffi_type_short(); -extern ScmObj get_ffi_type_unsigned_short(); -extern ScmObj get_ffi_type_int(); -extern ScmObj get_ffi_type_unsigned_int(); -extern ScmObj get_ffi_type_long(); -extern ScmObj get_ffi_type_unsigned_long(); -extern ScmObj get_ffi_type_float(); -extern ScmObj get_ffi_type_double(); -extern ScmObj get_ffi_type_void(); -extern ScmObj get_ffi_type_pointer(); - -extern void Scm_Init_gauchelib(void); - diff --git a/snow/foreign/c/primitives/gauche/gauchelib.scm b/snow/foreign/c/primitives/gauche/gauchelib.scm deleted file mode 100644 index 8e5fdc1..0000000 --- a/snow/foreign/c/primitives/gauche/gauchelib.scm +++ /dev/null @@ -1,101 +0,0 @@ -(in-module foreign.c.primitives.gauche) - -(inline-stub - (.include "foreign-c-primitives-gauche.h") - (define-cproc size-of-int8 () size_of_int8) - (define-cproc size-of-uint8 () size_of_uint8) - (define-cproc size-of-int16 () size_of_int16) - (define-cproc size-of-uint16 () size_of_int16) - (define-cproc size-of-int32 () size_of_int32) - (define-cproc size-of-uint32 () size_of_int32) - (define-cproc size-of-int64 () size_of_int64) - (define-cproc size-of-uint64 () size_of_int64) - (define-cproc size-of-char () size_of_char) - (define-cproc size-of-unsigned-char () size_of_unsigned_char) - (define-cproc size-of-short () size_of_short) - (define-cproc size-of-unsigned-short () size_of_unsigned_short) - (define-cproc size-of-int () size_of_int) - (define-cproc size-of-unsigned-int () size_of_unsigned_int) - (define-cproc size-of-long () size_of_long) - (define-cproc size-of-unsigned-long () size_of_unsigned_long) - (define-cproc size-of-float () size_of_float) - (define-cproc size-of-double () size_of_double) - (define-cproc size-of-string () size_of_string) - (define-cproc size-of-pointer () size_of_pointer) - (define-cproc size-of-void () size_of_void) - (define-cproc shared-object-load (path:: options) shared_object_load) - ;(define-cproc pointer-null () pointer_null) - ;(define-cproc pointer-null? (pointer) is_pointer_null) - ;(define-cproc pointer-allocate (size::) pointer_allocate) - ;(define-cproc pointer-address (object) pointer_address) - (define-cproc pointer? (pointer) is_pointer) - ;(define-cproc pointer-free (pointer) pointer_free) - - ;(define-cproc pointer-set-int8! (pointer offset:: value::) pointer_set_int8) - (define-cproc pointer-set-uint8! (pointer offset:: value::) pointer_set_uint8) - ;(define-cproc pointer-set-int16! (pointer offset:: value::) pointer_set_int16) - ;(define-cproc pointer-set-uint16! (pointer offset:: value::) pointer_set_uint16) - ;(define-cproc pointer-set-int32! (pointer offset:: value::) pointer_set_int32) - ;(define-cproc pointer-set-uint32! (pointer offset:: value::) pointer_set_uint32) - ;(define-cproc pointer-set-int64! (pointer offset:: value::) pointer_set_int64) - ;(define-cproc pointer-set-uint64! (pointer offset:: value::) pointer_set_uint64) - ;(define-cproc pointer-set-char! (pointer offset:: value::) pointer_set_char) - ;(define-cproc pointer-set-unsigned-char! (pointer offset:: value::) pointer_set_unsigned_char) - ;(define-cproc pointer-set-short! (pointer offset:: value::) pointer_set_short) - ;(define-cproc pointer-set-unsigned-short! (pointer offset:: value::) pointer_set_unsigned_short) - ;(define-cproc pointer-set-int! (pointer offset:: value::) pointer_set_int) - ;(define-cproc pointer-set-unsigned-int! (pointer offset:: value::) pointer_set_unsigned_int) - ;(define-cproc pointer-set-long! (pointer offset:: value::) pointer_set_long) - ;(define-cproc pointer-set-unsigned-long! (pointer offset:: value::) pointer_set_unsigned_long) - ;(define-cproc pointer-set-float! (pointer offset:: value::) pointer_set_float) - ;(define-cproc pointer-set-double! (pointer offset:: value::) pointer_set_double) - (define-cproc pointer-set-pointer! (pointer offset:: value) pointer_set_pointer) - - ;(define-cproc pointer-get-int8 (pointer offset::) pointer_get_int8) - (define-cproc pointer-get-uint8 (pointer offset::) pointer_get_uint8) - ;(define-cproc pointer-get-int16 (pointer offset::) pointer_get_int16) - ;(define-cproc pointer-get-uint16 (pointer offset::) pointer_get_uint16) - ;(define-cproc pointer-get-int32 (pointer offset::) pointer_get_int32) - ;(define-cproc pointer-get-uint32 (pointer offset::) pointer_get_uint32) - ;(define-cproc pointer-get-int64 (pointer offset::) pointer_get_int64) - ;(define-cproc pointer-get-uint64 (pointer offset::) pointer_get_uint64) - ;(define-cproc pointer-get-char (pointer offset::) pointer_get_char) - ;(define-cproc pointer-get-unsigned-char (pointer offset::) pointer_get_unsigned_char) - ;(define-cproc pointer-get-short (pointer offset::) pointer_get_short) - ;(define-cproc pointer-get-unsigned-short (pointer offset::) pointer_get_unsigned_short) - ;(define-cproc pointer-get-int (pointer offset::) pointer_get_int) - ;(define-cproc pointer-get-unsigned-int (pointer offset::) pointer_get_unsigned_int) - ;(define-cproc pointer-get-long (pointer offset::) pointer_get_long) - ;(define-cproc pointer-get-unsigned-long (pointer offset::) pointer_get_unsigned_long) - ;(define-cproc pointer-get-float (pointer offset::) pointer_get_float) - ;(define-cproc pointer-get-double (pointer offset::) pointer_get_double) - (define-cproc pointer-get-pointer (pointer offset::) pointer_get_pointer) - - (define-cproc dlerror () internal_dlerror) - (define-cproc dlsym (shared-object c-name) internal_dlsym) - (define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call) - (define-cproc scheme-procedure-to-pointer (procedure) scheme_procedure_to_pointer) - - ;(define-cproc get-ffi-type-int8 () get_ffi_type_int8) - ;(define-cproc get-ffi-type-uint8 () get_ffi_type_uint8) - ;(define-cproc get-ffi-type-int16 () get_ffi_type_int16) - ;(define-cproc get-ffi-type-uint16 () get_ffi_type_uint16) - ;(define-cproc get-ffi-type-int32 () get_ffi_type_int32) - ;(define-cproc get-ffi-type-uint32 () get_ffi_type_uint32) - ;(define-cproc get-ffi-type-int64 () get_ffi_type_int64) - ;(define-cproc get-ffi-type-uint64 () get_ffi_type_uint64) - ;(define-cproc get-ffi-type-char () get_ffi_type_char) - ;(define-cproc get-ffi-type-unsigned-char () get_ffi_type_unsigned_char) - ;(define-cproc get-ffi-type-short () get_ffi_type_short) - ;(define-cproc get-ffi-type-unsigned-short () get_ffi_type_unsigned_short) - ;(define-cproc get-ffi-type-int () get_ffi_type_int) - ;(define-cproc get-ffi-type-unsigned-int () get_ffi_type_unsigned_int) - ;(define-cproc get-ffi-type-long () get_ffi_type_long) - ;(define-cproc get-ffi-type-unsigned-long () get_ffi_type_unsigned_long) - ;(define-cproc get-ffi-type-float () get_ffi_type_float) - ;(define-cproc get-ffi-type-double () get_ffi_type_double) - ;(define-cproc get-ffi-type-void() get_ffi_type_void) - ;(define-cproc get-ffi-type-pointer () get_ffi_type_pointer) - - ;(define-cproc procedure-to-pointer (procedure) procedure_to_pointer) - ) diff --git a/snow/foreign/c/primitives/gerbil.scm b/snow/foreign/c/primitives/gerbil.scm deleted file mode 100644 index a780a83..0000000 --- a/snow/foreign/c/primitives/gerbil.scm +++ /dev/null @@ -1,29 +0,0 @@ -(define pffi-type->native-type - (lambda (type) - (error "Not defined"))) - -(define c-bytevector? - (lambda (object) - (error "Not defined"))) - -(define-syntax define-c-procedure - (syntax-rules () - ((_ scheme-name shared-object c-name return-type argument-types) - (error "Not defined")))) - -(define size-of-type - (lambda (type) - (error "Not defined"))) - -(define pffi-shared-object-load - (lambda (header path) - (error "Not defined"))) - -(define pffi-pointer-set! - (lambda (pointer type offset value) - (let ((p pointer)) - (error "Not defined")))) - -(define pffi-pointer-get - (lambda (pointer type offset) - (error "Not defined"))) diff --git a/snow/foreign/c/primitives/guile.scm b/snow/foreign/c/primitives/guile.scm deleted file mode 100644 index 797ac0e..0000000 --- a/snow/foreign/c/primitives/guile.scm +++ /dev/null @@ -1,126 +0,0 @@ -(define type->native-type - (lambda (type) - (cond ((equal? type 'int8) int8) - ((equal? type 'uint8) uint8) - ((equal? type 'int16) int16) - ((equal? type 'uint16) uint16) - ((equal? type 'int32) int32) - ((equal? type 'uint32) uint32) - ((equal? type 'int64) int64) - ((equal? type 'uint64) uint64) - ((equal? type 'char) int8) - ((equal? type 'unsigned-char) uint8) - ((equal? type 'short) short) - ((equal? type 'unsigned-short) unsigned-short) - ((equal? type 'int) int) - ((equal? type 'unsigned-int) unsigned-int) - ((equal? type 'long) long) - ((equal? type 'unsigned-long) unsigned-long) - ((equal? type 'float) float) - ((equal? type 'double) double) - ((equal? type 'pointer) '*) - ((equal? type 'void) void) - ((equal? type 'callback) '*) - ((equal? type 'struct) '*) - (else #f)))) - -(define c-bytevector? - (lambda (object) - (pointer? object))) - -(define-syntax define-c-procedure - (syntax-rules () - ((_ scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (foreign-library-function shared-object - (symbol->string c-name) - #:return-type (type->native-type return-type) - #:arg-types (map type->native-type argument-types)))))) - -(define-syntax define-c-callback - (syntax-rules () - ((_ scheme-name return-type argument-types procedure) - (define scheme-name - (procedure->pointer (type->native-type return-type) - procedure - (map type->native-type argument-types)))))) - -(define size-of-type - (lambda (type) - (let ((native-type (type->native-type type))) - (cond ((equal? native-type void) 0) - (native-type (sizeof native-type)) - (else #f))))) - -(define shared-object-load - (lambda (path options) - (load-foreign-library path))) - -(define c-bytevector-u8-set! - (lambda (c-bytevector k byte) - (let ((p (pointer->bytevector c-bytevector (+ k 100)))) - (bytevector-u8-set! p k byte)))) - -(define c-bytevector-u8-ref - (lambda (c-bytevector k) - (let ((p (pointer->bytevector c-bytevector (+ k 100)))) - (bytevector-u8-ref p k)))) - -(define c-bytevector-pointer-set! - (lambda (c-bytevector k pointer) - (c-bytevector-uint-set! c-bytevector - k - (pointer-address pointer) - (native-endianness) - (size-of-type 'pointer)))) - -(define c-bytevector-pointer-ref - (lambda (c-bytevector k) - (make-pointer (c-bytevector-uint-ref c-bytevector - k - (native-endianness) - (size-of-type 'pointer))))) - -#;(define pointer-set! -(lambda (pointer type offset value) - (let ((p (pointer->bytevector pointer (+ offset 100)))) - (cond ((equal? type 'int8) (bytevector-s8-set! p offset value)) - ((equal? type 'uint8) (bytevector-u8-set! p offset value)) - ((equal? type 'int16) (bytevector-s16-set! p offset value (native-endianness))) - ((equal? type 'uint16) (bytevector-u16-set! p offset value (native-endianness))) - ((equal? type 'int32) (bytevector-s32-set! p offset value (native-endianness))) - ((equal? type 'uint32) (bytevector-u32-set! p offset value (native-endianness))) - ((equal? type 'int64) (bytevector-s64-set! p offset value (native-endianness))) - ((equal? type 'uint64) (bytevector-u64-set! p offset value (native-endianness))) - ((equal? type 'char) (bytevector-s8-set! p offset (char->integer value))) - ((equal? type 'short) (bytevector-s8-set! p offset value)) - ((equal? type 'unsigned-short) (bytevector-u8-set! p offset value)) - ((equal? type 'int) (bytevector-sint-set! p offset value (native-endianness) (size-of-type type))) - ((equal? type 'unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (size-of-type type))) - ((equal? type 'long) (bytevector-s64-set! p offset value (native-endianness))) - ((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness))) - ((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness))) - ((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness))) - ((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type))))))) - -#;(define pointer-get -(lambda (pointer type offset) - (let ((p (pointer->bytevector pointer (+ offset 100)))) - (cond ((equal? type 'int8) (bytevector-s8-ref p offset)) - ((equal? type 'uint8) (bytevector-u8-ref p offset)) - ((equal? type 'int16) (bytevector-s16-ref p offset (native-endianness))) - ((equal? type 'uint16) (bytevector-u16-ref p offset (native-endianness))) - ((equal? type 'int32) (bytevector-s32-ref p offset (native-endianness))) - ((equal? type 'uint32) (bytevector-u32-ref p offset (native-endianness))) - ((equal? type 'int64) (bytevector-s64-ref p offset (native-endianness))) - ((equal? type 'uint64) (bytevector-u64-ref p offset (native-endianness))) - ((equal? type 'char) (integer->char (bytevector-s8-ref p offset))) - ((equal? type 'short) (bytevector-s8-ref p offset)) - ((equal? type 'unsigned-short) (bytevector-u8-ref p offset)) - ((equal? type 'int) (bytevector-sint-ref p offset (native-endianness) (size-of-type type))) - ((equal? type 'unsigned-int) (bytevector-uint-ref p offset (native-endianness) (size-of-type type))) - ((equal? type 'long) (bytevector-s64-ref p offset (native-endianness))) - ((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness))) - ((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness))) - ((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness))) - ((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))))))) diff --git a/snow/foreign/c/primitives/kawa.scm b/snow/foreign/c/primitives/kawa.scm deleted file mode 100644 index c4bc2db..0000000 --- a/snow/foreign/c/primitives/kawa.scm +++ /dev/null @@ -1,196 +0,0 @@ -(define arena (invoke-static java.lang.foreign.Arena 'global)) -(define method-handle-lookup (invoke-static java.lang.invoke.MethodHandles 'lookup)) -(define native-linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) - -(define value->object - (lambda (value type) - (cond ((equal? type 'byte) - (java.lang.Byte value)) - ((equal? type 'short) - (java.lang.Short value)) - ((equal? type 'unsigned-short) - (java.lang.Short value)) - ((equal? type 'int) - (java.lang.Integer value)) - ((equal? type 'unsigned-int) - (java.lang.Integer value)) - ((equal? type 'long) - (java.lang.Long value)) - ((equal? type 'unsigned-long) - (java.lang.Long value)) - ((equal? type 'float) - (java.lang.Float value)) - ((equal? type 'double) - (java.lang.Double value)) - ((equal? type 'char) - (java.lang.Char value)) - (else value)))) - -(define type->native-type - (lambda (type) - (cond - ((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) - ((equal? type 'uint8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) - ((equal? type 'int16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) - ((equal? type 'uint16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) - ((equal? type 'int32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) - ((equal? type 'uint32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) - ((equal? type 'int64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) - ((equal? type 'uint64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) - ((equal? type 'char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) - ((equal? type 'unsigned-char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) - ((equal? type 'short) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT) 'withByteAlignment 2)) - ((equal? type 'unsigned-short) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT) 'withByteAlignment 2)) - ((equal? type 'int) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) - ((equal? type 'unsigned-int) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) - ((equal? type 'long) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_LONG) 'withByteAlignment 8)) - ((equal? type 'unsigned-long) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_LONG) 'withByteAlignment 8)) - ((equal? type 'float) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT) 'withByteAlignment 4)) - ((equal? type 'double) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE) 'withByteAlignment 8)) - ((equal? type 'pointer) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) - ((equal? type 'void) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1)) - ((equal? type 'callback) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) - ((equal? type 'struct) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) - (else #f)))) - -(define c-bytevector? - (lambda (object) - (string=? (invoke (invoke object 'getClass) 'getName) - "jdk.internal.foreign.NativeMemorySegmentImpl"))) - -(define-syntax define-c-procedure - (syntax-rules () - ((_ scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (lambda vals - (invoke (invoke (cdr (assoc 'linker shared-object)) - 'downcallHandle - (invoke (invoke (cdr (assoc 'lookup shared-object)) - 'find - (symbol->string c-name)) - 'orElseThrow) - (if (equal? return-type 'void) - (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid) - (map type->native-type argument-types)) - (apply (class-methods java.lang.foreign.FunctionDescriptor 'of) - (type->native-type return-type) - (map type->native-type argument-types)))) - 'invokeWithArguments - (map value->object vals argument-types))))))) - -(define range - (lambda (from to) - (letrec* - ((looper - (lambda (count result) - (if (= count to) - (append result (list count)) - (looper (+ count 1) (append result (list count))))))) - (looper from (list))))) - -(define-syntax define-c-callback - (syntax-rules () - ((_ scheme-name return-type argument-types procedure) - (define scheme-name - (let* ((callback-procedure - (lambda (arg1 . args) - (try-catch - (begin - (apply procedure (append (list arg1) args))) - (ex - #f)))) - (function-descriptor - (let ((function-descriptor - (if (equal? return-type 'void) - (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid) - (map type->native-type argument-types)) - (apply (class-methods java.lang.foreign.FunctionDescriptor 'of) - (type->native-type return-type) - (map type->native-type argument-types))))) - (write function-descriptor) - (newline) - (write (invoke function-descriptor 'getClass)) - (newline) - (write function-descriptor) - (newline) - function-descriptor)) - ;(method-type (invoke function-descriptor 'toMethodType)) - (method-type (field callback-procedure 'applyMethodType)) - (method-handle - (let* ((method-handle (field callback-procedure 'applyToConsumerDefault))) - (write method-handle) - (newline) - method-handle))) - (invoke native-linker 'upcallStub method-handle function-descriptor arena)))))) - -(define size-of-type - (lambda (type) - (let ((native-type (type->native-type type))) - (if native-type - (invoke native-type 'byteAlignment) - #f)))) - -(define make-c-null - (lambda () - (static-field java.lang.foreign.MemorySegment 'NULL))) - -(define shared-object-load - (lambda (path options) - (let* ((library-file (make java.io.File path)) - (file-name (invoke library-file 'getName)) - (library-parent-folder (make java.io.File (invoke library-file 'getParent))) - (absolute-path (string-append (invoke library-parent-folder 'getCanonicalPath) - "/" - file-name)) - (linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) - (lookup (invoke-static java.lang.foreign.SymbolLookup - 'libraryLookup - absolute-path - arena))) - (list (cons 'linker linker) - (cons 'lookup lookup))))) - -(define null-pointer (make-c-null)) -(define c-null? - (lambda (pointer) - (invoke pointer 'equals null-pointer))) - -(define u8-value-layout (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) -(define c-bytevector-u8-set! - (lambda (c-bytevector k byte) - (invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) - 'set - u8-value-layout - k - byte))) -(define c-bytevector-u8-ref - (lambda (c-bytevector k) - (invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) - 'get - u8-value-layout - k))) - -(define pointer-value-layout (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) -(define c-bytevector-pointer-set! - (lambda (c-bytevector k pointer) - (invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) - 'set - pointer-value-layout - k - pointer))) - -(define c-bytevector-pointer-ref - (lambda (c-bytevector k) - (invoke (invoke c-bytevector 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) - 'get - pointer-value-layout - k))) - -#;(define-syntax call-with-address-of-c-bytevector - (syntax-rules () - ((_ input-pointer thunk) - (let ((address-pointer (make-c-bytevector (c-type-size 'pointer)))) - (pointer-set! address-pointer 'pointer 0 input-pointer) - (apply thunk (list address-pointer)) - (set! input-pointer (pointer-get address-pointer 'pointer 0)) - (c-free address-pointer))))) diff --git a/snow/foreign/c/primitives/larceny-util.scm b/snow/foreign/c/primitives/larceny-util.scm deleted file mode 100644 index 8228fac..0000000 --- a/snow/foreign/c/primitives/larceny-util.scm +++ /dev/null @@ -1,88 +0,0 @@ -;; Copied from Larceny source -;; Copyright 1998 Lars T Hansen. -;; Copied code begins - -(define %set32u) - -; %peek* and %poke*: convenient access to values in memory. - -(define (%peek8 addr) - (let ((x (make-bytevector 1))) - (peek-bytes addr x 1) - (let ((v (bytevector-ref x 0))) - (if (> v 127) - (- (- 256 v)) - v)))) - -(define (%peek16 addr) - (let ((x (make-bytevector 2))) - (peek-bytes addr x 2) - (%get16 x 0))) - -(define (%peek32 addr) - (let ((x (make-bytevector 4))) - (peek-bytes addr x 4) - (%get32 x 0))) - -(define (%peek8u addr) - (let ((x (make-bytevector 1))) - (peek-bytes addr x 1) - (bytevector-ref x 0))) - -(define (%peek16u addr) - (let ((x (make-bytevector 2))) - (peek-bytes addr x 2) - (%get16u x 0))) - -(define (%peek32u addr) - (let ((x (make-bytevector 4))) - (peek-bytes addr x 4) - (%get32u x 0))) - -(define (%poke8 addr val) - (let ((x (make-bytevector 1))) - (if (< val 0) - (bytevector-set! x 0 (+ 256 val)) - (bytevector-set! x 0 val)) - (poke-bytes addr x 1))) - -(define (%poke16 addr val) - (let ((x (make-bytevector 2))) - (%set16 x 0 val) - (poke-bytes addr x 2))) - -(define (%poke32 addr val) - (let ((x (make-bytevector 4))) - (%set32 x 0 val) - (poke-bytes addr x 4))) - -(define (%poke8u addr val) - (let ((x (make-bytevector 1))) - (bytevector-set! x 0 val) - (poke-bytes addr x 1))) - -(define (%poke16u addr val) - (let ((x (make-bytevector 2))) - (%set16u x 0 val) - (poke-bytes addr x 2))) - -(define (%poke32u addr val) - (let ((x (make-bytevector 4))) - (%set32u x 0 val) - (poke-bytes addr x 4))) - -(define %peek-int %peek32) -(define %peek-long %peek32) -(define %peek-uint %peek32u) -(define %peek-ulong %peek32u) -(define %peek-short %peek16) -(define %peek-ushort %peek16u) -(define %peek-pointer %peek32u) - -(define %poke-int %poke32) -(define %poke-long %poke32) -(define %poke-uint %poke32u) -(define %poke-ulong %poke32u) -(define %poke-short %poke16) -(define %poke-ushort %poke16u) -(define %poke-pointer %poke32u) diff --git a/snow/foreign/c/primitives/larceny.scm b/snow/foreign/c/primitives/larceny.scm deleted file mode 100644 index a0d4c9e..0000000 --- a/snow/foreign/c/primitives/larceny.scm +++ /dev/null @@ -1,76 +0,0 @@ -(require 'std-ffi) -(require 'ffi-load) -(require 'foreign-ctools) -(require 'foreign-cenums) -(require 'foreign-stdlib) -(require 'foreign-sugar) -(require 'system-interface) - -;; FIXME -(define size-of-type - (lambda (type) - (cond ((eq? type 'int8) 1) - ((eq? type 'uint8) 1) - ((eq? type 'int16) 2) - ((eq? type 'uint16) 2) - ((eq? type 'int32) 4) - ((eq? type 'uint32) 4) - ((eq? type 'int64) 8) - ((eq? type 'uint64) 8) - ((eq? type 'char) 1) - ((eq? type 'unsigned-char) 1) - ((eq? type 'short) 2) - ((eq? type 'unsigned-short) 2) - ((eq? type 'int) 4) - ((eq? type 'unsigned-int) 4) - ((eq? type 'long) 4) - ((eq? type 'unsigned-long) 4) - ((eq? type 'float) 4) - ((eq? type 'double) 8) - ((eq? type 'pointer) sizeof:pointer) - ((eq? type 'void) 0) - ((eq? type 'callback) sizeof:pointer) - (else (error "Can not get size of unknown type" type))))) - -(define c-bytevector? - (lambda (object) - ;(void*? object) - (number? object))) - -(define shared-object-load - (lambda (headers path . options) - (foreign-file path))) - -(define c-bytevector-u8-set! - (lambda (c-bytevector k byte) - (syscall syscall:poke-bytes c-bytevector k (c-type-size 'uint8) byte))) - -(define c-bytevector-u8-ref - (lambda (c-bytevector k) - (syscall syscall:peek-bytes c-bytevector k (c-type-size 'uint8)))) - -(define c-bytevector-pointer-set! - (lambda (c-bytevector k pointer) - (syscall syscall:poke-bytes c-bytevector k (c-type-size 'pointer) pointer))) - -(define c-bytevector-pointer-ref - (lambda (c-bytevector k) - (syscall syscall:peek-bytes c-bytevector k (c-type-size 'pointer)))) - -(define-syntax define-c-procedure - (syntax-rules () - ((_ scheme-name shared-object c-name return-type argument-types) - (define scheme-name - 0 - - #;(make-c-function shared-object - (symbol->string c-name) - return-type - argument-types))))) - -(define-syntax define-c-callback - (syntax-rules () - ((_ scheme-name return-type argument-types procedure) - (define scheme-name - 0 - #;(make-c-callback return-type argument-types procedure))))) diff --git a/snow/foreign/c/primitives/mit-scheme.scm b/snow/foreign/c/primitives/mit-scheme.scm deleted file mode 100644 index e69de29..0000000 diff --git a/snow/foreign/c/primitives/mosh.scm b/snow/foreign/c/primitives/mosh.scm deleted file mode 100644 index b9bb7bf..0000000 --- a/snow/foreign/c/primitives/mosh.scm +++ /dev/null @@ -1,79 +0,0 @@ -(define size-of-type - (lambda (type) - (cond ((eq? type 'int8) 1) - ((eq? type 'uint8) 1) - ((eq? type 'int16) 2) - ((eq? type 'uint16) 2) - ((eq? type 'int32) 4) - ((eq? type 'uint32) 4) - ((eq? type 'int64) 8) - ((eq? type 'uint64) 8) - ((eq? type 'char) 1) - ((eq? type 'unsigned-char) 1) - ((eq? type 'short) size-of-short) - ((eq? type 'unsigned-short) size-of-unsigned-short) - ((eq? type 'int) size-of-int) - ((eq? type 'unsigned-int) size-of-unsigned-int) - ((eq? type 'long) size-of-long) - ((eq? type 'unsigned-long) size-of-unsigned-long) - ((eq? type 'float) size-of-float) - ((eq? type 'double) size-of-double) - ((eq? type 'pointer) size-of-pointer) - ((eq? type 'callback) size-of-pointer) - ((eq? type 'void) 0) - (else #f)))) - -(define shared-object-load - (lambda (path options) - (open-shared-library path))) - -(define c-bytevector? - (lambda (object) - (pointer? object))) - -(define c-bytevector-u8-set! pointer-set-c-uint8!) -(define c-bytevector-u8-ref pointer-ref-c-uint8) -(define c-bytevector-pointer-set! pointer-set-c-pointer!) -(define c-bytevector-pointer-ref pointer-ref-c-pointer) - -(define type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'int8_t) - ((equal? type 'uint8) 'uint8_t) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32_t) - ((equal? type 'uint32) 'uint32_t) - ((equal? type 'int64) 'int64_t) - ((equal? type 'uint64) 'uint64_t) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) 'void*) - ((equal? type 'void) 'void) - ((equal? type 'callback) 'void*) - (else (error "type->native-type -- No such type" type))))) - -(define-syntax define-c-procedure - (syntax-rules () - ((_ scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (make-c-function shared-object - (type->native-type return-type) - c-name - (map type->native-type argument-types)))))) - -(define-syntax define-c-callback - (syntax-rules () - ((_ scheme-name return-type argument-types procedure) - (define scheme-name - (make-c-callback (type->native-type return-type) - (map type->native-type argument-types) - procedure))))) diff --git a/snow/foreign/c/primitives/racket.scm b/snow/foreign/c/primitives/racket.scm deleted file mode 100644 index 525e8c9..0000000 --- a/snow/foreign/c/primitives/racket.scm +++ /dev/null @@ -1,83 +0,0 @@ -(define type->native-type - (lambda (type) - (cond ((equal? type 'int8) _int8) - ((equal? type 'uint8) _uint8) - ((equal? type 'int16) _int16) - ((equal? type 'uint16) _uint16) - ((equal? type 'int32) _int32) - ((equal? type 'uint32) _uint32) - ((equal? type 'int64) _int64) - ((equal? type 'uint64) _uint64) - ((equal? type 'char) _int8) - ((equal? type 'unsigned-char) _uint8) - ((equal? type 'short) _short) - ((equal? type 'unsigned-short) _ushort) - ((equal? type 'int) _int) - ((equal? type 'unsigned-int) _uint) - ((equal? type 'long) _long) - ((equal? type 'unsigned-long) _ulong) - ((equal? type 'float) _float) - ((equal? type 'double) _double) - ((equal? type 'pointer) _pointer) - ((equal? type 'void) _void) - ((equal? type 'callback) _pointer) - (else #f)))) - -(define c-bytevector? - (lambda (object) - (cpointer? object))) - -(define-syntax define-c-procedure - (syntax-rules () - ((_ scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (get-ffi-obj c-name - shared-object - (_cprocedure (mlist->list (map type->native-type argument-types)) - (type->native-type return-type))))))) - -(define-syntax define-c-callback - (syntax-rules () - ((_ scheme-name return-type argument-types procedure) - (define scheme-name (function-ptr procedure - (_cprocedure - (mlist->list (map type->native-type argument-types)) - (type->native-type return-type))))))) - -(define size-of-type - (lambda (type) - (ctype-sizeof (type->native-type type)))) - -(define shared-object-load - (lambda (path options) - (if (and (not (null? options)) - (assoc 'additional-versions options)) - (ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions - options)) - (list #f)))) - (ffi-lib path)))) - -(define c-bytevector-u8-set! - (lambda (c-bytevector k byte) - (ptr-set! c-bytevector _uint8 'abs k byte))) - -(define c-bytevector-u8-ref - (lambda (c-bytevector k) - (ptr-ref c-bytevector _uint8 'abs k))) - -(define c-bytevector-pointer-set! - (lambda (c-bytevector k pointer) - (ptr-set! c-bytevector _pointer 'abs k pointer))) - -(define c-bytevector-pointer-ref - (lambda (c-bytevector k) - (ptr-ref c-bytevector _pointer 'abs k))) - -#;(define-syntax call-with-address-of-c-bytevector - (syntax-rules () - ((_ input-pointer thunk) - (let ((address-pointer (make-c-bytevector (c-type-size 'pointer)))) - (c-bytevector-pointer-set! address-pointer 0 input-pointer) - (apply thunk (list address-pointer)) - (set! input-pointer (c-bytevector-pointer-ref address-pointer 0)) - (c-free address-pointer))))) diff --git a/snow/foreign/c/primitives/sagittarius.scm b/snow/foreign/c/primitives/sagittarius.scm deleted file mode 100644 index 78704a9..0000000 --- a/snow/foreign/c/primitives/sagittarius.scm +++ /dev/null @@ -1,124 +0,0 @@ -(define size-of-type - (lambda (type) - (cond ((eq? type 'int8) size-of-int8_t) - ((eq? type 'uint8) size-of-uint8_t) - ((eq? type 'int16) size-of-int16_t) - ((eq? type 'uint16) size-of-uint16_t) - ((eq? type 'int32) size-of-int32_t) - ((eq? type 'uint32) size-of-uint32_t) - ((eq? type 'int64) size-of-int64_t) - ((eq? type 'uint64) size-of-uint64_t) - ((eq? type 'char) size-of-char) - ((eq? type 'unsigned-char) size-of-char) - ((eq? type 'short) size-of-short) - ((eq? type 'unsigned-short) size-of-unsigned-short) - ((eq? type 'int) size-of-int) - ((eq? type 'unsigned-int) size-of-unsigned-int) - ((eq? type 'long) size-of-long) - ((eq? type 'unsigned-long) size-of-unsigned-long) - ((eq? type 'float) size-of-float) - ((eq? type 'double) size-of-double) - ((eq? type 'pointer) size-of-void*) - ((eq? type 'void) 0) - ((eq? type 'callback) size-of-void*) - (else #f)))) - -(define shared-object-load - (lambda (path options) - (open-shared-library path))) - -(define type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'int8_t) - ((equal? type 'uint8) 'uint8_t) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32_t) - ((equal? type 'uint32) 'uint32_t) - ((equal? type 'int64) 'int64_t) - ((equal? type 'uint64) 'uint64_t) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) 'void*) - ((equal? type 'void) 'void) - ((equal? type 'callback) 'callback) - (else #f)))) - -(define-syntax define-c-procedure - (syntax-rules () - ((_ scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (make-c-function shared-object - (type->native-type return-type) - c-name - (map type->native-type argument-types)))))) - -(define-syntax define-c-callback - (syntax-rules () - ((_ scheme-name return-type argument-types procedure) - (define scheme-name - (make-c-callback (type->native-type return-type) - (map type->native-type argument-types) - procedure))))) - -(define c-bytevector? - (lambda (object) - (pointer? object))) - -(define c-bytevector-u8-set! pointer-set-c-uint8_t!) -(define c-bytevector-u8-ref pointer-ref-c-uint8_t) -(define c-bytevector-pointer-set! pointer-set-c-pointer!) -(define c-bytevector-pointer-ref pointer-ref-c-pointer) - -#;(define pointer-set! - (lambda (pointer type offset value) - (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value)) - ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value)) - ((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value)) - ((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value)) - ((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value)) - ((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value)) - ((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value)) - ((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value)) - ((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value))) - ((equal? type 'short) (pointer-set-c-short! pointer offset value)) - ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value)) - ((equal? type 'int) (pointer-set-c-int! pointer offset value)) - ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value)) - ((equal? type 'long) (pointer-set-c-long! pointer offset value)) - ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value)) - ((equal? type 'float) (pointer-set-c-float! pointer offset value)) - ((equal? type 'double) (pointer-set-c-double! pointer offset value)) - ((equal? type 'void) (pointer-set-c-pointer! pointer offset value)) - ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) - -#;(define pointer-get - (lambda (pointer type offset) - (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset)) - ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset)) - ((equal? type 'int16) (pointer-ref-c-int16_t pointer offset)) - ((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset)) - ((equal? type 'int32) (pointer-ref-c-int32_t pointer offset)) - ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset)) - ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset)) - ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset)) - ((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset))) - ((equal? type 'short) (pointer-ref-c-short pointer offset)) - ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset)) - ((equal? type 'int) (pointer-ref-c-int pointer offset)) - ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset)) - ((equal? type 'long) (pointer-ref-c-long pointer offset)) - ((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset)) - ((equal? type 'float) (pointer-ref-c-float pointer offset)) - ((equal? type 'double) (pointer-ref-c-double pointer offset)) - ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) - ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) - diff --git a/snow/foreign/c/primitives/skint.scm b/snow/foreign/c/primitives/skint.scm deleted file mode 100644 index 88f9efc..0000000 --- a/snow/foreign/c/primitives/skint.scm +++ /dev/null @@ -1,3 +0,0 @@ -(define size-of-type - (lambda (type) - (cond ((equal? type 'int8) 1)))) diff --git a/snow/foreign/c/primitives/stklos.scm b/snow/foreign/c/primitives/stklos.scm deleted file mode 100644 index deb24a7..0000000 --- a/snow/foreign/c/primitives/stklos.scm +++ /dev/null @@ -1,110 +0,0 @@ -(define type->native-type - (lambda (type) - (cond ((equal? type 'int8) :char) - ((equal? type 'uint8) :char) - ((equal? type 'int16) :short) - ((equal? type 'uint16) :ushort) - ((equal? type 'int32) :int) - ((equal? type 'uint32) :uint) - ((equal? type 'int64) :long) - ((equal? type 'uint64) :ulong) - ((equal? type 'char) :char) - ((equal? type 'unsigned-char) :uchar) - ((equal? type 'short) :short) - ((equal? type 'unsigned-short) :ushort) - ((equal? type 'int) :int) - ((equal? type 'unsigned-int) :uint) - ((equal? type 'long) :long) - ((equal? type 'unsigned-long) :ulong) - ((equal? type 'float) :float) - ((equal? type 'double) :double) - ((equal? type 'pointer) :pointer) - ((equal? type 'void) :void) - ((equal? type 'callback) :pointer) - (else (error "type->native-type -- No such pffi type" type))))) - -(define c-bytevector? - (lambda (object) - (cpointer? object))) - -(define-syntax define-c-procedure - (syntax-rules () - ((_ scheme-name shared-object c-name return-type argument-types) - (begin - (define type->native-type - (lambda (type) - (cond ((equal? type 'int8) :char) - ((equal? type 'uint8) :char) - ((equal? type 'int16) :short) - ((equal? type 'uint16) :ushort) - ((equal? type 'int32) :int) - ((equal? type 'uint32) :uint) - ((equal? type 'int64) :long) - ((equal? type 'uint64) :ulong) - ((equal? type 'char) :char) - ((equal? type 'unsigned-char) :char) - ((equal? type 'short) :short) - ((equal? type 'unsigned-short) :ushort) - ((equal? type 'int) :int) - ((equal? type 'unsigned-int) :uint) - ((equal? type 'long) :long) - ((equal? type 'unsigned-long) :ulong) - ((equal? type 'float) :float) - ((equal? type 'double) :double) - ((equal? type 'pointer) :pointer) - ((equal? type 'void) :void) - ((equal? type 'callback) :pointer) - (else (error "type->native-type -- No such pffi type" type))))) - (define scheme-name - (make-external-function - (symbol->string c-name) - (map type->native-type argument-types) - (type->native-type return-type) - shared-object)))))) - -(define-syntax define-c-callback - (syntax-rules () - ((_ scheme-name return-type argument-types procedure) - (define scheme-name - (%make-callback procedure - (map type->native-type argument-types) - (type->native-type return-type)))))) - -; FIXME -(define size-of-type - (lambda (type) - (cond ((equal? type 'int8) 1) - ((equal? type 'uint8) 1) - ((equal? type 'int16) 2) - ((equal? type 'uint16) 2) - ((equal? type 'int32) 4) - ((equal? type 'uint32) 4) - ((equal? type 'int64) 8) - ((equal? type 'uint64) 8) - ((equal? type 'char) 1) - ((equal? type 'unsigned-char) 1) - ((equal? type 'short) 2) - ((equal? type 'unsigned-short) 2) - ((equal? type 'int) 4) - ((equal? type 'unsigned-int) 4) - ((equal? type 'long) 8) - ((equal? type 'unsigned-long) 8) - ((equal? type 'float) 4) - ((equal? type 'double) 8) - ((equal? type 'pointer) 8)))) - -(define c-bytevector-u8-set! - (lambda (pointer offset value) - (cpointer-set! pointer :uint8 value offset))) - -(define c-bytevector-u8-ref - (lambda (pointer offset) - (cpointer-ref pointer :uint8 offset))) - -(define c-bytevector-pointer-set! - (lambda (pointer offset value) - (cpointer-set! pointer :pointer value offset))) - -(define c-bytevector-pointer-ref - (lambda (pointer offset) - (cpointer-ref pointer :pointer offset))) diff --git a/snow/foreign/c/primitives/tr7.scm b/snow/foreign/c/primitives/tr7.scm deleted file mode 100644 index 88f9efc..0000000 --- a/snow/foreign/c/primitives/tr7.scm +++ /dev/null @@ -1,3 +0,0 @@ -(define size-of-type - (lambda (type) - (cond ((equal? type 'int8) 1)))) diff --git a/snow/foreign/c/primitives/ypsilon.scm b/snow/foreign/c/primitives/ypsilon.scm deleted file mode 100644 index b38043e..0000000 --- a/snow/foreign/c/primitives/ypsilon.scm +++ /dev/null @@ -1,188 +0,0 @@ -(define size-of-type - (lambda (type) - (cond ((eq? type 'int8) (c-sizeof int8_t)) - ((eq? type 'uint8) (c-sizeof uint8_t)) - ((eq? type 'int16) (c-sizeof int16_t)) - ((eq? type 'uint16) (c-sizeof uint16_t)) - ((eq? type 'int32) (c-sizeof int32_t)) - ((eq? type 'uint32) (c-sizeof uint32_t)) - ((eq? type 'int64) (c-sizeof int64_t)) - ((eq? type 'uint64) (c-sizeof uint64_t)) - ((eq? type 'char) (c-sizeof char)) - ((eq? type 'unsigned-char) (c-sizeof char)) - ((eq? type 'short) (c-sizeof short)) - ((eq? type 'unsigned-short) (c-sizeof unsigned-short)) - ((eq? type 'int) (c-sizeof int)) - ((eq? type 'unsigned-int) (c-sizeof unsigned-int)) - ((eq? type 'long) (c-sizeof long)) - ((eq? type 'unsigned-long) (c-sizeof unsigned-long)) - ((eq? type 'float) (c-sizeof float)) - ((eq? type 'double) (c-sizeof double)) - ((eq? type 'pointer) (c-sizeof void*)) - ((eq? type 'struct) (c-sizeof void*)) - ((eq? type 'callback) (c-sizeof void*)) - ((eq? type 'void) 0) - (else #f)))) - -(define c-bytevector? - (lambda (object) - (number? object))) - -(define c-bytevector-u8-set! - (lambda (c-bytevector k byte) - (bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k) - (c-type-size 'uint8)) - 0 - byte))) - -(define c-bytevector-u8-ref - (lambda (c-bytevector k) - (bytevector-c-int8-ref (make-bytevector-mapping (+ c-bytevector k) - (c-type-size 'uint8)) - 0))) -(define c-bytevector-pointer-set! - (lambda (c-bytevector k pointer) - (let ((bv (make-bytevector-mapping (+ c-bytevector k) (c-type-size 'pointer)))) - (bytevector-c-void*-set! bv 0 pointer)))) -(define c-bytevector-pointer-ref - (lambda (c-bytevector k) - (let ((bv (make-bytevector-mapping (+ c-bytevector k) (c-type-size 'pointer)))) - (bytevector-c-void*-ref bv 0)))) - -#;(define pointer-set! - (lambda (pointer type offset value) - (let ((bv (make-bytevector-mapping (+ pointer offset) (c-type-size type)))) - (cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value)) - ((equal? type 'uint8) (bytevector-c-int8-set! bv 0 value)) - ((equal? type 'int16) (bytevector-c-int16-set! bv 0 value)) - ((equal? type 'uint16) (bytevector-c-int16-set! bv 0 value)) - ((equal? type 'int32) (bytevector-c-int32-set! bv 0 value)) - ((equal? type 'uint32) (bytevector-c-int32-set! bv 0 value)) - ((equal? type 'int64) (bytevector-c-int64-set! bv 0 value)) - ((equal? type 'uint64) (bytevector-c-int64-set! bv 0 value)) - ((equal? type 'char) (bytevector-c-int8-set! bv 0 (char->integer value))) - ((equal? type 'short) (bytevector-c-short-set! bv 0 value)) - ((equal? type 'unsigned-short) (bytevector-c-short-set! bv 0 value)) - ((equal? type 'int) (bytevector-c-int-set! bv 0 value)) - ((equal? type 'unsigned-int) (bytevector-c-int-set! bv 0 value)) - ((equal? type 'long) (bytevector-c-long-set! bv 0 value)) - ((equal? type 'unsigned-long) (bytevector-c-long-set! bv 0 value)) - ((equal? type 'float) (bytevector-c-float-set! bv 0 value)) - ((equal? type 'double) (bytevector-c-double-set! bv 0 value)) - ((equal? type 'void) (bytevector-c-void*-set! bv 0 value)) - ((equal? type 'pointer) (bytevector-c-void*-set! bv 0 value)))))) - -#;(define pointer-get - (lambda (pointer type offset) - (let ((bv (make-bytevector-mapping (+ pointer offset) (c-type-size type)))) - (cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0)) - ((equal? type 'uint8) (bytevector-c-uint8-ref bv 0)) - ((equal? type 'int16) (bytevector-c-int16-ref bv 0)) - ((equal? type 'uint16) (bytevector-c-uint16-ref bv 0)) - ((equal? type 'int32) (bytevector-c-int32-ref bv 0)) - ((equal? type 'uint32) (bytevector-c-uint32-ref bv 0)) - ((equal? type 'int64) (bytevector-c-int64-ref bv 0)) - ((equal? type 'uint64) (bytevector-c-uint64-ref bv 0)) - ((equal? type 'char) (integer->char (bytevector-c-uint8-ref bv 0))) - ((equal? type 'short) (bytevector-c-short-ref bv 0)) - ((equal? type 'unsigned-short) (bytevector-c-unsigned-short-ref bv 0)) - ((equal? type 'int) (bytevector-c-int-ref bv 0)) - ((equal? type 'unsigned-int) (bytevector-c-unsigned-int-ref bv 0)) - ((equal? type 'long) (bytevector-c-long-ref bv 0)) - ((equal? type 'unsigned-long) (bytevector-c-unsigned-long-ref bv 0)) - ((equal? type 'float) (bytevector-c-float-ref bv 0)) - ((equal? type 'double) (bytevector-c-double-ref bv 0)) - ((equal? type 'void) (bytevector-c-void*-ref bv 0)) - ((equal? type 'pointer) (bytevector-c-void*-ref bv 0)))))) - -(define shared-object-load - (lambda (path options) - (load-shared-object path))) - -#;(define-macro - (type->native-type type) - `(cond ((equal? ,type 'int8) 'int8_t) - ((equal? ,type 'uint8) 'uint8_t) - ;((equal? ,type 'int16) 'int16_t) - ;((equal? ,type 'uint16) 'uint16_t) - ;((equal? ,type 'int32) 'int32_t) - ;((equal? ,type 'uint32) 'uint32_t) - ;((equal? ,type 'int64) 'int64_t) - ;((equal? ,type 'uint64) 'uint64_t) - ;((equal? ,type 'char) 'char) - ;((equal? ,type 'unsigned-char) 'char) - ;((equal? ,type 'short) 'short) - ;((equal? ,type 'unsigned-short) 'unsigned-short) - ((equal? ,type 'int) 'int) - ;((equal? ,type 'unsigned-int) 'unsigned-int) - ;((equal? ,type 'long) 'long) - ;((equal? ,type 'unsigned-long) 'unsigned-long) - ;((equal? ,type 'float) 'float) - ;((equal? ,type 'double) 'double) - ((equal? ,type 'pointer) 'void*) - ((equal? ,type 'void) 'void) - ;((equal? ,type 'callback) 'void*) - (else (error "type->native-type -- No such type" ,type)))) - -(define-macro - (define-c-procedure scheme-name shared-object c-name return-type argument-types) - (begin - (let ((type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'int8_t) - ((equal? type 'uint8) 'uint8_t) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32_t) - ((equal? type 'uint32) 'uint32_t) - ((equal? type 'int64) 'int64_t) - ((equal? type 'uint64) 'uint64_t) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) 'void*) - ((equal? type 'void) 'void) - ((equal? type 'callback) 'void*) - (else (error "type->native-type -- No such type" type)))))) - `(define ,scheme-name - (c-function ,(type->native-type (cadr return-type)) - ,(cadr c-name) - ,(map type->native-type (cadr argument-types))))))) - -(define-macro - (define-c-callback scheme-name return-type argument-types procedure) - (let* ((type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'int8_t) - ((equal? type 'uint8) 'uint8_t) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32_t) - ((equal? type 'uint32) 'uint32_t) - ((equal? type 'int64) 'int64_t) - ((equal? type 'uint64) 'uint64_t) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) 'void*) - ((equal? type 'void) 'void) - ((equal? type 'callback) 'void*) - (else (error "type->native-type -- No such type" type))))) - (native-return-type (type->native-type (cadr return-type))) - (native-argument-types (map type->native-type (cadr argument-types)))) - `(define ,scheme-name - (c-callback ,native-return-type ,native-argument-types ,procedure)))) diff --git a/snow/foreign/c/struct.scm b/snow/foreign/c/struct.scm deleted file mode 100644 index 926b9ee..0000000 --- a/snow/foreign/c/struct.scm +++ /dev/null @@ -1,101 +0,0 @@ -(define-record-type - (struct-make c-type size pointer members) - pffi-struct? - (c-type pffi-struct-c-type) - (size pffi-struct-size) - (pointer pffi-struct-pointer) - (members pffi-struct-members)) - -(define-syntax pffi-define-struct - (syntax-rules () - ((_ name c-type members) - (define name - (lambda arguments - (let* ((size-and-offsets (calculate-struct-size-and-offsets members)) - (size (cdr (assoc 'size size-and-offsets))) - (offsets (cdr (assoc 'offsets size-and-offsets))) - (pointer (if (and (not (null? arguments)) - (c-bytevector? (car arguments))) - (car arguments) - (make-c-bytevector size))) - (c-type-string (if (string? c-type) c-type (symbol->string c-type)))) - (struct-make c-type-string size pointer offsets))))))) - -(define c-align-of - (lambda (type) - (cond-expand - ;(guile (alignof (pffi-type->native-type type))) - (else (size-of-type type))))) - -(define round-to-next-modulo-of - (lambda (to-round roundee) - (if (= (modulo to-round roundee) 0) - to-round - (round-to-next-modulo-of (+ to-round 1) roundee)))) - -(define calculate-struct-size-and-offsets - (lambda (members) - (let* ((size 0) - (largest-member-size 0) - (offsets (map (lambda (member) - (let* ((name (cdr member)) - (type (car member)) - (type-alignment (c-align-of type))) - (when (> (size-of-type type) largest-member-size) - (set! largest-member-size (size-of-type type))) - (if (or (= size 0) - (= (modulo size type-alignment) 0)) - (begin - (set! size (+ size type-alignment)) - (list name type (- size type-alignment))) - (let ((next-alignment (round-to-next-modulo-of size type-alignment))) - (set! size (+ next-alignment type-alignment)) - (list name - type - next-alignment))))) - members))) - (list (cons 'size - (cond-expand - ;(guile (sizeof (map pffi-type->native-type (map car members)))) - (else - (if (= (modulo size largest-member-size) 0) - size - (round-to-next-modulo-of size largest-member-size))))) - (cons 'offsets offsets))))) - -#;(define pffi-struct-make - (lambda (c-type members . pointer) - (for-each - (lambda (member) - (when (not (pair? member)) - (error "All struct members must be pairs" (list c-type member))) - (when (not (symbol? (car member))) - (error "All struct member types must be symbols" (list c-type member))) - (when (not (symbol? (cdr member))) - (error "All struct member names must be symbols" (list c-type member)))) - members) - (let* ((size-and-offsets (calculate-struct-size-and-offsets members)) - (size (cdr (assoc 'size size-and-offsets))) - (offsets (cdr (assoc 'offsets size-and-offsets))) - (pointer (if (null? pointer) (make-c-bytevector size) (car pointer))) - (c-type (if (string? c-type) c-type (symbol->string c-type)))) - (struct-make c-type size pointer offsets)))) - -(define (pffi-struct-offset-get struct member-name) - (when (not (assoc member-name (pffi-struct-members struct))) - (error "Struct has no such member" (list struct member-name))) - (car (cdr (cdr (assoc member-name (pffi-struct-members struct)))))) - -(define (pffi-struct-get struct member-name) - (when (not (assoc member-name (pffi-struct-members struct))) - (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))))))) - (pffi-pointer-get (pffi-struct-pointer struct) type offset))) - -(define (pffi-struct-set! struct member-name value) - (when (not (assoc member-name (pffi-struct-members struct))) - (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))))))) - (pffi-pointer-set! (pffi-struct-pointer struct) type offset value))) diff --git a/snow/srfi/170.scm b/snow/srfi/170.scm deleted file mode 100644 index 67efce7..0000000 --- a/snow/srfi/170.scm +++ /dev/null @@ -1,143 +0,0 @@ -(define slash (cond-expand (windows "\\") (else "/"))) - -(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)) -(define-c-procedure c-stat libc 'stat 'int '(pointer pointer)) -(define-c-procedure c-opendir libc 'opendir 'pointer '(pointer)) -(define-c-procedure c-readdir libc 'readdir 'pointer '(pointer)) -(define-c-procedure c-closedir libc 'closedir 'int '(pointer)) -(define-c-procedure c-realpath libc 'realpath 'pointer '(pointer pointer)) - -(define-record-type file-info-record - (file-info-record-make device inode mode nlinks uid gid rdev size blksize blocks atime mtime ctime fname/port follow?) - file-info? - (device file-info:device) - (inode file-info:inode) - (mode file-info:mode) - (nlinks file-info:nlinks) - (uid file-info:uid) - (gid file-info:gid) - (rdev file-info:rdev) - (size file-info:size) - (blksize file-info:blksize) - (blocks file-info:blocks) - (atime file-info:atime) - (mtime file-info:mtime) - (ctime file-info:ctime) - (fname/port file-info:fname/port) - (follow? file-info:follow?)) - -; FIX make the "follow?" argument work -(define file-info - (lambda (fname/port follow?) - (when (port? fname/port) - (error "file-info implementation does not support ports as arguments")) - (let* ((fname-pointer (string->c-utf8 fname/port)) - (stat-pointer (make-c-bytevector 256)) - (result (c-stat fname-pointer stat-pointer)) - (error-message "file-info error") - (error-pointer (string->c-utf8 error-message))) - (when (< result 0) - (c-perror error-pointer) - (c-free fname-pointer) - (c-free stat-pointer) - (c-free error-pointer) - (error error-message fname/port)) - (file-info-record-make (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 0) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 1) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 2) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 3) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 4) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 5) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 6) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 7) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 8) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 9) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 10) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 11) (native-endianness)) - (c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 12) (native-endianness)) - fname/port - follow?)))) - -(define create-directory - (lambda (fname . permission-bits) - (let* ((fname-pointer (string->c-utf8 fname)) - (mode (if (null? permission-bits) - #o775 - (string->number (string-append "#o" - (number->string (car permission-bits)))))) - (result (c-mkdir fname-pointer mode)) - (error-message "create-directory error") - (error-pointer (string->c-utf8 error-message))) - (c-free fname-pointer) - (when (< result 0) - (c-perror error-pointer) - (c-free error-pointer) - (error error-message))))) - -(define delete-directory - (lambda (fname) - (let* ((fname-pointer (string->c-utf8 fname)) - (result (c-rmdir fname-pointer)) - (error-message "delete-directory error") - (error-pointer (string->c-utf8 error-message))) - (c-free fname-pointer) - (when (< result 0) - (c-perror error-pointer) - (c-free error-pointer) - (error error-message))))) - -(define pointer-string-read - (lambda (pointer offset) - (letrec* ((looper (lambda (c index result) - (if (char=? c #\null) - (list->string (reverse result)) - (looper (c-bytevector-char-ref pointer - (+ offset index)) - (+ index 1) - (cons c result)))))) - (looper (c-bytevector-char-ref pointer offset) 1 (list))))) - -(define directory-files - (lambda (dir . dotfiles?) - (letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?))) - (path-pointer (string->c-utf8 dir)) - (directory-pointer (c-opendir path-pointer)) - (error-message "directory-files error") - (error-pointer (string->c-utf8 error-message)) - (name-offset 19) ; struct dirent d_name offset on linux - (looper (lambda (directory-entity files) - (if (c-null? directory-entity) - files - (let ((name (pointer-string-read directory-entity - name-offset))) - (looper (c-readdir directory-pointer) - (if (or (string=? name ".") - (string=? name "..")) - (if include-dotfiles? - (cons name files) - files) - (cons name files)))))))) - (when (c-null? directory-pointer) - (c-perror error-pointer) - ;(c-free error-pointer) - ;(c-free directory) - ;(c-free path-pointer) - (error error-message)) - (let ((files (looper (c-readdir directory-pointer) (list)))) - ;(c-free error-pointer) - ;(c-free directory-pointer) - ;(c-free path-pointer) - (c-closedir directory-pointer) - files)))) - -(define real-path - (lambda (path) - (let* ((path-pointer (string->c-utf8 path)) - (real-path-pointer (c-realpath path-pointer (make-c-null))) - (real-path (c-utf8->string real-path-pointer))) - (c-free path-pointer) - (c-free real-path-pointer) - real-path))) - diff --git a/snow/srfi/170.sld b/snow/srfi/170.sld deleted file mode 100644 index 5e3d7ad..0000000 --- a/snow/srfi/170.sld +++ /dev/null @@ -1,85 +0,0 @@ -(define-library - (srfi 170) - (import (scheme base) - (scheme write) - (scheme file) - (foreign c) - (scheme process-context)) - (export ;posix-error? - ;posix-error-name - ;posix-error-message - ;open-file - ;fd->port - create-directory - ;create-fifo - ;create-hard-link - ;create-symlink - ;read-symlink - ;rename-file - delete-directory - ;set-file-owner - ;set-file-times - ;truncate-file - file-info - file-info? - file-info:device - file-info:inode - file-info:mode - file-info:nlinks - file-info:uid - file-info:gid - file-info:rdev - file-info:size - file-info:blksize - file-info:blocks - file-info:atime - file-info:mtime - file-info:ctime - ;file-info-directory? - ;file-info-fifo? - ;file-info-symlink? - ;file-info-regular? - ;file-info-socket? - ;file-info-device? - ;set-file-mode - directory-files - ;make-directory-files-generator - ;open-directory - ;read-directory - ;close-directory - real-path - ;file-space - ;temp-file-prefix - ;create-temp-file - ;call-with-temporary-filename - ;umask - ;set-umask! - ;current-directory - ;set-current-directory! - ;pid - ;nice - ;user-uid - ;user-gid - ;user-effective-uid - ;user-effective-gid - ;user-supplementary-gids - ;user-info - ;user-info? - ;user-info:name - ;user-info:uid - ;user-info:gid - ;user-info:home-dir - ;user-info:shell - ;user-info:full-name - ;user-info:parsed-full-name - ;group-info - ;group-info? - ;group-info:name - ;group-info:gid - ;posix-time - ;monotonic-time - ;set-environment-variable! - ;delete-environment-variable! - ;terminal? - ) - (include "170.scm")) diff --git a/snow/srfi/srfi-170.scm b/snow/srfi/srfi-170.scm deleted file mode 100644 index 403dbab..0000000 --- a/snow/srfi/srfi-170.scm +++ /dev/null @@ -1,86 +0,0 @@ -;; This file exists for guile compability -(define-library - (srfi 170) - (import (scheme base) - (scheme write) - (scheme file) - (foreign c) - (scheme process-context)) - (export ;posix-error? - ;posix-error-name - ;posix-error-message - ;open-file - ;fd->port - create-directory - ;create-fifo - ;create-hard-link - ;create-symlink - ;read-symlink - ;rename-file - delete-directory - ;set-file-owner - ;set-file-times - ;truncate-file - file-info - file-info? - file-info:device - file-info:inode - file-info:mode - file-info:nlinks - file-info:uid - file-info:gid - file-info:rdev - file-info:size - file-info:blksize - file-info:blocks - file-info:atime - file-info:mtime - file-info:ctime - ;file-info-directory? - ;file-info-fifo? - ;file-info-symlink? - ;file-info-regular? - ;file-info-socket? - ;file-info-device? - ;set-file-mode - directory-files - ;make-directory-files-generator - ;open-directory - ;read-directory - ;close-directory - real-path - ;file-space - ;temp-file-prefix - ;create-temp-file - ;call-with-temporary-filename - ;umask - ;set-umask! - ;current-directory - ;set-current-directory! - ;pid - ;nice - ;user-uid - ;user-gid - ;user-effective-uid - ;user-effective-gid - ;user-supplementary-gids - ;user-info - ;user-info? - ;user-info:name - ;user-info:uid - ;user-info:gid - ;user-info:home-dir - ;user-info:shell - ;user-info:full-name - ;user-info:parsed-full-name - ;group-info - ;group-info? - ;group-info:name - ;group-info:gid - ;posix-time - ;monotonic-time - ;set-environment-variable! - ;delete-environment-variable! - ;terminal? - ) - (include "170.scm"))