From 508d2060d478e75d492baae9aac108eae3b8d2fe Mon Sep 17 00:00:00 2001 From: retropikzel Date: Mon, 19 Jan 2026 20:27:34 +0200 Subject: [PATCH] Improve testing --- Dockerfile.test | 9 +- Makefile | 14 +- fcgi-lighttpd.conf | 17 + foreign/c-bytevectors.sld | 1194 ++++++++++++ foreign/c.rkt | 3 + foreign/c.scm | 861 +++++++++ foreign/c.sld | 137 ++ foreign/c/array.scm | 59 + foreign/c/array.sld | 14 + foreign/c/bytevectors.scm | 0 foreign/c/capyscheme-primitives.scm | 101 + foreign/c/capyscheme-primitives.sld | 23 + foreign/c/chezscheme-primitives.scm | 187 ++ foreign/c/chezscheme-primitives.sld | 18 + foreign/c/chibi-primitives.c | 854 +++++++++ foreign/c/chibi-primitives.scm | 165 ++ foreign/c/chibi-primitives.sld | 24 + foreign/c/chibi-primitives.so | Bin 0 -> 46888 bytes foreign/c/chibi-primitives.stub | 324 ++++ foreign/c/chibi-scheme-primitives.c | 3 + foreign/c/chicken-primitives.scm | 198 ++ foreign/c/chicken-primitives.sld | 35 + foreign/c/cyclone-primitives.c | 2533 ++++++++++++++++++++++++++ foreign/c/cyclone-primitives.sld | 296 +++ foreign/c/define-c-library.scm | 160 ++ foreign/c/gambit-primitives.scm | 240 +++ foreign/c/gambit-primitives.sld | 20 + foreign/c/gauche-primitives.scm | 98 + foreign/c/gauche-primitives.sld | 24 + foreign/c/guile-primitives.scm | 96 + foreign/c/guile-primitives.sld | 29 + foreign/c/ikarus-primitives.sld | 123 ++ foreign/c/ironscheme-primitives.sld | 140 ++ foreign/c/kawa-primitives.scm | 175 ++ foreign/c/kawa-primitives.sld | 22 + foreign/c/larceny-primitives.scm | 105 ++ foreign/c/larceny-primitives.sld | 50 + foreign/c/libc.scm | 32 + foreign/c/mit-scheme-primitives.sld | 34 + foreign/c/mosh-primitives.scm | 113 ++ foreign/c/mosh-primitives.sld | 24 + foreign/c/racket-primitives.rkt | 3 + foreign/c/racket-primitives.scm | 86 + foreign/c/racket-primitives.sld | 42 + foreign/c/sagittarius-primitives.scm | 111 ++ foreign/c/sagittarius-primitives.sld | 24 + foreign/c/stklos-primitives.scm | 122 ++ foreign/c/stklos-primitives.sld | 46 + foreign/c/struct.scm | 166 ++ foreign/c/struct.sld | 17 + foreign/c/ypsilon-primitives.scm | 147 ++ foreign/c/ypsilon-primitives.sld | 32 + lighttpd.conf | 16 - retropikzel/fcgi/test.scm | 15 + 54 files changed, 9356 insertions(+), 25 deletions(-) create mode 100644 fcgi-lighttpd.conf create mode 100644 foreign/c-bytevectors.sld create mode 100644 foreign/c.rkt create mode 100644 foreign/c.scm create mode 100644 foreign/c.sld create mode 100644 foreign/c/array.scm create mode 100644 foreign/c/array.sld create mode 100644 foreign/c/bytevectors.scm create mode 100644 foreign/c/capyscheme-primitives.scm create mode 100644 foreign/c/capyscheme-primitives.sld create mode 100644 foreign/c/chezscheme-primitives.scm create mode 100644 foreign/c/chezscheme-primitives.sld create mode 100644 foreign/c/chibi-primitives.c create mode 100644 foreign/c/chibi-primitives.scm create mode 100644 foreign/c/chibi-primitives.sld create mode 100755 foreign/c/chibi-primitives.so create mode 100644 foreign/c/chibi-primitives.stub create mode 100644 foreign/c/chibi-scheme-primitives.c create mode 100644 foreign/c/chicken-primitives.scm create mode 100644 foreign/c/chicken-primitives.sld create mode 100644 foreign/c/cyclone-primitives.c create mode 100644 foreign/c/cyclone-primitives.sld create mode 100644 foreign/c/define-c-library.scm create mode 100644 foreign/c/gambit-primitives.scm create mode 100644 foreign/c/gambit-primitives.sld create mode 100644 foreign/c/gauche-primitives.scm create mode 100644 foreign/c/gauche-primitives.sld create mode 100644 foreign/c/guile-primitives.scm create mode 100644 foreign/c/guile-primitives.sld create mode 100644 foreign/c/ikarus-primitives.sld create mode 100644 foreign/c/ironscheme-primitives.sld create mode 100644 foreign/c/kawa-primitives.scm create mode 100644 foreign/c/kawa-primitives.sld create mode 100644 foreign/c/larceny-primitives.scm create mode 100644 foreign/c/larceny-primitives.sld create mode 100644 foreign/c/libc.scm create mode 100644 foreign/c/mit-scheme-primitives.sld create mode 100644 foreign/c/mosh-primitives.scm create mode 100644 foreign/c/mosh-primitives.sld create mode 100644 foreign/c/racket-primitives.rkt create mode 100644 foreign/c/racket-primitives.scm create mode 100644 foreign/c/racket-primitives.sld create mode 100644 foreign/c/sagittarius-primitives.scm create mode 100644 foreign/c/sagittarius-primitives.sld create mode 100644 foreign/c/stklos-primitives.scm create mode 100644 foreign/c/stklos-primitives.sld create mode 100644 foreign/c/struct.scm create mode 100644 foreign/c/struct.sld create mode 100644 foreign/c/ypsilon-primitives.scm create mode 100644 foreign/c/ypsilon-primitives.sld delete mode 100644 lighttpd.conf create mode 100644 retropikzel/fcgi/test.scm diff --git a/Dockerfile.test b/Dockerfile.test index 5bbf0dd..ae6e6e0 100644 --- a/Dockerfile.test +++ b/Dockerfile.test @@ -20,7 +20,8 @@ RUN make build-gauche ARG SCHEME=chibi ARG IMAGE=${SCHEME}:head FROM schemers/${IMAGE} -RUN apt-get update && apt-get install -y make gcc libffi-dev libcurl4 gauche +RUN apt-get update && apt-get install -y \ + make gcc libffi-dev libcurl4 gauche lighttpd RUN mkdir ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm COPY --from=build /build /build ARG SCHEME=chibi @@ -33,7 +34,13 @@ RUN bash install.sh ENV PATH=/root/.local/bin:${PATH} RUN akku update WORKDIR /workdir +COPY fcgi-lighttpd.conf . +RUN snow-chibi --impls=${SCHEME} --always-yes install "(srfi 60)" RUN snow-chibi --impls=${SCHEME} --always-yes install "(srfi 64)" +RUN if [ "${SCHEME}" != "gauche" ]; then snow-chibi --impls=${SCHEME} --always-yes install "(srfi 106)"; fi +RUN if [ "${SCHEME}" != "gauche" ]; then snow-chibi --impls=${SCHEME} --always-yes install --install-source-dir=. --install-library-dir=. "(srfi 106)"; fi RUN snow-chibi --impls=${SCHEME} --always-yes install "(srfi 180)" COPY Makefile . COPY retropikzel retropikzel/ +COPY foreign foreign/ +RUN akku install loko-srfi diff --git a/Makefile b/Makefile index 12913f3..07611d7 100644 --- a/Makefile +++ b/Makefile @@ -22,8 +22,6 @@ DOCKERIMG="chicken:5" endif DOCKER_TAG=scheme-library-test-${SCHEME} -DOCKER_QUIET="--quiet" - all: build build: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION retropikzel/${LIBRARY}/README.md @@ -44,7 +42,7 @@ ${TMPDIR}: if [ -d srfi ]; then cp -r srfi ${TMPDIR}/; fi test-r6rs: ${TMPDIR} - cd ${TMPDIR} && printf "#!r6rs\n(import (rnrs base) (rnrs control) (rnrs io simple) (rnrs files) (rnrs programs) (srfi :64) (srfi :180) (retropikzel ${LIBRARY}))\n" > test-r6rs.sps + cd ${TMPDIR} && printf "#!r6rs\n(import (rnrs base) (rnrs control) (rnrs io simple) (rnrs files) (rnrs programs) (srfi :64) (retropikzel ${LIBRARY}))\n" > test-r6rs.sps cat ${TESTFILE} >> ${TMPDIR}/test-r6rs.sps cd ${TMPDIR} && akku install chez-srfi akku-r7rs cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} timeout 120 compile-scheme -I .akku/lib -o test-r6rs test-r6rs.sps @@ -52,19 +50,19 @@ test-r6rs: ${TMPDIR} test-r6rs-docker: ${TMPDIR} echo "Building docker image..." - docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=${DOCKER_TAG} -f Dockerfile.test ${DOCKER_QUIET} . - docker run -t ${DOCKER_TAG} sh -c "make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes LIBRARY=${LIBRARY} test-r6rs" + docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=${DOCKER_TAG} -f Dockerfile.test . + docker run -p 3001:3001 -t ${DOCKER_TAG} sh -c "lighttpd -f fcgi-lighttpd.conf && make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes LIBRARY=${LIBRARY} test-r6rs" test-r7rs: ${TMPDIR} - cd ${TMPDIR} && echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (srfi 180) (retropikzel ${LIBRARY}))" > test-r7rs.scm + cd ${TMPDIR} && echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (retropikzel ${LIBRARY}))" > test-r7rs.scm cat ${TESTFILE} >> ${TMPDIR}/test-r7rs.scm cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} timeout 120 compile-scheme -I . -o test-r7rs test-r7rs.scm cd ${TMPDIR} && timeout 120 ./test-r7rs test-r7rs-docker: ${TMPDIR} echo "Building docker image..." - docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=${DOCKER_TAG} -f Dockerfile.test ${DOCKER_QUIET} . - docker run -t ${DOCKER_TAG} sh -c "make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes LIBRARY=${LIBRARY} build install test-r7rs" + docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=${DOCKER_TAG} -f Dockerfile.test . + docker run -p 3001:3001 -t ${DOCKER_TAG} sh -c "lighttpd -f fcgi-lighttpd.conf && make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes LIBRARY=${LIBRARY} build install test-r7rs" clean: git clean -X -f diff --git a/fcgi-lighttpd.conf b/fcgi-lighttpd.conf new file mode 100644 index 0000000..cf190ad --- /dev/null +++ b/fcgi-lighttpd.conf @@ -0,0 +1,17 @@ +server.document-root = "/workdir" +server.errorlog = "/tmp/scgi-error.log" +server.modules = ("mod_fastcgi") + +fastcgi.debug = 1 + +server.port = 3001 +fastcgi.server = ("/" => + (( "host" => "127.0.0.1", + "port" => 3002, + "check-local" => "disable"))) + +mimetype.assign = ( + ".html" => "text/html", + ".txt" => "text/plain", + ".jpg" => "image/jpeg", + ".png" => "image/png") diff --git a/foreign/c-bytevectors.sld b/foreign/c-bytevectors.sld new file mode 100644 index 0000000..5612e07 --- /dev/null +++ b/foreign/c-bytevectors.sld @@ -0,0 +1,1194 @@ +;;; 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. + +(define-library + (foreign c-bytevectors) + (cond-expand + (chezscheme + (import (rnrs base) + (rnrs control) + (only (rnrs r5rs) + remainder + quotient) + (only (rnrs bytevectors) native-endianness))) + (r6rs + (import (rnrs base) + (rnrs control) + (only (rnrs r5rs) + remainder + quotient) + (only (rnrs bytevectors) native-endianness))) + (else + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (scheme inexact)) + (begin + (define (native-endianness) + (cond-expand (little-endian 'little) + (else 'big)))))) + (export c-bytevectors-init + ;; TODO endianness + native-endianness + ;make-c-bytevector + ;c-bytevector->address + ;; 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-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 + ) + (begin + + (define make-c-bytevector #f) + (define c-bytevector-u8-set! #f) + (define c-bytevector-u8-ref #f) + (define c-type-size #f) + (define (c-bytevectors-init make u8-set! u8-ref size-of) + (set! make-c-bytevector make) + (set! c-bytevector-u8-set! u8-set!) + (set! c-bytevector-u8-ref u8-ref) + (set! c-type-size size-of)) + + ;;; 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)))) + + #;(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-uint-ref c-bytevector index endness size) + (cond ((equal? endness 'big) + (do ((i 0 (+ i 1)) + (result 0 (+ (* 256 result) + (c-bytevector-u8-ref c-bytevector (+ index i))))) + ((>= i size) + result))) + ((equal? endness '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) + (cond + ((equal? (native-endianness) 'little) + (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)) + (else + (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) + (cond + ((equal? (native-endianness) 'little) + (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)) + (else + (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) + (cond + ((equal? (native-endianness) 'little) + (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)) + (else + (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) + (cond + ((equal? (native-endianness) 'little) + (if (not (= 0 (remainder k 4))) + (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 + (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)))) + #;(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/foreign/c.rkt b/foreign/c.rkt new file mode 100644 index 0000000..143ade4 --- /dev/null +++ b/foreign/c.rkt @@ -0,0 +1,3 @@ +#lang r7rs +(import (except (scheme base) let let-values let*-values string-copy string-copy! string-for-each string-map string-fill! string->list)) +(include "c.sld") diff --git a/foreign/c.scm b/foreign/c.scm new file mode 100644 index 0000000..74c9c6e --- /dev/null +++ b/foreign/c.scm @@ -0,0 +1,861 @@ +;; (Heavily modified) Parts from (r6rs bytevectors) library begins +;;; 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. +;;; + +(define c-bytevector:single-maxexponent 255) +(define c-bytevector:single-bias (quotient 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 (quotient 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)) + +(define-syntax s8->u8 + (syntax-rules () + ((_ val0) + (let ((val val0)) + (if (negative? val) + (+ val 256) + val))))) + +(define-syntax u8->s8 + (syntax-rules () + ((_ octet0) + (let ((octet octet0)) + (if (> octet 127) + (- octet 256) + octet))))) + +(define-syntax unspecified + (syntax-rules () + ((_) (if #f #f)))) + +(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))) + +;;; 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 (quotient num 2)))) + ((and (< num q) (= biased 1)) + (values sign biased num)))))))))))) + +(define (c-bytevector-uint-set! c-bytevector index val size) + (cond + ((symbol=? (native-endianness) 'little) + (do ((i 0 (+ i 1)) + (val val (quotient val 256))) + ((>= i size) + (unspecified)) + (c-bytevector-u8-set! c-bytevector (+ index i) (quotient val 256)))) + ((symbol=? (native-endianness) 'big) + (do ((i (- size 1) (- i 1)) + (val val (quotient val 256))) + ((< i 0) + (unspecified)) + (c-bytevector-u8-set! c-bytevector (+ index i) (remainder val 256)))) + (else + (c-bytevector-uint-set! c-bytevector index val size)))) + +(define (c-bytevector-uint-ref c-bytevector index size) + (cond ((equal? (native-endianness) 'big) + (do ((i 0 (+ i 1)) + (result 0 (+ (* 256 result) + (c-bytevector-u8-ref c-bytevector (+ index i))))) + ((>= i size) + result))) + ((equal? (native-endianness) '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 size)))) + +(define (c-bytevector-sint-set! c-bytevector index val size) + (let ((uval (if (< val 0) + (+ val (expt 256 size)) + val))) + (c-bytevector-uint-set! c-bytevector index uval size))) + +(define (c-bytevector-sint-ref c-bytevector index size) + (let* ((high-byte (c-bytevector-u8-ref c-bytevector + (if (eq? (native-endianness) 'big) + index + (+ index size -1)))) + (uresult (c-bytevector-uint-ref c-bytevector index size))) + (if (> high-byte 127) + (- uresult (expt 256 size)) + uresult))) + +;;; 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)))))) + +(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))) + +(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) + (quotient biased-exponent 2))) + (c-bytevector-u8-set! c-bytevector (+ k 1) + (+ (* 128 (remainder biased-exponent 2)) + (quotient frac (* 256 256)))) + (c-bytevector-u8-set! c-bytevector (+ k 2) + (quotient + (remainder frac (* 256 256)) 256)) + (c-bytevector-u8-set! c-bytevector (+ k 3) + (remainder frac 256))) + (begin + (c-bytevector-u8-set! c-bytevector (+ k 3) + (+ (* 128 sign) + (quotient biased-exponent 2))) + (c-bytevector-u8-set! c-bytevector (+ k 2) + (+ (* 128 (remainder biased-exponent 2)) + (quotient frac (* 256 256)))) + (c-bytevector-u8-set! c-bytevector (+ k 1) + (quotient + (remainder frac (* 256 256)) 256)) + (c-bytevector-u8-set! c-bytevector k + (remainder 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-single-native-set! c-bytevector k x) + (cond + ((equal? (native-endianness) 'little) + (if (not (= 0 (remainder k 4))) + (error "c-bytevector-ieee-single-native-set!" (list c-bytevector k x))) + (c-bytevector-ieee-single-set! c-bytevector k x 'little)) + (else + (if (not (= 0 (remainder k 4))) + (error "c-bytevector-ieee-single-native-set!" (list c-bytevector k x))) + (c-bytevector-ieee-single-set! c-bytevector k x 'big)))) + +(define (c-bytevector-ieee-single-native-ref c-bytevector k) + (cond + ((equal? (native-endianness) 'little) + (if (not (= 0 (remainder k 4))) + (error "c-bytevector-ieee-single-native-ref" (list c-bytevector k))) + (c-bytevector-ieee-single-little-endian-ref c-bytevector k)) + (else + (if (not (= 0 (remainder k 4))) + (error "c-bytevector-ieee-single-native-ref" (list c-bytevector k))) + (c-bytevector-ieee-single-big-endian-ref c-bytevector k)))) + + +;;; 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)))))) + +(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) + (quotient biased-exponent 16))) + (c-bytevector-u8-set! c-bytevector (+ k 6) + (+ (* 16 (remainder biased-exponent 16)) + (quotient frac two^48))) + (c-bytevector-u8-set! c-bytevector (+ k 5) + (quotient (remainder frac two^48) two^40)) + (c-bytevector-u8-set! c-bytevector (+ k 4) + (quotient (remainder frac two^40) two^32)) + (c-bytevector-u8-set! c-bytevector (+ k 3) + (quotient (remainder frac two^32) two^24)) + (c-bytevector-u8-set! c-bytevector (+ k 2) + (quotient (remainder frac two^24) two^16)) + (c-bytevector-u8-set! c-bytevector (+ k 1) + (quotient (remainder frac two^16) 256)) + (c-bytevector-u8-set! c-bytevector k (remainder 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))))))) + +(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))) + +(define (c-bytevector-ieee-double-native-set! c-bytevector k x) + (cond + ((equal? (native-endianness) 'little) + (if (not (= 0 (remainder k 4))) + (if (not (= 0 (remainder k 8))) + (error "c-bytevector-ieee-double-native-set!" (list c-bytevector k x))) + (c-bytevector-ieee-double-set! c-bytevector k x 'little))) + (else + (if (not (= 0 (remainder k 8))) + (error "c-bytevector-ieee-double-native-set!" (list c-bytevector k x))) + (c-bytevector-ieee-double-set! c-bytevector k x 'big)))) + +(define (c-bytevector-ieee-double-native-ref c-bytevector k) + (cond + ((equal? (native-endianness) 'little) + (if (not (= 0 (remainder k 8))) + (error "c-bytevector-ieee-double-native-ref" (list c-bytevector k))) + (c-bytevector-ieee-double-little-endian-ref c-bytevector k)) + (else + (if (not (= 0 (remainder k 8))) + (error "c-bytevector-ieee-double-native-ref" (list c-bytevector k))) + (c-bytevector-ieee-double-big-endian-ref c-bytevector k)))) + +;; Parts from (r6rs bytevectors) library ends + +(define (c-type-size type) + (cond ((not (symbol? type)) (error "c-type-size: Type must be symbol" type)) + ((symbol=? type 'void) 0) + ((or (symbol=? type 'i8) + (symbol=? type 'u8) + (symbol=? type 'i16) + (symbol=? type 'u16) + (symbol=? type 'i32) + (symbol=? type 'u32) + (symbol=? type 'i64) + (symbol=? type 'u64) + (symbol=? type 'char) + (symbol=? type 'uchar) + (symbol=? type 'short) + (symbol=? type 'ushort) + (symbol=? type 'int) + (symbol=? type 'uint) + (symbol=? type 'long) + (symbol=? type 'ulong) + (symbol=? type 'float) + (symbol=? type 'double) + (symbol=? type 'pointer)) + (size-of-type type)) + (else (error "Unknown type" type)))) + +(define (c-type-align type) + (cond ((not (symbol? type)) (error "c-type-align: Type must be symbol" type)) + ((symbol=? type 'void) 0) + ((or (symbol=? type 'i8) + (symbol=? type 'u8) + (symbol=? type 'i16) + (symbol=? type 'u16) + (symbol=? type 'i32) + (symbol=? type 'u32) + (symbol=? type 'i64) + (symbol=? type 'u64) + (symbol=? type 'char) + (symbol=? type 'uchar) + (symbol=? type 'short) + (symbol=? type 'ushort) + (symbol=? type 'int) + (symbol=? type 'uint) + (symbol=? type 'long) + (symbol=? type 'ulong) + (symbol=? type 'float) + (symbol=? type 'double) + (symbol=? type 'pointer)) + (align-of-type type)) + (else (error "Unknown type" type)))) + +(define (make-c-bytevector size . byte) + (when (not (integer? size)) + (error "make-c-bytevector: Size must be integer" size)) + (let ((cbv (cond ((null? byte) (c-malloc size)) + ((= (car byte) 0) (c-calloc 1 size)) + (else (bytevector->c-bytevector (make-bytevector size (car byte))))))) + (when (c-null? cbv) + (c-perror (string->c-utf8 "make-c-bytevector error")) + (error "make-c-bytevector error: malloc returned null" size)) + cbv)) + +(define c-bytevector + (lambda bytes + (bytevector->c-bytevector + (apply (lambda (b) (make-bytevector 1 b)) bytes)))) + +(define (c-bytevector-set! cbv type offset value) + (when (not (c-bytevector? cbv)) + (error "c-bytevector-set!: cbv argument must be c-bytevector" cbv)) + (when (not (symbol? type)) + (error "c-bytevector-set!: type must be symbol" type)) + (when (not (integer? offset)) + (error "c-bytevector-set!: offset argument must be integer" offset)) + (cond ((not (symbol? type)) (error "c-bytevector-set!: type must be symbol" type)) + ((symbol=? type 'i8) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-s8-set! cbv offset value)) + ((symbol=? type 'u8) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-u8-set! cbv offset value)) + ((symbol=? type 'i16) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-sint-set! cbv offset value 2)) + ((symbol=? type 'u16) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-uint-set! cbv offset value 2)) + ((symbol=? type 'i32) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-sint-set! cbv offset value 4)) + ((symbol=? type 'u32) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-uint-set! cbv offset value 4)) + ((symbol=? type 'i64) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-sint-set! cbv offset value 8)) + ((symbol=? type 'u64) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-uint-set! cbv offset value 8)) + ((symbol=? type 'char) + (when (not (char? value)) + (error "c-bytevector-set!: value for given type must be char" + `((type ,type) + (value ,value)))) + (c-bytevector-s8-set! cbv offset (char->integer value))) + ((symbol=? type 'uchar) + (when (not (char? value)) + (error "c-bytevector-set!: value for given type must be char" + `((type ,type) + (value ,value)))) + (c-bytevector-u8-set! cbv offset (char->integer value))) + ((symbol=? type 'short) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-sint-set! cbv offset value (c-type-size 'short))) + ((symbol=? type 'ushort) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-sint-set! cbv offset value (c-type-size 'ushort))) + ((symbol=? type 'int) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-sint-set! cbv offset value (c-type-size 'int))) + ((symbol=? type 'uint) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-sint-set! cbv offset value (c-type-size 'uint))) + ((symbol=? type 'long) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-sint-set! cbv offset value (c-type-size 'long))) + ((symbol=? type 'ulong) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-sint-set! cbv offset value (c-type-size 'ulong))) + ((symbol=? type 'float) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-ieee-single-native-set! cbv offset value)) + ((symbol=? type 'double) + (when (not (number? value)) + (error "c-bytevector-set!: value for given type must be number" + `((type ,type) + (value ,value)))) + (c-bytevector-ieee-double-native-set! cbv offset value)) + ((symbol=? type 'pointer) + (when (not (c-bytevector? value)) + (error "c-bytevector-set!: value for given type must be pointer" + `((type ,type) + (value ,value)))) + (c-bytevector-pointer-set! cbv offset value)) + (else (error "c-bytevector-set!: Unknown type" type)))) + +(define (c-bytevector-ref cbv type offset) + (when (not (c-bytevector? cbv)) + (error "c-bytevector-ref: cbv argument must be c-bytevector" cbv)) + (when (not (symbol? type)) + (error "c-bytevector-ref: type must be symbol" type)) + (when (not (integer? offset)) + (error "c-bytevector-ref: offset argument must be integer" offset)) + (cond ((symbol=? type 'i8) (c-bytevector-s8-ref cbv offset)) + ((symbol=? type 'u8) (c-bytevector-u8-ref cbv offset)) + ((symbol=? type 'i16) (c-bytevector-sint-ref cbv offset 2)) + ((symbol=? type 'u16) (c-bytevector-uint-ref cbv offset 2)) + ((symbol=? type 'i32) (c-bytevector-sint-ref cbv offset 4)) + ((symbol=? type 'u32) (c-bytevector-uint-ref cbv offset 4)) + ((symbol=? type 'i64) (c-bytevector-sint-ref cbv offset 8)) + ((symbol=? type 'u64) (c-bytevector-uint-ref cbv offset 8)) + ((symbol=? type 'char) (integer->char (c-bytevector-s8-ref cbv offset))) + ((symbol=? type 'uchar) (integer->char (c-bytevector-u8-ref cbv offset))) + ((symbol=? type 'short) (c-bytevector-sint-ref cbv offset (c-type-size 'short))) + ((symbol=? type 'ushort) (c-bytevector-uint-ref cbv offset (c-type-size 'ushort))) + ((symbol=? type 'int) (c-bytevector-sint-ref cbv offset (c-type-size 'int))) + ((symbol=? type 'uint) (c-bytevector-uint-ref cbv offset (c-type-size 'uint))) + ((symbol=? type 'long) (c-bytevector-sint-ref cbv offset (c-type-size 'long))) + ((symbol=? type 'ulong) (c-bytevector-uint-ref cbv offset (c-type-size 'ulong))) + ((symbol=? type 'float) (c-bytevector-ieee-single-native-ref cbv offset)) + ((symbol=? type 'double) (c-bytevector-ieee-double-native-ref cbv offset)) + ((equal? type 'pointer) (c-bytevector-pointer-ref cbv offset)) + (else (error "c-bytevector-ref: Unknown type" type)))) + +(define (bytevector->c-bytevector bv) + (when (not (bytevector? bv)) + (error "bytevector->c-bytevector: bv argument must be bytevector" bv)) + (letrec* ((bytes-length (bytevector-length bv)) + (pointer (make-c-bytevector bytes-length)) + (looper (lambda (index) + (when (< index bytes-length) + (c-bytevector-u8-set! pointer + index + (bytevector-u8-ref bv index)) + (looper (+ index 1)))))) + (looper 0) + pointer)) + +(define (c-bytevector->bytevector cbv size) + (when (not (c-bytevector? cbv)) + (error "c-bytevector->bytevector: cbv argument must be c-bytevector" cbv)) + (when (not (integer? size)) + (error "c-bytevector->bytevector: size argument must be integer" size)) + (letrec* ((bv (make-bytevector size)) + (looper (lambda (index) + (let ((byte (c-bytevector-u8-ref cbv index))) + (if (= index size) + bv + (begin + (bytevector-u8-set! bv index byte) + (looper (+ index 1)))))))) + (looper 0))) + +(define (c-utf8->string cbv) + (when (not (c-bytevector? cbv)) + (error "c-utf8->string: cbv argument must be c-bytevector" cbv)) + (let ((size (c-strlen cbv))) + (utf8->string (c-bytevector->bytevector cbv size)))) + +(define (string->c-utf8 str) + (when (not (string? str)) + (error "string->c-utf8-: str argument must be string" str)) + (bytevector->c-bytevector + (string->utf8 + (string-append str (string (integer->char 0)))))) + +(define (c-bytevector->integer cbv . offset) + (when (not (c-bytevector? cbv)) + (error "c-bytevector->integer cbv argument must be c-bytevector" cbv)) + (let ((internal-offset (if (null? offset) 0 (car offset)))) + (when (not (integer? internal-offset)) + (error "c-bytevector->integer offset argument must be integer" (car offset))) + (+ (c-memset-pointer->address cbv 0 0) internal-offset))) + +(define (integer->c-bytevector address) + (when (not (integer? address)) + (error "c-bytevector->string: address argument must be integer" address)) + (c-memset-address->pointer address 0 0)) + +(define-syntax call-with-address-of + (syntax-rules () + ((_ cbv thunk) + (let ((address-cbv (make-c-bytevector (c-type-size 'pointer)))) + (c-bytevector-pointer-set! address-cbv 0 cbv) + (when (not (c-bytevector? cbv)) + (error "call-with-address-of: cbv argument must be c-bytevector")) + (when (not (procedure? thunk)) + (error "call-with-address-of: thunk argument must be procedure")) + (let ((result (apply thunk (list address-cbv)))) + (set! cbv (c-bytevector-pointer-ref address-cbv 0)) + (c-free address-cbv) + result))))) + +(define (round-to-next-modulo-of to-round roundee) + (if (= (modulo to-round roundee) 0) + to-round + (round-to-next-modulo-of (+ to-round 1) roundee))) + +(define (calculate-struct-members members . return-just-size) + (let* + ((size 0) + (largest-member-size 0) + (data (map (lambda (member) + (let* ((name (list-ref member 0)) + (type (list-ref member 1)) + (accessor (list-ref member 2)) + (type-alignment (c-type-align 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) accessor)) + (let ((next-alignment + (round-to-next-modulo-of size type-alignment))) + (set! size (+ next-alignment type-alignment)) + (list name type next-alignment accessor))))) + members))) + (if (null? return-just-size) + data + size))) + +(define calculate-struct-size + (lambda (members) + (calculate-struct-members members #t))) + +(define-syntax define-c-struct + (syntax-rules () + ((_ name members struct-size-variable struct-cbv (field-name field-type accessor modifier) ...) + (begin + (when (not (or (equal? struct-cbv #f) + (c-bytevector? struct-cbv))) + (error "define-c-struct: struct-cbv argument must be c-bytevector or #f")) + (define accessor + (lambda (cbv) + (let ((offset (let ((offset 0) + (before? #t)) + (for-each + (lambda (member) + (when (equal? (list-ref member 0) 'field-name) + (set! before? #f)) + (when before? + (set! offset + (+ offset + (c-type-align (list-ref member 1)))))) + members) + offset))) + (c-bytevector-ref cbv field-type offset)))) + ... + (define modifier + (lambda (cbv value) + (let ((offset (let ((offset 0) + (before? #t)) + (for-each + (lambda (member) + (when (equal? (list-ref member 0) 'field-name) + (set! before? #f)) + (when before? + (set! offset + (+ offset + (c-type-align (list-ref member 1)))))) + members) + offset))) + (c-bytevector-set! cbv field-type offset value)))) + ... + (define members (calculate-struct-members + (list (list 'field-name field-type accessor) ...))) + (define struct-size-variable (calculate-struct-size + (list (list 'field-name field-type accessor) ...))) + (define name + (if (not struct-cbv) + (make-c-bytevector (+ (c-type-size field-type) ...) 0) + struct-cbv)))))) + +(cond-expand + (capyscheme (primitives-init c-bytevector-set! c-bytevector-ref)) + (chibi (primitives-init c-bytevector-set! c-bytevector-ref)) + (else)) diff --git a/foreign/c.sld b/foreign/c.sld new file mode 100644 index 0000000..22850a8 --- /dev/null +++ b/foreign/c.sld @@ -0,0 +1,137 @@ +(define-library + (foreign c) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (scheme inexact)) + (cond-expand + (capyscheme (import (foreign c capyscheme-primitives))) + (chezscheme (import (foreign c chezscheme-primitives)) + (export foreign-procedure)) + (chibi (import (foreign c chibi-primitives))) + (chicken (import (foreign c chicken-primitives) + (chicken base) + (chicken foreign)) + (export foreign-declare + foreign-safe-lambda + foreign-value)) + ;(cyclone (import (foreign c cyclone-primitives))) + ;(gambit (import (foreign c gambit-primitives))) + (gauche (import (foreign c gauche-primitives))) + (guile (import (foreign c guile-primitives))) + (ikarus (import (foreign c ikarus-primitives))) + (ironscheme (import (foreign c ironscheme-primitives))) + (kawa (import (foreign c kawa-primitives))) + ;(mit-scheme (import (foreign c mit-scheme-primitives))) + ;(larceny (import (foreign c larceny-primitives))) + (mosh (import (foreign c mosh-primitives))) + (racket (import (foreign c racket-primitives))) + (sagittarius (import (foreign c sagittarius-primitives))) + (stklos (import (foreign c stklos-primitives)) + (export make-external-function + free-bytes + file-exists? + c-bytevector-pointer-set! + c-bytevector-pointer-ref)) + (ypsilon (import (foreign c ypsilon-primitives)) + (export c-function + bytevector-c-int8-set! + bytevector-c-uint8-ref))) + (export + ;; Types + c-type-size + c-type-align + + ;; Libraries and procedures + define-c-library + define-c-procedure + ;define-c-callback ;; TODO + + ;; c-bytevectors + make-c-bytevector + c-bytevector + c-bytevector? + c-free + make-c-null + c-null? + c-bytevector-set! + c-bytevector-ref + bytevector->c-bytevector + c-bytevector->bytevector + c-bytevector->integer + integer->c-bytevector + + ;; Strings + string->c-utf8 + c-utf8->string + + ;; Pass pointer by address + call-with-address-of + + ;; Structs + define-c-struct + + ;; Utilities + libc-name + + ;; endianness + native-endianness) + (cond-expand + (chezscheme + (import (only (rnrs bytevectors) native-endianness))) + (r6rs + (import (only (rnrs bytevectors) native-endianness))) + (guile + (import (only (rnrs bytevectors) native-endianness))) + (else + (begin + (define (native-endianness) + (cond-expand (big-endian 'big) (else 'little)))))) + (cond-expand + (chicken + (begin + (define-syntax define-c-library + (syntax-rules () + ((_ scheme-name headers object-name options) + (begin + (define scheme-name #t) + (shared-object-load headers))))))) + (else (include "c/define-c-library.scm"))) + (cond-expand + (chicken + (begin + (define libc-name + (cond-expand + (windows "ucrtbase") + (haiku "root") + (else "c"))) + (define-c-library libc + '("stdlib.h" "stdio.h" "string.h") + libc-name + '((additional-versions ("0" "6")))) + + (define-c-procedure c-malloc libc 'malloc 'pointer '(int)) + (define-c-procedure c-free libc 'free 'void '(pointer)) + (define-c-procedure c-strlen libc 'strlen 'int '(pointer)) + (define-c-procedure c-calloc libc 'calloc 'pointer '(int int)) + (define-c-procedure c-perror libc 'perror 'void '(pointer)) + (define (c-memset-address->pointer address value offset) (address->pointer address)) + (define (c-memset-pointer->address pointer value offset) (pointer->address pointer)))) + (else (include "c/libc.scm"))) + (cond-expand + (chicken + ;; FIXME These are in primitives too but error + (begin + (define (make-c-null) (foreign-value "NULL" c-pointer)) + (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))))))) + (else)) + (include "c.scm")) + diff --git a/foreign/c/array.scm b/foreign/c/array.scm new file mode 100644 index 0000000..ce36a5d --- /dev/null +++ b/foreign/c/array.scm @@ -0,0 +1,59 @@ +(define make-c-array + (lambda (type size . fill) + (let ((array (make-c-bytevector (* (c-type-size type) size)))) + (when (not (null? fill)) + (letrec* ((filler (car fill)) + (looper (lambda (count) + (when (> size count) + (c-array-set! array type count filler) + (looper (+ count 1)))))) + (looper 0))) + array))) + +(define c-array-ref + (lambda (array type index) + (let* ((size (c-type-size type)) + (offset (* index size))) + (cond + ((equal? 'pointer type) + (c-bytevector-pointer-ref array offset)) + ((c-type-signed? type) + (c-bytevector-sint-ref array offset (native-endianness) size)) + (else + (c-bytevector-uint-ref array offset (native-endianness) size)))))) + +(define c-array-set! + (lambda (array type index value) + (let* ((size (c-type-size type)) + (offset (* index size))) + (cond + ((equal? 'pointer type) + (c-bytevector-pointer-set! array offset value)) + ((c-type-signed? type) + (c-bytevector-sint-set! array offset value (native-endianness) size)) + (else + (c-bytevector-uint-set! array offset value (native-endianness) size)))))) + +(define list->c-array + (lambda (list type) + (let* ((array-size (length list)) + (type-size (c-type-size type)) + (array (make-c-bytevector (* type-size array-size))) + (index 0)) + (for-each + (lambda (item) + (c-array-set! array type index item) + (set! index (+ index 1))) + list) + array))) + +(define c-array->list + (lambda (array type size) + (letrec* + ((looper (lambda (index result) + (if (>= index size) + result + (looper (+ index 1) + (append result + (list (c-array-ref array type index)))))))) + (looper 0 (list))))) diff --git a/foreign/c/array.sld b/foreign/c/array.sld new file mode 100644 index 0000000..48b546d --- /dev/null +++ b/foreign/c/array.sld @@ -0,0 +1,14 @@ +(define-library + (foreign c array) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context)) + (export make-c-array + c-array-ref + c-array-set! + list->c-array + c-array->list) + (include "array.scm")) diff --git a/foreign/c/bytevectors.scm b/foreign/c/bytevectors.scm new file mode 100644 index 0000000..e69de29 diff --git a/foreign/c/capyscheme-primitives.scm b/foreign/c/capyscheme-primitives.scm new file mode 100644 index 0000000..b013ac8 --- /dev/null +++ b/foreign/c/capyscheme-primitives.scm @@ -0,0 +1,101 @@ +(define c-bytevector-set! #f) +(define c-bytevector-ref #f) +(define (primitives-init set-procedure get-procedure) + (set! c-bytevector-set! set-procedure) + (set! c-bytevector-ref get-procedure)) + +(define os 'unix) +(define implementation 'guile) +(define arch 'x86_64) +(define libc-name "c") + +(define type->native-type + (lambda (type) + (cond ((equal? type 'i8) int8) + ((equal? type 'u8) uint8) + ((equal? type 'i16) int16) + ((equal? type 'u16) uint16) + ((equal? type 'i32) int32) + ((equal? type 'u32) uint32) + ((equal? type 'i64) int64) + ((equal? type 'u64) uint64) + ((equal? type 'char) int8) + ((equal? type 'uchar) uint8) + ((equal? type 'short) short) + ((equal? type 'ushort) unsigned-short) + ((equal? type 'int) int) + ((equal? type 'uint) unsigned-int) + ((equal? type 'long) long) + ((equal? type 'ulong) unsigned-long) + ((equal? type 'float) float) + ((equal? type 'double) double) + ((equal? type 'pointer) '*) + ((equal? type 'void) void) + ((equal? type 'callback) '*) + (else #f)))) + +(define c-bytevector? + (lambda (object) + (pointer? object))) + +(define-syntax define-c-procedure + (syntax-rules () + ((_ scheme-name shared-object c-name return-type argument-types) + (define scheme-name + (pointer->procedure (type->native-type return-type) + (foreign-library-pointer shared-object + (symbol->string 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 + (procedure->pointer (type->native-type return-type) + procedure + (map type->native-type argument-types)))))) + +(define size-of-type + (lambda (type) + (let ((native-type (type->native-type type))) + (cond ((equal? native-type void) 0) + (native-type (sizeof native-type)) + (else #f))))) + +(define align-of-type + (lambda (type) + (let ((native-type (type->native-type type))) + (cond ((equal? native-type void) 0) + (native-type (alignof native-type)) + (else #f))))) + +(define shared-object-load + (lambda (path options) + (display "HERE: ") + (write path) + (newline) + (load-foreign-library `(filename ,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 (cbv offset pointer) + (c-bytevector-set! cbv 'uint offset pointer))) + +(define c-bytevector-pointer-ref + (lambda (cbv offset) + (make-pointer (c-bytevector-ref cbv 'uint offset)))) + +(define (make-c-null) (make-pointer (pointer-address %null-pointer))) + +(define (c-null? pointer) + (and (pointer? pointer) + (null-pointer? pointer))) diff --git a/foreign/c/capyscheme-primitives.sld b/foreign/c/capyscheme-primitives.sld new file mode 100644 index 0000000..5a494b0 --- /dev/null +++ b/foreign/c/capyscheme-primitives.sld @@ -0,0 +1,23 @@ +(define-library + (foreign c capyscheme-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (core foreign) + (core foreign-library)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + ;define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null + c-null?) + (include "capyscheme-primitives.scm")) diff --git a/foreign/c/chezscheme-primitives.scm b/foreign/c/chezscheme-primitives.scm new file mode 100644 index 0000000..73dd4e9 --- /dev/null +++ b/foreign/c/chezscheme-primitives.scm @@ -0,0 +1,187 @@ +(define-syntax type->native-type + (syntax-rules () + ((_ type) + (cond ((equal? type 'i8) 'integer-8) + ((equal? type 'u8) 'unsigned-8) + ((equal? type 'i16) 'integer-16) + ((equal? type 'u16) 'unsigned-16) + ((equal? type 'i32) 'integer-32) + ((equal? type 'u32) 'unsigned-32) + ((equal? type 'i64) 'integer-64) + ((equal? type 'u64) 'unsigned-64) + ((equal? type 'char) 'char) + ((equal? type 'uchar) 'unsigned-8) + ((equal? type 'short) 'short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'uint) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'ulong) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'void*) + ((equal? type 'void) 'void))))) + +(define c-bytevector? + (lambda (object) + (or (number? object) + (ftype-pointer? object)))) + +(define-syntax define-macro! + (lambda (x) + (syntax-case x () + [(k (name arg1 ... . args) + form1 + form2 + ...) + #'(k name (arg1 ... . args) + form1 + form2 + ...)] + [(k (name arg1 arg2 ...) + form1 + form2 + ...) + #'(k name (arg1 arg2 ...) + form1 + form2 + ...)] + [(k name args . forms) + (identifier? #'name) + (letrec ((add-car + (lambda (access) + (case (car access) + ((cdr) `(cadr ,@(cdr access))) + ((cadr) `(caadr ,@(cdr access))) + ((cddr) `(caddr ,@(cdr access))) + ((cdddr) `(cadddr ,@(cdr access))) + (else `(car ,access))))) + (add-cdr + (lambda (access) + (case (car access) + ((cdr) `(cddr ,@(cdr access))) + ((cadr) `(cdadr ,@(cdr access))) + ((cddr) `(cdddr ,@(cdr access))) + ((cdddr) `(cddddr ,@(cdr access))) + (else `(cdr ,access))))) + (parse + (lambda (l access) + (cond + ((null? l) '()) + ((symbol? l) `((,l ,access))) + ((pair? l) + (append! + (parse (car l) (add-car access)) + (parse (cdr l) (add-cdr access)))) + (else + (syntax-error #'args + (format "invalid ~s parameter syntax" (datum k)))))))) + (with-syntax ((proc (datum->syntax-object #'k + (let ((g (gensym))) + `(lambda (,g) + (let ,(parse (datum args) `(cdr ,g)) + ,@(datum forms))))))) + #'(define-syntax name + (lambda (x) + (syntax-case x () + ((k1 . r) + (datum->syntax-object #'k1 + (proc (syntax-object->datum x)))))))))]))) + +(define-macro! + define-c-procedure + (scheme-name shared-object c-name return-type argument-types) + (let ((native-argument-types + (map (lambda (type) + ;; This is defined in 3 places + (cond ((equal? type 'i8) 'integer-8) + ((equal? type 'u8) 'unsigned-8) + ((equal? type 'i16) 'integer-16) + ((equal? type 'u16) 'unsigned-16) + ((equal? type 'i32) 'integer-32) + ((equal? type 'u32) 'unsigned-32) + ((equal? type 'i64) 'integer-64) + ((equal? type 'u64) 'unsigned-64) + ((equal? type 'char) 'char) + ((equal? type 'uhar) 'unsigned-8) + ((equal? type 'short) 'short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'uint) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'ulong) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'void*) + ((equal? type 'void) 'void) + (else type))) + (if (null? argument-types) + '() + (cadr argument-types)))) + (native-return-type + ;; This is defined in 3 places + (cond ((equal? return-type ''i8) 'integer-8) + ((equal? return-type ''u8) 'unsigned-8) + ((equal? return-type ''i16) 'integer-16) + ((equal? return-type ''u16) 'unsigned-16) + ((equal? return-type ''i32) 'integer-32) + ((equal? return-type ''u32) 'unsigned-32) + ((equal? return-type ''i64) 'integer-64) + ((equal? return-type ''u64) 'unsigned-64) + ((equal? return-type ''char) 'char) + ((equal? return-type ''uhar) 'unsigned-8) + ((equal? return-type ''short) 'short) + ((equal? return-type ''ushort) 'unsigned-short) + ((equal? return-type ''int) 'int) + ((equal? return-type ''uint) 'unsigned-int) + ((equal? return-type ''long) 'long) + ((equal? return-type ''ulong) 'unsigned-long) + ((equal? return-type ''float) 'float) + ((equal? return-type ''double) 'double) + ((equal? return-type ''pointer) 'void*) + ((equal? return-type ''void) 'void) + (else return-type)))) + (if (null? argument-types) + `(define ,scheme-name + (foreign-procedure #f + ,(symbol->string (cadr c-name)) + () + ,native-return-type)) + `(define ,scheme-name + (foreign-procedure #f + ,(symbol->string (cadr c-name)) + ,native-argument-types + ,native-return-type))))) + +(define size-of-type + (lambda (type) + (foreign-sizeof (type->native-type type)))) + +(define align-of-type + (lambda (type) + (foreign-alignof (type->native-type type)))) + +(define shared-object-load + (lambda (path options) + (load-shared-object path))) + +(define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + (foreign-set! 'unsigned-8 c-bytevector k byte))) + +(define c-bytevector-u8-ref + (lambda (c-bytevector k) + (foreign-ref 'unsigned-8 c-bytevector k))) + +(define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (foreign-set! 'void* c-bytevector k pointer))) + +(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (foreign-ref 'void* c-bytevector k))) + +(define (make-c-null) (make-ftype-pointer void* 0)) +(define (c-null? pointer) + (and (ftype-pointer? pointer) + (ftype-pointer-null? pointer))) diff --git a/foreign/c/chezscheme-primitives.sld b/foreign/c/chezscheme-primitives.sld new file mode 100644 index 0000000..4275448 --- /dev/null +++ b/foreign/c/chezscheme-primitives.sld @@ -0,0 +1,18 @@ +(define-library + (foreign c chezscheme-primitives) + (import (chezscheme)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + ;; Chez specific + foreign-procedure + type->native-type + make-c-null + c-null?) + (include "chezscheme-primitives.scm")) diff --git a/foreign/c/chibi-primitives.c b/foreign/c/chibi-primitives.c new file mode 100644 index 0000000..ccdba9a --- /dev/null +++ b/foreign/c/chibi-primitives.c @@ -0,0 +1,854 @@ +/* Automatically generated by chibi-ffi; version: 0.5 */ + +#include + +#include + +#include + +#include + +#include +void* make_c_null() { return NULL; } +sexp is_null(void* pointer) { if(pointer == NULL) { return SEXP_TRUE; } else { return SEXP_FALSE; } } + + int size_of_int8_t() { return sizeof(int8_t); } + int size_of_uint8_t() { return sizeof(uint8_t); } + int size_of_int16_t() { return sizeof(int16_t); } + int size_of_uint16_t() { return sizeof(uint16_t); } + int size_of_int32_t() { return sizeof(int32_t); } + int size_of_uint32_t() { return sizeof(uint32_t); } + int size_of_int64_t() { return sizeof(int64_t); } + int size_of_uint64_t() { return sizeof(uint64_t); } + int size_of_char() { return sizeof(char); } + int size_of_unsigned_char() { return sizeof(unsigned char); } + int size_of_short() { return sizeof(short); } + int size_of_unsigned_short() { return sizeof(unsigned short); } + int size_of_int() { return sizeof(int); } + int size_of_unsigned_int() { return sizeof(unsigned int); } + int size_of_long() { return sizeof(long); } + int size_of_unsigned_long() { return sizeof(unsigned long); } + int size_of_float() { return sizeof(float); } + int size_of_double() { return sizeof(double); } + int size_of_pointer() { return sizeof(void*); } + + + int align_of_int8_t() { return _Alignof(int8_t); } + int align_of_uint8_t() { return _Alignof(uint8_t); } + int align_of_int16_t() { return _Alignof(int16_t); } + int align_of_uint16_t() { return _Alignof(uint16_t); } + int align_of_int32_t() { return _Alignof(int32_t); } + int align_of_uint32_t() { return _Alignof(uint32_t); } + int align_of_int64_t() { return _Alignof(int64_t); } + int align_of_uint64_t() { return _Alignof(uint64_t); } + int align_of_char() { return _Alignof(char); } + int align_of_unsigned_char() { return _Alignof(unsigned char); } + int align_of_short() { return _Alignof(short); } + int align_of_unsigned_short() { return _Alignof(unsigned short); } + int align_of_int() { return _Alignof(int); } + int align_of_unsigned_int() { return _Alignof(unsigned int); } + int align_of_long() { return _Alignof(long); } + int align_of_unsigned_long() { return _Alignof(unsigned long); } + int align_of_float() { return _Alignof(float); } + int align_of_double() { return _Alignof(double); } + int align_of_pointer() { return _Alignof(void*); } + +sexp is_pointer(struct sexp_struct* object) { if(sexp_cpointerp(object)) { return SEXP_TRUE; } else { return SEXP_FALSE; } } +void c_bytevector_u8_set(void* pointer, int offset, uint8_t value) { *(uint8_t*)((uint8_t*)pointer + offset) = value; } +uint8_t c_bytevector_u8_ref (void* pointer, int offset) { return *(uint8_t*)((uint8_t*)pointer + offset); } +void c_bytevector_pointer_set (void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; } +void* c_bytevector_pointer_ref (void* pointer, int offset) { char* p = (char*)pointer + offset; return (void*)*(char**)p;} +ffi_cif cif; +void* internal_ffi_call( + unsigned int nargs, + unsigned int rtype, + unsigned int atypes[], + void* fn, + unsigned int rvalue_size, + struct sexp_struct* avalues[]) + { + ffi_type* c_atypes[nargs]; + void* c_avalues[nargs]; + + int8_t vals1[nargs]; + uint8_t vals2[nargs]; + int16_t vals3[nargs]; + uint16_t vals4[nargs]; + int32_t vals5[nargs]; + uint32_t vals6[nargs]; + int64_t vals7[nargs]; + uint64_t vals8[nargs]; + char vals9[nargs]; + unsigned char vals10[nargs]; + short vals11[nargs]; + unsigned short vals12[nargs]; + int vals13[nargs]; + unsigned int vals14[nargs]; + long vals15[nargs]; + unsigned long vals16[nargs]; + float vals17[nargs]; + double vals18[nargs]; + void* vals20[nargs]; + + //printf("nargs: %i\n", nargs); + for(int i = 0; i < nargs; i++) { + //printf("i: %i\n", i); + void* arg = NULL; + switch(atypes[i]) { + case 1: + c_atypes[i] = &ffi_type_sint8; + vals1[i] = (int8_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals1[i]; + break; + case 2: + c_atypes[i] = &ffi_type_uint8; + vals2[i] = (uint8_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals2[i]; + break; + case 3: + c_atypes[i] = &ffi_type_sint16; + vals3[i] = (int16_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals3[i]; + break; + case 4: + c_atypes[i] = &ffi_type_uint16; + vals4[i] = (uint16_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals4[i]; + break; + case 5: + c_atypes[i] = &ffi_type_sint32; + vals5[i] = (int32_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals5[i]; + break; + case 6: + c_atypes[i] = &ffi_type_uint32; + vals6[i] = (uint32_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals6[i]; + break; + case 7: + c_atypes[i] = &ffi_type_sint64; + vals7[i] = (int64_t) sexp_sint_value(avalues[i]); + c_avalues[i] = &vals7[i]; + break; + case 8: + c_atypes[i] = &ffi_type_uint64; + vals8[i] = (uint64_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals8[i]; + break; + case 9: + c_atypes[i] = &ffi_type_schar; + vals9[i] = (char)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals9[i]; + break; + case 10: + c_atypes[i] = &ffi_type_uchar; + vals10[i] = (unsigned char)sexp_uint_value(avalues[i]); + break; + case 11: + c_atypes[i] = &ffi_type_sshort; + vals11[i] = (short)sexp_sint_value(avalues[i]); + break; + case 12: + c_atypes[i] = &ffi_type_ushort; + vals12[i] = (unsigned short)sexp_uint_value(avalues[i]); + break; + case 13: + c_atypes[i] = &ffi_type_sint; + vals13[i] = (int)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals13[i]; + break; + case 14: + c_atypes[i] = &ffi_type_uint; + vals14[i] = (unsigned int)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals14[i]; + break; + case 15: + c_atypes[i] = &ffi_type_slong; + vals15[i] = (long)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals15[i]; + break; + case 16: + c_atypes[i] = &ffi_type_ulong; + vals16[i] = (unsigned long)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals16[i]; + break; + case 17: + c_atypes[i] = &ffi_type_float; + vals17[i] = (float)sexp_flonum_value(avalues[i]); + c_avalues[i] = &vals17[i]; + break; + case 18: + c_atypes[i] = &ffi_type_double; + vals18[i] = (double)sexp_flonum_value(avalues[i]); + c_avalues[i] = &vals18[i]; + break; + case 19: + c_atypes[i] = &ffi_type_void; + arg = NULL; + c_avalues[i] = NULL; + break; + case 20: + c_atypes[i] = &ffi_type_pointer; + if(sexp_cpointerp(avalues[i])) { + vals20[i] = sexp_cpointer_value(avalues[i]); + } else { + vals20[i] = NULL; + } + c_avalues[i] = &vals20[i]; + break; + default: + printf("Undefined argument type integer: %i, index: %i\n", atypes[i], i); + //c_avalues[i] = sexp_cpointer_value(avalues[i]); + break; + } + } + + ffi_type* c_rtype = &ffi_type_void; + switch(rtype) { + case 1: c_rtype = &ffi_type_sint8; break; + case 2: c_rtype = &ffi_type_uint8; break; + case 3: c_rtype = &ffi_type_sint16; break; + case 4: c_rtype = &ffi_type_uint16; break; + case 5: c_rtype = &ffi_type_sint32; break; + case 6: c_rtype = &ffi_type_uint32; break; + case 7: c_rtype = &ffi_type_sint64; break; + case 8: c_rtype = &ffi_type_uint64; break; + case 9: c_rtype = &ffi_type_schar; break; + case 10: c_rtype = &ffi_type_uchar; break; + case 11: c_rtype = &ffi_type_sshort; break; + case 12: c_rtype = &ffi_type_ushort; break; + case 13: c_rtype = &ffi_type_sint; break; + case 14: c_rtype = &ffi_type_uint; break; + case 15: c_rtype = &ffi_type_slong; break; + case 16: c_rtype = &ffi_type_ulong; break; + case 17: c_rtype = &ffi_type_float; break; + case 18: c_rtype = &ffi_type_double; break; + case 19: c_rtype = &ffi_type_void; break; + case 20: c_rtype = &ffi_type_pointer; break; + default: + printf("Undefined return type: %i\n", rtype); + c_rtype = &ffi_type_pointer; + break; + } + + int r = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, c_rtype, c_atypes); + + void* rvalue = malloc(rvalue_size); + ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues); + return rvalue; + } +void* scheme_procedure_to_pointer(sexp proc) { + if(sexp_procedurep(proc) == 1) { + return 0; //&sexp_unbox_fixnum(proc); + } else { + printf("NOT A FUNCTION\n"); + } + return (void*)proc; + } +/* +types: () +enums: () +*/ + +sexp sexp_scheme_procedure_to_pointer_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) { + sexp res; + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, scheme_procedure_to_pointer(arg0), SEXP_FALSE, 0); + return res; +} + +sexp sexp_internal_ffi_call_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1, sexp arg2, sexp arg3, sexp arg4, sexp arg5) { + int i = 0; + void* *tmp; + unsigned int *tmp2; + sexp *tmp5; + sexp res; + if (! sexp_exact_integerp(arg0)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + for (res=arg2; sexp_pairp(res); res=sexp_cdr(res)) + if (! sexp_exact_integerp(sexp_car(res))) + return sexp_xtype_exception(ctx, self, "not a list of integers", arg2); + if (! sexp_nullp(res)) + return sexp_xtype_exception(ctx, self, "not a list of integers", arg2); + if (! ((sexp_pointerp(arg3) && (sexp_pointer_tag(arg3) == SEXP_CPOINTER)) || sexp_not(arg3))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg3); + if (! sexp_exact_integerp(arg4)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg4); + for (res=arg5; sexp_pairp(res); res=sexp_cdr(res)) + if (! 1) + return sexp_xtype_exception(ctx, self, "not a list of sexps", arg5); + if (! sexp_nullp(res)) + return sexp_xtype_exception(ctx, self, "not a list of sexps", arg5); + tmp2 = (unsigned int*) calloc((sexp_unbox_fixnum(sexp_length(ctx, arg2))+1), sizeof(tmp2[0])); + for (i=0, res=arg2; sexp_pairp(res); res=sexp_cdr(res), i++) { + tmp2[i] = sexp_uint_value(sexp_car(res)); + } + tmp2[i] = 0; + tmp5 = (sexp*) calloc((sexp_unbox_fixnum(sexp_length(ctx, arg5))+1), sizeof(tmp5[0])); + for (i=0, res=arg5; sexp_pairp(res); res=sexp_cdr(res), i++) { + tmp5[i] = sexp_car(res); + } + tmp5[i] = 0; + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, internal_ffi_call(sexp_uint_value(arg0), sexp_uint_value(arg1), tmp2, (void**)sexp_cpointer_maybe_null_value(arg3), sexp_uint_value(arg4), tmp5), SEXP_FALSE, 0); + free(tmp2); + free(tmp5); + return res; +} + +sexp sexp_dlsym_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) { + void* *tmp; + sexp res; + if (! ((sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER)) || sexp_not(arg0))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + if (! sexp_stringp(arg1)) + return sexp_type_exception(ctx, self, SEXP_STRING, arg1); + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, dlsym((void**)sexp_cpointer_maybe_null_value(arg0), sexp_string_data(arg1)), SEXP_FALSE, 0); + return res; +} + +sexp sexp_c_bytevector_pointer_ref_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) { + void* *tmp; + sexp res; + if (! ((sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER)) || sexp_not(arg0))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, c_bytevector_pointer_ref((void**)sexp_cpointer_maybe_null_value(arg0), sexp_sint_value(arg1)), SEXP_FALSE, 0); + return res; +} + +sexp sexp_c_bytevector_pointer_set_x_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1, sexp arg2) { + sexp res; + if (! (sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + if (! ((sexp_pointerp(arg2) && (sexp_pointer_tag(arg2) == SEXP_CPOINTER)) || sexp_not(arg2))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg2); + res = ((c_bytevector_pointer_set((void**)sexp_cpointer_value(arg0), sexp_sint_value(arg1), (void**)sexp_cpointer_maybe_null_value(arg2))), SEXP_VOID); + return res; +} + +sexp sexp_c_bytevector_u8_ref_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) { + sexp res; + if (! ((sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER)) || sexp_not(arg0))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + res = sexp_make_unsigned_integer(ctx, c_bytevector_u8_ref((void**)sexp_cpointer_maybe_null_value(arg0), sexp_sint_value(arg1))); + return res; +} + +sexp sexp_c_bytevector_u8_set_x_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1, sexp arg2) { + sexp res; + if (! ((sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER)) || sexp_not(arg0))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + if (! sexp_exact_integerp(arg2)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2); + res = ((c_bytevector_u8_set((void**)sexp_cpointer_maybe_null_value(arg0), sexp_sint_value(arg1), sexp_uint_value(arg2))), SEXP_VOID); + return res; +} + +sexp sexp_pointer_p_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) { + sexp res; + res = is_pointer(arg0); + return res; +} + +sexp sexp_dlerror_stub (sexp ctx, sexp self, sexp_sint_t n) { + void* *tmp; + sexp res; + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, dlerror(), SEXP_FALSE, 0); + return res; +} + +sexp sexp_dlopen_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) { + void* *tmp; + sexp res; + if (! sexp_stringp(arg0)) + return sexp_type_exception(ctx, self, SEXP_STRING, arg0); + if (! sexp_exact_integerp(arg1)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1); + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, dlopen(sexp_string_data(arg0), sexp_sint_value(arg1)), SEXP_FALSE, 0); + return res; +} + +sexp sexp_align_of_pointer_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_pointer()); + return res; +} + +sexp sexp_align_of_double_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_double()); + return res; +} + +sexp sexp_align_of_float_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_float()); + return res; +} + +sexp sexp_align_of_unsigned_long_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_unsigned_long()); + return res; +} + +sexp sexp_align_of_long_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_long()); + return res; +} + +sexp sexp_align_of_unsigned_int_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_unsigned_int()); + return res; +} + +sexp sexp_align_of_int_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_int()); + return res; +} + +sexp sexp_align_of_unsigned_short_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_unsigned_short()); + return res; +} + +sexp sexp_align_of_short_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_short()); + return res; +} + +sexp sexp_align_of_unsigned_char_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_unsigned_char()); + return res; +} + +sexp sexp_align_of_char_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_char()); + return res; +} + +sexp sexp_align_of_uint64_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_uint64_t()); + return res; +} + +sexp sexp_align_of_int64_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_int64_t()); + return res; +} + +sexp sexp_align_of_uint32_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_uint32_t()); + return res; +} + +sexp sexp_align_of_int32_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_int32_t()); + return res; +} + +sexp sexp_align_of_uint16_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_uint16_t()); + return res; +} + +sexp sexp_align_of_int16_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_int16_t()); + return res; +} + +sexp sexp_align_of_uint8_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_uint8_t()); + return res; +} + +sexp sexp_align_of_int8_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, align_of_int8_t()); + return res; +} + +sexp sexp_size_of_pointer_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_pointer()); + return res; +} + +sexp sexp_size_of_double_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_double()); + return res; +} + +sexp sexp_size_of_float_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_float()); + return res; +} + +sexp sexp_size_of_unsigned_long_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_unsigned_long()); + return res; +} + +sexp sexp_size_of_long_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_long()); + return res; +} + +sexp sexp_size_of_unsigned_int_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_unsigned_int()); + return res; +} + +sexp sexp_size_of_int_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_int()); + return res; +} + +sexp sexp_size_of_unsigned_short_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_unsigned_short()); + return res; +} + +sexp sexp_size_of_short_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_short()); + return res; +} + +sexp sexp_size_of_unsigned_char_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_unsigned_char()); + return res; +} + +sexp sexp_size_of_char_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_char()); + return res; +} + +sexp sexp_size_of_uint64_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_uint64_t()); + return res; +} + +sexp sexp_size_of_int64_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_int64_t()); + return res; +} + +sexp sexp_size_of_uint32_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_uint32_t()); + return res; +} + +sexp sexp_size_of_int32_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_int32_t()); + return res; +} + +sexp sexp_size_of_uint16_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_uint16_t()); + return res; +} + +sexp sexp_size_of_int16_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_int16_t()); + return res; +} + +sexp sexp_size_of_uint8_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_uint8_t()); + return res; +} + +sexp sexp_size_of_int8_t_stub (sexp ctx, sexp self, sexp_sint_t n) { + sexp res; + res = sexp_make_integer(ctx, size_of_int8_t()); + return res; +} + +sexp sexp_internal_c_null_p_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) { + sexp res; + if (! ((sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == SEXP_CPOINTER)) || sexp_not(arg0))) + return sexp_type_exception(ctx, self, SEXP_CPOINTER, arg0); + res = is_null((void**)sexp_cpointer_maybe_null_value(arg0)); + return res; +} + +sexp sexp_make_c_null_stub (sexp ctx, sexp self, sexp_sint_t n) { + void* *tmp; + sexp res; + res = sexp_make_cpointer(ctx, SEXP_CPOINTER, make_c_null(), SEXP_FALSE, 0); + return res; +} + + +sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) { + sexp_gc_var3(name, tmp, op); + if (!(sexp_version_compatible(ctx, version, sexp_version) + && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) + return SEXP_ABI_ERROR; + sexp_gc_preserve3(ctx, name, tmp, op); + name = sexp_intern(ctx, "FFI-OK", 6); + sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, FFI_OK)); + name = sexp_intern(ctx, "RTLD-NOW", 8); + sexp_env_define(ctx, env, name, tmp=sexp_make_integer(ctx, RTLD_NOW)); + op = sexp_define_foreign(ctx, env, "scheme-procedure-to-pointer", 1, sexp_scheme_procedure_to_pointer_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + } + op = sexp_define_foreign(ctx, env, "internal-ffi-call", 6, sexp_internal_ffi_call_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_argn_type(op) = sexp_make_vector(ctx, SEXP_THREE, sexp_make_fixnum(SEXP_OBJECT)); + sexp_vector_set(sexp_opcode_argn_type(op), SEXP_ZERO, sexp_make_fixnum(SEXP_CPOINTER)); + sexp_vector_set(sexp_opcode_argn_type(op), SEXP_ONE, sexp_make_fixnum(SEXP_FIXNUM)); + } + op = sexp_define_foreign(ctx, env, "dlsym", 2, sexp_dlsym_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_STRING); + } + op = sexp_define_foreign(ctx, env, "c-bytevector-pointer-ref", 2, sexp_c_bytevector_pointer_ref_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "c-bytevector-pointer-set!", 3, sexp_c_bytevector_pointer_set_x_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = SEXP_VOID; + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + } + op = sexp_define_foreign(ctx, env, "c-bytevector-u8-ref", 2, sexp_c_bytevector_u8_ref_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "c-bytevector-u8-set!", 3, sexp_c_bytevector_u8_set_x_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = SEXP_VOID; + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + sexp_opcode_arg3_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "pointer?", 1, sexp_pointer_p_stub); + op = sexp_define_foreign(ctx, env, "dlerror", 0, sexp_dlerror_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + } + op = sexp_define_foreign(ctx, env, "dlopen", 2, sexp_dlopen_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING); + sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-pointer", 0, sexp_align_of_pointer_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-double", 0, sexp_align_of_double_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-float", 0, sexp_align_of_float_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-unsigned-long", 0, sexp_align_of_unsigned_long_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-long", 0, sexp_align_of_long_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-unsigned-int", 0, sexp_align_of_unsigned_int_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-int", 0, sexp_align_of_int_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-unsigned-short", 0, sexp_align_of_unsigned_short_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-short", 0, sexp_align_of_short_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-unsigned-char", 0, sexp_align_of_unsigned_char_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-char", 0, sexp_align_of_char_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-uint64_t", 0, sexp_align_of_uint64_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-int64_t", 0, sexp_align_of_int64_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-uint32_t", 0, sexp_align_of_uint32_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-int32_t", 0, sexp_align_of_int32_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-uint16_t", 0, sexp_align_of_uint16_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-int16_t", 0, sexp_align_of_int16_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-uint8_t", 0, sexp_align_of_uint8_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "align-of-int8_t", 0, sexp_align_of_int8_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-pointer", 0, sexp_size_of_pointer_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-double", 0, sexp_size_of_double_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-float", 0, sexp_size_of_float_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-unsigned-long", 0, sexp_size_of_unsigned_long_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-long", 0, sexp_size_of_long_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-unsigned-int", 0, sexp_size_of_unsigned_int_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-int", 0, sexp_size_of_int_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-unsigned-short", 0, sexp_size_of_unsigned_short_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-short", 0, sexp_size_of_short_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-unsigned-char", 0, sexp_size_of_unsigned_char_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-char", 0, sexp_size_of_char_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-uint64_t", 0, sexp_size_of_uint64_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-int64_t", 0, sexp_size_of_int64_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-uint32_t", 0, sexp_size_of_uint32_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-int32_t", 0, sexp_size_of_int32_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-uint16_t", 0, sexp_size_of_uint16_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-int16_t", 0, sexp_size_of_int16_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-uint8_t", 0, sexp_size_of_uint8_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "size-of-int8_t", 0, sexp_size_of_int8_t_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM); + } + op = sexp_define_foreign(ctx, env, "internal-c-null?", 1, sexp_internal_c_null_p_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT); + sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + } + op = sexp_define_foreign(ctx, env, "make-c-null", 0, sexp_make_c_null_stub); + if (sexp_opcodep(op)) { + sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_CPOINTER); + } + sexp_gc_release3(ctx); + return SEXP_VOID; +} + diff --git a/foreign/c/chibi-primitives.scm b/foreign/c/chibi-primitives.scm new file mode 100644 index 0000000..e734107 --- /dev/null +++ b/foreign/c/chibi-primitives.scm @@ -0,0 +1,165 @@ +(define c-bytevector-ref #f) +(define (primitives-init set-procedure get-procedure) + (set! c-bytevector-ref get-procedure)) + +(define type->libffi-type-number + (lambda (type) + (cond ((equal? type 'i8) 1) + ((equal? type 'u8) 2) + ((equal? type 'i16) 3) + ((equal? type 'u16) 4) + ((equal? type 'i32) 5) + ((equal? type 'u32) 6) + ((equal? type 'i64) 7) + ((equal? type 'u64) 8) + ((equal? type 'char) 9) + ((equal? type 'uchar) 10) + ((equal? type 'short) 11) + ((equal? type 'ushort) 12) + ((equal? type 'int) 13) + ((equal? type 'uint) 14) + ((equal? type 'long) 15) + ((equal? type 'ulong) 16) + ((equal? type 'float) 17) + ((equal? type 'double) 18) + ((equal? type 'void) 19) + ((equal? type 'pointer) 20) + ((equal? type 'pointer-address) 21) + ((equal? type 'callback) 22) + (else (error "Undefined type" type))))) + +(define size-of-type + (lambda (type) + (cond ((eq? type 'i8) (size-of-int8_t)) + ((eq? type 'u8) (size-of-uint8_t)) + ((eq? type 'i16) (size-of-int16_t)) + ((eq? type 'u16) (size-of-uint16_t)) + ((eq? type 'i32) (size-of-int32_t)) + ((eq? type 'u32) (size-of-uint32_t)) + ((eq? type 'i64) (size-of-int64_t)) + ((eq? type 'u64) (size-of-uint64_t)) + ((eq? type 'char) (size-of-char)) + ((eq? type 'uchar) (size-of-char)) + ((eq? type 'short) (size-of-short)) + ((eq? type 'ushort) (size-of-unsigned-short)) + ((eq? type 'int) (size-of-int)) + ((eq? type 'uint) (size-of-unsigned-int)) + ((eq? type 'long) (size-of-long)) + ((eq? type 'ulong) (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 align-of-type + (lambda (type) + (cond ((eq? type 'i8) (align-of-int8_t)) + ((eq? type 'u8) (align-of-uint8_t)) + ((eq? type 'i16) (align-of-int16_t)) + ((eq? type 'u16) (align-of-uint16_t)) + ((eq? type 'i32) (align-of-int32_t)) + ((eq? type 'u32) (align-of-uint32_t)) + ((eq? type 'i64) (align-of-int64_t)) + ((eq? type 'u64) (align-of-uint64_t)) + ((eq? type 'char) (align-of-char)) + ((eq? type 'uchar) (align-of-char)) + ((eq? type 'short) (align-of-short)) + ((eq? type 'ushort) (align-of-unsigned-short)) + ((eq? type 'int) (align-of-int)) + ((eq? type 'uint) (align-of-unsigned-int)) + ((eq? type 'long) (align-of-long)) + ((eq? type 'ulong) (align-of-unsigned-long)) + ((eq? type 'float) (align-of-float)) + ((eq? type 'double) (align-of-double)) + ((eq? type 'pointer) (align-of-pointer)) + ((eq? type 'pointer-address) (align-of-pointer)) + ((eq? type 'callback) (align-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 type->native-type + (lambda (type) + (cond ((equal? type 'i8) 'int8_t) + ((equal? type 'u8) 'uint8_t) + ((equal? type 'i16) 'int16_t) + ((equal? type 'u16) 'uint16_t) + ((equal? type 'i32) 'int32_t) + ((equal? type 'u32) 'uint32_t) + ((equal? type 'i64) 'int64_t) + ((equal? type 'u64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'uchar) 'char) + ((equal? type 'short) 'short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'uint) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'ulong) '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 "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 + (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))) + (when (not (symbol=? return-type 'void)) + (c-bytevector-ref 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) + (error "define-c-callback is not yet supported on Chibi") + #;(define scheme-name + (make-c-callback return-type 'argument-types procedure)) + ))) + +(define (c-null? pointer) + (or (equal? pointer #f) ;; #f counts as null pointer on chibi + (and (c-bytevector? pointer) + (internal-c-null? pointer)))) + diff --git a/foreign/c/chibi-primitives.sld b/foreign/c/chibi-primitives.sld new file mode 100644 index 0000000..fd6678f --- /dev/null +++ b/foreign/c/chibi-primitives.sld @@ -0,0 +1,24 @@ +(define-library + (foreign c chibi-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (chibi ast) + (scheme inexact)) + (export primitives-init + size-of-type + align-of-type + shared-object-load + define-c-procedure + ;define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null + c-null?) + (include-shared "chibi-primitives") + (include "chibi-primitives.scm")) diff --git a/foreign/c/chibi-primitives.so b/foreign/c/chibi-primitives.so new file mode 100755 index 0000000000000000000000000000000000000000..fc1ff0e30e51ccb0328c807e7ed4a6600c502ff9 GIT binary patch literal 46888 zcmeHw33OG})&C6%5FmtrM1xa<1r17K0z`uf<^jPQ2@s|_06s$UGDt{b@}7jM7>p>- zkO~ehS}oC9i&`t~=UlY`L9lfI>p)vAgQ9s~R0b7;)BFGSIs4pq-pPH~_0|7c-?tVw z>t^5mJA3c5&pzWF-}MDWlY7L)S!#>7##<52vhq1${bNdkuso|D{-0`{B4iUHN!^Yr zGbN;`l_Gh{qbD6^OWvdfVS~ecUB8T`mr^3O^-Pss z4`2i(uA)@Xd!p%X4wj;cGT9;@X%F^F+A-;vc!?{j@|yuY6)Gul^#5G#)=bVXRy`zg28yb-NHE!;HgnOmITpgxP8ho< zVm+97NWe+DM|$7H38JnNQmiKH zxQsz|O7{AViB_9spP7)-)U>-t;;_Q(^g#;}!MlMtRcv4(`!skYzQ+!PE^Y1LIQS60F@R`Bp-oeCy2o^u)G=VOB!>O%u}M zR>j4&S%YVgFKRne9e|F+PF*L9v24&$*he#;3wkd0vCI=W5BvGpFTg$y`*`dZV)tOD z4aKx3iX+RK3~KZ76wqmWOr#k54D2(p{{;Ib*e}JdZeysMxf4sV2+L++^XKhVPd*H>cv%dJ_hCfdly|>@A2X|C_dG<+v z{cMvzIOwz6_6^ya`YUU}!&T$k{d1qGo_SaO;U{|ecHOo9vz)Jw#9uk{^vN6jYx>@u z(J^~&NymX1w>-7mKk?*io^KgB=NB1|ESgpFWWPl-eaq}Mmn{GF&%T&=sAkmsvBCT$ z#lPC{=U?paoVPY(%1xz1K3kjq!NEiOE;@K!=;Ke8om^$z{?wi0THjffHTy@~zx1u_ zckg?T-&s8%{KbjG-rSb)(i8veeEgpH%Rec5xZsoPZ+r0E_f9Ms{*&5IgPU6B?t9|S zaOv*tkG@iI>YuJUxb=nAPYk@`rURF}{)?5j$6v8}!MT@>IDE~hyB_+(x>b*E`TOT* zy}0Vrk8j!k#@T0IA5557`C;i_*1gzu=PB>Kd+7aZ`d|L#h^b%49oaPU;dk3wi|?3u z`@eQ=cy#1LL!S>!KWF*lRX-oFanQWi?*CcBk+@GzeIn&vkhL>mZku3Se${zZmj$G4K@FNq4b-TMYZd`dHRL7x^!MyZLiRjC@DNz$eA9zc0}} z-%)Yy`Tkc7e`d$9zb=OS*~r(eTw`L`c{PT7LX7g3#;{WrL;m>~^@1?C)?-5q`@f4( z-rvQ@_qG`FpU0?|gc$kO#_+!}M!pZmkbgTyzPn@ixjcqHgJa+{52a%_H<~|AGePiW zy{VlfTi?=TgN^iQo7qd^&v+!S@TcP?ek)B@*cASk9ui+d6B#yyMQks#{hN6r>&N(e zjNiuiI>v{fL6AQ_ni#Pu`d6?^K3fGsilL7(qCvA?D=hFdeHpk~P zBR&r%Ncop(;et)sKauUPqs5Je7qk3)Lw*ta`AEJHck2Bijze#@qx`I4e5(;3T5yv8 zxok)IGl~6q%kbw@WJmI+vmIKe(YBN8@lQrQp2>C|GW_`m=R1+>MdiDe{ruMOb1m27 zNk%+3v;1ho&t)9{5fi0<%D$KV{ISs=PvtLc7eCtVWj4fZo^#Pd4#C)Maj+o4D8Y8Q`Jqu5Sg zj@w+LJ@n)FubChPm7mlN$<8x8K4i0<583}MM!o-@>vy=ban9>I1#XZf31 zUbU-{9JfXJQc&R;obUTayCs_WPi4sU+{3)*YzZvaw8JBCi(SG`~ z{MSak{FL$AjrKE;<9uPh%uv<)O71Vy3!?owpZ(lw#NkbDSL2L+(VP8z%82u9mj5Nk zLFHS@`M$t$Tf=eKjDA6Jo;6bfTToB54dQxP>XE!^CwFi?dW?G9#N|DK-h(WVsrQxV3QHE;H(JJo_Io>|0)M z#p2o;Z-c+2-tYBV-on{ay=A_7Uqw}e-&a3->cr~W8sF@ah1EWp=APm$Z7lJYSJjkM zSN+syHTW9qyk*tC`uf^>SPm?-n2{-qOBVUOrFFGcHON5;H!NK&MTN3|X`RpOYb^EE z`KxMcppIlESzG5Le}z>#wxm68O`y73&p-fDu&O~z71_d5Z>f~1<9y+{x3=7iRR+7|k#mkqCIm)Hl6rShg+|Llbo3|}s{}?%l74qlg+|Ll z^qes+Rtb!jB>nE93XPU6tt{cHSJ5LRS|(7_P*qXmEAw_2j!KHwYN)KOH>yuS(Nc~9 z7xCz{Xgw6MThoY^aJ0LL>M7AW=wlVpW(kRwakRS&Mo67#<5KTB@uzKpk9k zJyjnPik-253l9195tsBg&{D3(-h#aAX-ZWXXbyu!0R~2uFH^ zZaLC>9F$DB2rIa|v8 ztqjnx7}c>H(WstRq_h@4MPp>c^ZL$n!S%IJPbc-bR_dnN;s9m-XS2 zAT`7YAtpa3KByNl3r6WE=iI%}Qe9n9>F)k$snRL(pq?i5^71NgX$e*VbRd=x4M@w2 zu+)z$L_AZQiVXe_5hEmr$#D*Tn++B%Cu z2D|0;K1>0nmA=J3xKLZ_D+|>7y#89J+0_O74LnE0meR7Vs;TmOtE(2)m((w{8vOO8 zi|dHg2ue#t>9aKHtGOEMPAnnS@=+Xn%WLa>G^3OR8l{|QeB8|8JIo`VSq-&Wd30P_ zS+%e#Qx<~2Yyr~IIaX2OgvpZ&y%RjM3cPtpxd^~S@2ITNS!0~z$kC{*Tn8OZH;LnL zFEAc|arjFR|KmaFs3%k62#bd#$&hR>P9trSl^W6tS^B^IM^TBh+Hvxv?rXID_YTA= z!Rq7_Dk||FPNy>)|Bx!2k@d2^W^8a(Re!qM+8ZajWFv4QrN>(XnSXrE&vC}o!#age zgw_3YobHKj17BaT?vcF0>lnB1kH!_>aj(Q-T-@W6oMj!*aCNPR(z-ODMoB^k1F zraTn?6E&RfYpN|p!>?5!XqtxORL$AaH5{j!&X%F!bPrQ)*%}^HAZVV3b0|e>zJ{xN zz?5KX_yQp*{}pREpMr~oOEsKNodv!?!*9{-RBCvVhSzDhx@SwtjT(NPCf}st>RJ^g zuhek5cdWM68eXnI(6t(VqlUL>_y7%Gui+&czCpt)H2i4|pQYjL8m`~>+NR+dn*4SR z=SvPEb*F}_YeST$;BFeu_k}1hM%h8 z3pD&D4X@Pj91XA2@Y6KBQNyb>yh+1v*6@`YUZ>%!HC%tzVy%YH)8yMUe3*u>*YN8# ze1nD$*YKw`{HGe;uHmO^_%;pC)9~#YPWLv|wo}6=DG+qGhV!LXk=mi*`ojPRH2e(B zPM3yXq2Xz5lA*B~m*ku+y-gkxj!TNpmeD2;3CE>6XUlGrhlHzZe}v?<(SLd0FhL%Q z|M_i_A$jV1YO~wq5#eesB&4{F{!2So%0u!0(l*JEJSJXeThJyC37_krmQ|_YeKovJ z!>4F?qlT+ziYU2B!|Ms)ZDpH0pnUm~tpHYQIA8J<_*xBb5{UfQrr|{zzFxyG)9?)% zuI^=0^3xjLp8($4+vEZH$+rvyuua1&rHJ^yUBlIqg%WmZ__+k|w!2LpkbPPgsjZ_; z9uc0aK+pqik|BJcJQV-C+9X3bUviefeG&XPc_{uTYWQRgPtkCC{!MLZ8h*S2LDMz- z1P#y7@Fg0at>N=EJWs>D8lJD=(=^=H@C!A(Si@&%_@x@YLc&X zHM~*7&(iQF4PU6?D>a^;XKVOQ4WF&yyEXhr8s4Gdb2R*bhELV-E)7rDaO-}_P`@}^!xJ@p zsD`I#c$J2yX?U}Sr)&6f4bRZG^kzoA!!!e~<8XyLofsi^AP-?p`eC4uyxm4>I6K7RihG^H69{I2>Lr_&A6j z3hi+C9)jQK@U);h6#9e1(}L+x=st(#%As=PGuqx=p} z6FbW9@N~j>D74YxX(C7Y9iAp?l;7b~1;57OX~IVN9iAp?l;7d$#1Q3ocsemd`5m4n zMwH*-X#zs|9iAp0l;7b`5&S@hrxPWV-{EPXKNLFnttx-I;P*H@4ag|J!=EPjjSf!( zD$4Khbi#u2JN$6LuW@)f;XwHv{tUrihGd6eJb zGX+1;;j;uE=kPQUq5R*d^3z0#`giyo!S8VRQG(y-@U*~2`5m4X5GcRH=L&v}!_!2M z@;f{&KvDk=PbXfee}|`qE9&3j>4XaP@9=a%2<3NpTBxJ^4nI!t109|gN~nK_rv)3z z|FtTAzTo#byhrdm9Dah}H#+=8!T-VG=|m9acX*m84~5n!9;3~iMKsz#j>Z@8iw)jq z@beAc)Sqgk7a06FgU>biOoJb8@TVAjs=@a+_?`y;EzbS)@_u3PpBVf;gMZK9-!k}D z4StKkKX33)82qCK{~Lq9*Wm9o_*R2oVer=(e8Aur8@$ip=NtSSgP&^f1qMIP;ByT= z)8L02{3!;XYViFHzNf)|i?wT1{Tuuz2EWhX-!u5P4E|Mv-(v938~hUn|ER(L#^CQY z_&W{0)!l5-}wi_0B+cdwNzqwce$un zrBCBo)3|-KgbJKB$8H{XB_u67xX+(tw~Tudc*l{i!r_iGEIwZ9`8@cz`OtOpC;iY8 zB+>yEZfSP#+F^+u`=DdD;HV&{{TUj*?ck;tXj;WeE-iEsW^$6BV+X%IyfHq|vw7@r zf4^sC`jPR0!JfnI@qu2R=Da@sfknZM&-M`(_RkN!3cH0Z`6-1h#fdp#yVc(##cn<_ z-k)H%EKTdU5O(e0elyScp|>%0iVO>bFGuq1{~eCg}Ow~fXC|63R`9*7Pfd&?AB|0q;$}H#3)yl(sGUbUt^SO^ij0}F|@w@lFQ{J;bG2EwPwZe@N4)W%H>*L*TvAKR1BE3NzT;4*F!_Nz1pRRR}Max*BXBj>!VF#Rd(KRe@bEVSL12O-jPU?f&-dAPqP0@RsX6l{k}6rSU>#bs|1i_VjC-q1Wfu8`JjCs3rw)6jeS z5h<~Z!&>v-h?0oT&Ti4MTYi}EOoKZ|4bQ7GJl$8|v$^qM$-mEYiRUMtIiA_Gih_Uj z1drIuKkhtXO5AQyOcONDc1`iZ2-%T}8G-9hg_8Zq4_)yls=k|)jq6WsGBFRSZH;tnGeDt4N zt0QZ5Kd80JAI4f?>s932f*;bFZ#`ARe_RE^vFsnlF}ryq6*EOxLyP+l`+4idWG(Rr zwRY(bWz8nvihodR_77yOc@z1TFRWpRR71%BY?zdT_HXijAZyL-@NI8laId|w1B1tI z4Bs2=<$L7t{TF-en{I>0a5;8trgaBR0tsDKQA=QTQHyVFVeoy-Uj;egf}Bt6*4!&` zw`fu@G<9rfz>R;vlEZFULDSQOmcdr*gm81$aRY81O>k@KwYZOCmnPg`$88@U-i@nn z>+ocf-Ev%EFk#r?O>wlo`6{@*^SGS$!&pcqHJ_Ih=zYrstZpWx*)7*S9eRaUVl6#O z@Z1Th*e&tvg;G~=Q)hC{8|&i(iOqRQf%sdBAz!dz!pgxJMR6U4!Cs+naYqxHU%F`y z7MjVVNo$&7i{ZiUr|8Wy0BZuq$*4U6yR= z8H~yojls2ESJ1#oRU68{S{Z7mMU|A*Vnvn4$<8cjCAn#JtH~8K5{k+UJu6E%(oHW` zZZz_V+{&lvA$2L5tUwyu(CDnt-L!OT>G^t;no|?8Dv<`W&U2tQz+Ep^4brf6ad2>6 zQCwH(HQYpmh1`gRLjx|)M}4oL;pnpo0|q8oMRDz+2c=wrE|-#@IHfh=yh9TqbYAF2 zDN#xiTYJ$uhB|F$0M_3Dmh*<{!|{PW&3VHExI|r?HYGUteAqZYG#T1|M#!xkoEzNR zffiB}yz_t{E4l<}wct?4Js%>aMGCYC0Srm+;D&fniYC3Z{yXQ$$z1_wLnz=wl$6r*z< z4sIrySvWYAk}k$UD%t&c?w^Iyk*$P8%G(0*-PiJKoqwk?;Q}O74w= z8*ot6GCUrcw9I+n1v)V-YAIM-6#S^;j1S=T^CwgJPZnBJSKBR5q=QE)YPm4DrDGyw zFbZxfv(J(z2L7HMkG&79)wi=K*fG~L&oke1g~vNzoFU3nj;X;dp4o-LS8#fTlf>OP zNt}gS7I`=`vs>m3tFwcXh9wrY_=hzXwcI$Y2@VAYc@A%m5A^mlUob3*&gS-Xo&w{f z0NIqlS)RjNMDlf3lK<4AU`XCDXx^NMbHusxl@Fog_rkH@HjLnBH0SjSoQ9^5h#4Vp z98Cm0F%kItpl+t%xrffhHg0cpzGaUakB9_9hhHRt^KlMqH-C+DSUdQ4dB%NrQSbo! zkw!O6UJ|F-kGQ@b+E6__AJt&R()9D1cHT5$*c7coVhO6fz;4~Ik zIXI==UxZ?2*ukP<=^YFAgu^e;#SI#3TN~p#_E4c(kW|zHA!_ei?b1zj?t6Cg*j|A% z?G{g>n!sMd1a{b&z*_3kJi#%)u)~||mco?Im*G!zmg%0Y2{$7vtK;L{$dxXRs9YBz zSIRKGP~5PI52WEXQLn%tx+8>pBZ+pfxN9nfaIf8b?XWb<-b!{Xe`4W|@1_P1bRLJf zT|}#|r+Iu*AfcdTa$3&IBDm!})PjT}Mll5Uy$NfCbsN+C_rzIdn5{1Y| z_KtAp;GD2%B}t-{1bTXKpCYX&_*D_YmeMf=Z8CB?ydSMs+z0EJ2)rnWR)IFx@zO2| zB{J@KP8MT3>HSQpxV-#yA-IIpdxM#IBVHjO?v9}`r z6jeG%R0y4&3nW_|q^KnEWIhS!Q&PuMaMu%Te|mgB%PLsWK48VE$(Hr3sO8q&oA9&{ z4FYfc%Md!!ALfI*pQW)DE>}R#4(_4=VmZ{@w18OnWw%oFM7zaN8XaX5mO@8)bc6;C zPv{73Unq9$LzHq3W4a7GkHm!a46Z_YajYm%+` z8B?HmC9)-Hs6GMdaBiKAFv6+~OzLxF;!WfwOcVw;U*Uy~60$K**%0Ft_3&LlvU|d+ zN8B2GrZ)}&q>Z=g`*fu&|3I;FR-Z~+Le8ISaUtAFpB)?5w$Bx@pvdIlV?x1WFD|Plnr*i zt73&A|EMOVk1!d=^J>cEb7T^$XL2=(O|ErJUgo(RCWn)k>Exws&k-+Glw`FCn^Z0D zA%k%4*n)_+As~oK$2eu$>$x<_S+?YqUpgy23w{dA;oK2$6~_Nardm_~DlG2m==>*_ z|FSFoEmx&s*jWbyDhgMVtJElA_?K+>HW)@a#ztywXpGQVDf7Nvid>087D2P4f_=!w zpp_0Uy0zEV)TLT(ZP0{D$6~i-+Lf*Y$P=i1fh=wT|MwYag^Kv-%`bom` zbA?;fH9Fqqn%Waq zI_4;S(f1k@g$_U51uq4fPoS?KtCo#1l+W}dTUpV)d()Ujz+JFDM zD!c3vF8Z%U^iP^7VyESPm!mJ6zo{=84K?!@U?rS;CL9n2dP%y_ahcMWZQN8B4GP*1 z2<-%9PX=34pA_o5I!;vTqCuP55TtCm@Z}Rk=x&!eQ^mi#Qx#scBU2su{w$*YCDdW? z-iZ3Wj(W^?b5lfriPT>e(Vy?=e^0w9hfX;6K^PE4ffsc^I!;mgvD-~R<{!?z&m#(d zaU}O$?{MK`wHuP<(0!IK%04@yeV@|y#B4Wt5&hA~9bS7P`X!G3_q3Z+p%c!nhXK)U z&XOiNhARD|x0__4{SBT0mF;GTP~X+D_iZkGtafuU1iA3bWa#$e!DjAq4=8Op{=!A1$!Yw@E3u@p+ARYVO;=;#n zH=AVs;oOH1I`o6PBf0-pX~$|ecSv0tYv&?sap4lWy=*`gC~;_x?GtvjW^Xw zJ7&AdkEq`Yb;NFRL_O0{kJ)ZckLaH(^~Xf?KlvM%z1vFBn5T}1PB`~NJZY`k%}GEy z9##6W+YQMc zMBWHptIV0&%^0N}v)$YhQTIX}Io}ph|6+$Kd(3v@kLZ7d2k@bPO+^0*NB?`qo1Z`@ zoO=ZfpeSmII3Hj~y)q%1PAaXDQ)rDGCl_jBC3~fe_-yG4#x2-E9I_&gjD!`V^~m!I zI+K$pXW~Y`-7v@r~Z{A!?=g2S0=kmpSL(S?%^7TG{puR>(%cPoGe|kxJHNH=tUR$mVG+5Cved4mgnl^oQx+i_|oM{th z7fzpMWoPB&;KPrlS7%l%J~L2h;d79g)2CQ7XBSP%oHqTEfA`y#;^UW@&L=W6{k56u z}kG-nAGmrkYRD6lm z`PQnNHqwVmhoZ8^mt@^@4dlhhP=0&XH81EyvQeLLWj=O!~*-gPs&dI^}M0HdKE}y7&5qFVt`9iiZjFP&1 zPn%IAgzmCr+4u&yvh4B=aCc!wjd~%=kuUy7YLa0?+FjUPR($7JeV#wcaQ6?b!vetW zp>QN!zw=HYg&}I-Q<8eOQi6J~QgT|SQes-4Qc_OCiS!XAt&+4JrL?*WNBWbJQRmkari@1xFvLJpGA=(p_lo{zC%66m^DNnk~ zM0X)2r_gRuh_#IgJucl2+JC^)k;lYXs)Cp+!;OJs!-z#_D$`x!2%Z^r%|_6u=i z;X3S3Vy7Dl3D9dn{|ves zv=eka=og^Rfezgi4!;R{7H9|PC7|@%Y9*k9L0duTH==$4N)N%j2zn{#tDx1OM?h}` zjejv5UJH6Q=myZSpqoK`pzng#f*t_;vLqX}cQKy2^Z*E=!O5ZJS2Hgp|4)kNtM?mqTm}+#2xL|N=})aoObbmeoGRYtP4*(@66G|P6I0RCxPZY zg*Xtv8`+(QJsbD}(&vqEKlYsG!eRLwUvheBa-zs<74SmfSCMQ%a>`9T>iQ-p7WAv< z^xpx#8|llO^hS}s1nHFbE7-e`j%Fn`%4;|FPGIzjD$7nz_pxjj*q+aa!?;rdKH0d@+ok%YkJ9JW~mJjak-!1|_aBk=PL*;TA>%02+Rz>uY< z=}6y{-41-ZA^QRAo3h^kzs!(L=^^z^S$bKZ)R4UZ80nj`vw<%*WGh+Ulx+gO#E_-m zJ|lfo_IJRS8?x=JZ_3i|zlGGf&Z5wdk^cIvX29Q-jLnK`ljq|;9CvZ&spD;O+r82VaTQfBYjgg5BNU~*&^0A zWof?LXUI0Pz9~y{>3&1@0oFHVX`Ve|$ZltSQ!DnoWR>zlH)rn$zD zO~S-M`lc+ccUBm(dB8~Dl%=)Mt%fZ9Ml|W0vb0XR%aC2o`lc+cp?(cnnv-dx`RX}f zj{r*&h{U$D94!H8qxtFsV0S}q9RWSclT#X#6G{IY;6t$U{{l@O>^*1 z#T;9~b6hskYmlz;B>S{ZD+jiQbb2gEPN|dj=K^=j@N?@Pi81;4`q+2=r;vCi3oaow7noN{ZA3CU?c zi=U93-kMO5oUy9sMakJW^|~lIuetZ6~k zSH>mhdAey>c(B&W!`kna*TUgU98=z_5LdV((&)G5-$U96N)u)9inI;zvkqzhjWqH5 zu0n50a@tMtlakY$6E04!i=Pvh+&C?{DQ-b>vFz|2o>^q>G0$&E9>%@bUy zOqwg?qL@W8<#Lr0(cu(-^2)f$$*be0IT^qTGJuttuz#7#I*K7bE)imIic&7snWO5+ zg1G4*Q?_C?PT81w8JOgAuXXS$u~Zl(vATH-<&*7;1+nPxN1XIjj30n<9BO-xra zZDYEDX*<*HOm{Oqz|^8|!(&Tfn$9$vX+G0prVE(XF>PYHnrR!;4NTjaZfCli=>ewJ z7|x$*I@4^X`AmzME?`>6w27(u{l<$XPCPF?W6r`rjX#i%r#i-DWoPCD1e>#L)TpfN zF}s065&s_)~aKg*N3+JSKRz@}2-ZT}Vd%8y!Rb zBH#m~MFm$8L;h-kCtH8R`&P6mf7UR5nNhCwjK9zRtM$|4G3>v>^6%se^HkGf`&SJ4 z{VYGx6D{8h3ml5`^An=+RN!vq&1Lz4TwkeD%^JtJk8xGrpD;eduwTY_s!?CpFn(Wt zv_Eujl>D4qAo1m#?_-QFHOln@KE=p)KjQ(;SNY!$*I?b^a3*l_r=L+@ z=Q3V1M>;63qu{WR@tjE#SM7hkz$K>tuZ@A5|FOB%qHE8m4hk?J%_%5Tr zA7p$u*O!XJKrHylPBX_@;b$^_vr)eu#@86}p8?!0o^>q$$4N2@NgRxz!1c(;;|E!O z7v89%O-4ZD1N9~rml z1rkv8ezw3_NFx(t;PZgH)yuVP|4&A}-@^D117FAZTSh%@V0?|yPj@grg4?ZXS9=+s zZ`9)<##b2mCPIR(^vs4^9Q;CF3nU-j%yz1b z@~&mPPrejXzr?WrHp@>n+RvAa@8t0r-AZinnE2er8G44qtz4spe6sb4 zG2az3UcvEK{+BYoC|~9WH^dfT+{^JlneisZFK0iOF}{ZJ9K-%2jC+iJv{B%!tdX}_ zeowvxm7j-zyOsAibP#F}vt~+paqkF+X9IVWpU(1Ijdn}V(xgihQU7mX`4Eq*S8?iX zjL$XfJj{4+qaAKxe7{le?=n8!X#XL`UpD&7SB&3l#5olgFi(r}Tr%0fDLz|`aVa18 zK%74|-7n?Rm2PRhzri0UFV8Bq%6#>{3cL>CtM~dBdrR@0tFOWGddq6P71gy1ORBwP z{@VHmZ%LrhDy>~ySMBrr%J3S5tAw|_s;0_YQeR)P)Qgui>X%yO^(Bja-m<{r#Y>^0 zad>LB${!_KT3NNQ3NJ=fEw1ucUF~atZ(i@@nVzWy-hye9yk1LKr;HnFy_F?3Wz{~* zJL$4%o~eZsfnGFij<>*O1$)v=K(nV#RH_#hO`qT?@=l*Tc~-$}?`+S6q5>EsALJvK zzM8AO@*R`thdS}hW#pk!U6hO7!r4<11=Su9K57lK zOBN#1!XUkL7w%%7&Q6n0qW00H>PY~Ay{0&j%iip%S zK+RVs9)GqRSUxr$Rho0gbSq6&gO?t=m5wN1k*D)0uVar25G@vYg4z*M-ijba)uVd1 z#i>k3ho9)?sHn%7qqB0FN+eH_g=0ikmU?JEs?>Si3a!c+dEi_0+v=)?^(E-uQGUy} zeWW+ysbmz9Ue7{LZ19(qE<)57dCNU~~+t=GxLA6TeWiPJh%-9)#IC@rT@4G?ze5LzWfp4@lbiy913 zOnPUnTM->;+ESkq%VACi7~LI5 zxCNpmS1hirq2^rg$BZQGtC;btXwi8(@z&aukl?vQYkn%6(fw1Q{02;vN8R66(B6r0 zVsmwERay7QL`GH-cgHU0BYaeOJB2_5*tsm6t-K1zyw7@g)mCjB`neJUqV^Fh(e7i z^3tg?#_q``;j}kuzi#EGYLlaxa#Gn*E#Bz;(vX^{oFY0!Kt57Kx@l^wh(=n7HkMlA zZP`f08TIBe5$Y2XGSoV*;~8LQnsPv=a9BS$1t(+ryQop!jisV{np5h?u-|Ab$BdB& z-b4mZr*_zQ_hv~h$v|Swuj<>VT58gxN4e`d1=hwOv7n5-oYY=kj`ls$u%iMK-5{b> z;8}FQ#60adh2+R+>7ZoLsWGp&w6TQFF_8Sz=(W3QsLBdvYs<=NSi0C>vJli?FKMMZ z!rSD&tcsdI7N+DnU%h{+mE}MS169>!nN?+$5U4C^sI;=mme#V4HEq`*gY)qX2WoX2G0Fsq^#EFCoXO06uvuMsSrltH?-ti)epW%(-kG_0}= z))Xgg$n!C&p^lMN$>J&)gK4r1FNK|j4GmTn&Isvke05s+pVE_HfUb%3U_*5Ohc-pi z1sC~;%WF|v7C2ph8|y1NEJ~X0eMWC|+I|?%xTyTqb3KZ-#Y=gmXXZZz$+(2!_^+P3 zQ8W?fO)blvAz)=<|fAt)ZqUyOJsU>ZwW1@4h(=$9uUp=>@=<$>( zHs!yPQ?wFk^h}WA)pJ3L)(LItKglTn8Mc<-fNU#$J6)zIs^XyXSNf{_%UOSdRI}7` zO^WLJxV!7*uk>4hQ4w)DUvBCGIa6w1`lkF)*iAUl_0w5TQSnZd5(Z7-V@1~(`m6c5 z14WgbGNE`y?>6+?SYOcvhQmrv(O(<-&hrO+UF)2)RL+trJ%v7G=&SqoigNQ+;!ZnK zz+ffs46sGU?QIe7x#j&0;^ws@-MaOXeQ&vps$%>~$Q_ zGa4!z^}IwEH7snVyy6x8Cu9a-SNhKL8LLS9`}IG947FXQubzWQWc}UTe`)-nP35cV z@lIeQqVzlNB`JKCu~pJEr(z_p^c6h-Sl74Oq@1-{Qu}-Kj~M#u`40Owsju>3tB(JQ z595Gjl>ZCvmnp@ppD$VGf4Xxd4-()!`JZjzNfP)I}V+#_&#|!$>=~TUnNM_vfcFW_`Q^%=T!8~V6FcL4%mS0 literal 0 HcmV?d00001 diff --git a/foreign/c/chibi-primitives.stub b/foreign/c/chibi-primitives.stub new file mode 100644 index 0000000..38d6972 --- /dev/null +++ b/foreign/c/chibi-primitives.stub @@ -0,0 +1,324 @@ +; vim: ft=scheme + +(c-system-include "stdint.h") +(c-system-include "dlfcn.h") +(c-system-include "stdio.h") +(c-system-include "ffi.h") +(c-link "ffi") + +;; make-c-null +(c-declare "void* make_c_null() { return NULL; }") +(define-c (maybe-null pointer void*) make-c-null ()) + +;; c-null? +(c-declare "sexp is_null(void* pointer) { if(pointer == NULL) { return SEXP_TRUE; } else { return SEXP_FALSE; } }") +(define-c sexp (internal-c-null? is_null) ((maybe-null pointer void*))) + +;; c-type-size +(c-declare " + int size_of_int8_t() { return sizeof(int8_t); } + int size_of_uint8_t() { return sizeof(uint8_t); } + int size_of_int16_t() { return sizeof(int16_t); } + int size_of_uint16_t() { return sizeof(uint16_t); } + int size_of_int32_t() { return sizeof(int32_t); } + int size_of_uint32_t() { return sizeof(uint32_t); } + int size_of_int64_t() { return sizeof(int64_t); } + int size_of_uint64_t() { return sizeof(uint64_t); } + int size_of_char() { return sizeof(char); } + int size_of_unsigned_char() { return sizeof(unsigned char); } + int size_of_short() { return sizeof(short); } + int size_of_unsigned_short() { return sizeof(unsigned short); } + int size_of_int() { return sizeof(int); } + int size_of_unsigned_int() { return sizeof(unsigned int); } + int size_of_long() { return sizeof(long); } + int size_of_unsigned_long() { return sizeof(unsigned long); } + int size_of_float() { return sizeof(float); } + int size_of_double() { return sizeof(double); } + int size_of_pointer() { return sizeof(void*); } +") + +(define-c int (size-of-int8_t size_of_int8_t) ()) +(define-c int (size-of-uint8_t size_of_uint8_t) ()) +(define-c int (size-of-int16_t size_of_int16_t) ()) +(define-c int (size-of-uint16_t size_of_uint16_t) ()) +(define-c int (size-of-int32_t size_of_int32_t) ()) +(define-c int (size-of-uint32_t size_of_uint32_t) ()) +(define-c int (size-of-int64_t size_of_int64_t) ()) +(define-c int (size-of-uint64_t size_of_uint64_t) ()) +(define-c int (size-of-char size_of_char) ()) +(define-c int (size-of-unsigned-char size_of_unsigned_char) ()) +(define-c int (size-of-short size_of_short) ()) +(define-c int (size-of-unsigned-short size_of_unsigned_short) ()) +(define-c int (size-of-int size_of_int) ()) +(define-c int (size-of-unsigned-int size_of_unsigned_int) ()) +(define-c int (size-of-long size_of_long) ()) +(define-c int (size-of-unsigned-long size_of_unsigned_long) ()) +(define-c int (size-of-float size_of_float) ()) +(define-c int (size-of-double size_of_double) ()) +(define-c int (size-of-pointer size_of_pointer) ()) + +;; c-type-align +(c-declare " + int align_of_int8_t() { return _Alignof(int8_t); } + int align_of_uint8_t() { return _Alignof(uint8_t); } + int align_of_int16_t() { return _Alignof(int16_t); } + int align_of_uint16_t() { return _Alignof(uint16_t); } + int align_of_int32_t() { return _Alignof(int32_t); } + int align_of_uint32_t() { return _Alignof(uint32_t); } + int align_of_int64_t() { return _Alignof(int64_t); } + int align_of_uint64_t() { return _Alignof(uint64_t); } + int align_of_char() { return _Alignof(char); } + int align_of_unsigned_char() { return _Alignof(unsigned char); } + int align_of_short() { return _Alignof(short); } + int align_of_unsigned_short() { return _Alignof(unsigned short); } + int align_of_int() { return _Alignof(int); } + int align_of_unsigned_int() { return _Alignof(unsigned int); } + int align_of_long() { return _Alignof(long); } + int align_of_unsigned_long() { return _Alignof(unsigned long); } + int align_of_float() { return _Alignof(float); } + int align_of_double() { return _Alignof(double); } + int align_of_pointer() { return _Alignof(void*); } +") + +(define-c int (align-of-int8_t align_of_int8_t) ()) +(define-c int (align-of-uint8_t align_of_uint8_t) ()) +(define-c int (align-of-int16_t align_of_int16_t) ()) +(define-c int (align-of-uint16_t align_of_uint16_t) ()) +(define-c int (align-of-int32_t align_of_int32_t) ()) +(define-c int (align-of-uint32_t align_of_uint32_t) ()) +(define-c int (align-of-int64_t align_of_int64_t) ()) +(define-c int (align-of-uint64_t align_of_uint64_t) ()) +(define-c int (align-of-char align_of_char) ()) +(define-c int (align-of-unsigned-char align_of_unsigned_char) ()) +(define-c int (align-of-short align_of_short) ()) +(define-c int (align-of-unsigned-short align_of_unsigned_short) ()) +(define-c int (align-of-int align_of_int) ()) +(define-c int (align-of-unsigned-int align_of_unsigned_int) ()) +(define-c int (align-of-long align_of_long) ()) +(define-c int (align-of-unsigned-long align_of_unsigned_long) ()) +(define-c int (align-of-float align_of_float) ()) +(define-c int (align-of-double align_of_double) ()) +(define-c int (align-of-pointer align_of_pointer) ()) + +;; shared-object-load +(define-c-const int (RTLD-NOW "RTLD_NOW")) +(define-c (maybe-null pointer void*) dlopen (string int)) +(define-c (maybe-null pointer void*) dlerror ()) + +(c-declare "sexp is_pointer(struct sexp_struct* object) { if(sexp_cpointerp(object)) { return SEXP_TRUE; } else { return SEXP_FALSE; } }") +(define-c sexp (pointer? is_pointer) (sexp)) + +(c-declare "void c_bytevector_u8_set(void* pointer, int offset, uint8_t value) { *(uint8_t*)((uint8_t*)pointer + offset) = value; }") +(define-c void (c-bytevector-u8-set! c_bytevector_u8_set) ((maybe-null pointer void*) int uint8_t)) + +(c-declare "uint8_t c_bytevector_u8_ref (void* pointer, int offset) { return *(uint8_t*)((uint8_t*)pointer + offset); }") +(define-c uint8_t (c-bytevector-u8-ref c_bytevector_u8_ref) ((maybe-null pointer void*) int)) + +(c-declare "void c_bytevector_pointer_set (void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }") +(define-c void (c-bytevector-pointer-set! c_bytevector_pointer_set) ((pointer void*) int (maybe-null pointer void*))) + +(c-declare "void* c_bytevector_pointer_ref (void* pointer, int offset) { char* p = (char*)pointer + offset; return (void*)*(char**)p;}") +(define-c (maybe-null pointer void*) (c-bytevector-pointer-ref c_bytevector_pointer_ref) ((maybe-null pointer void*) int)) + +(c-declare "ffi_cif cif;") +(define-c (maybe-null pointer void*) dlsym ((maybe-null pointer void*) string)) + +(define-c-const int (FFI-OK "FFI_OK")) +(c-declare + "void* internal_ffi_call( + unsigned int nargs, + unsigned int rtype, + unsigned int atypes[], + void* fn, + unsigned int rvalue_size, + struct sexp_struct* avalues[]) + { + ffi_type* c_atypes[nargs]; + void* c_avalues[nargs]; + + int8_t vals1[nargs]; + uint8_t vals2[nargs]; + int16_t vals3[nargs]; + uint16_t vals4[nargs]; + int32_t vals5[nargs]; + uint32_t vals6[nargs]; + int64_t vals7[nargs]; + uint64_t vals8[nargs]; + char vals9[nargs]; + unsigned char vals10[nargs]; + short vals11[nargs]; + unsigned short vals12[nargs]; + int vals13[nargs]; + unsigned int vals14[nargs]; + long vals15[nargs]; + unsigned long vals16[nargs]; + float vals17[nargs]; + double vals18[nargs]; + void* vals20[nargs]; + + //printf(\"nargs: %i\\n\", nargs); + for(int i = 0; i < nargs; i++) { + //printf(\"i: %i\\n\", i); + void* arg = NULL; + switch(atypes[i]) { + case 1: + c_atypes[i] = &ffi_type_sint8; + vals1[i] = (int8_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals1[i]; + break; + case 2: + c_atypes[i] = &ffi_type_uint8; + vals2[i] = (uint8_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals2[i]; + break; + case 3: + c_atypes[i] = &ffi_type_sint16; + vals3[i] = (int16_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals3[i]; + break; + case 4: + c_atypes[i] = &ffi_type_uint16; + vals4[i] = (uint16_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals4[i]; + break; + case 5: + c_atypes[i] = &ffi_type_sint32; + vals5[i] = (int32_t)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals5[i]; + break; + case 6: + c_atypes[i] = &ffi_type_uint32; + vals6[i] = (uint32_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals6[i]; + break; + case 7: + c_atypes[i] = &ffi_type_sint64; + vals7[i] = (int64_t) sexp_sint_value(avalues[i]); + c_avalues[i] = &vals7[i]; + break; + case 8: + c_atypes[i] = &ffi_type_uint64; + vals8[i] = (uint64_t)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals8[i]; + break; + case 9: + c_atypes[i] = &ffi_type_schar; + vals9[i] = (char)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals9[i]; + break; + case 10: + c_atypes[i] = &ffi_type_uchar; + vals10[i] = (unsigned char)sexp_uint_value(avalues[i]); + break; + case 11: + c_atypes[i] = &ffi_type_sshort; + vals11[i] = (short)sexp_sint_value(avalues[i]); + break; + case 12: + c_atypes[i] = &ffi_type_ushort; + vals12[i] = (unsigned short)sexp_uint_value(avalues[i]); + break; + case 13: + c_atypes[i] = &ffi_type_sint; + vals13[i] = (int)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals13[i]; + break; + case 14: + c_atypes[i] = &ffi_type_uint; + vals14[i] = (unsigned int)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals14[i]; + break; + case 15: + c_atypes[i] = &ffi_type_slong; + vals15[i] = (long)sexp_sint_value(avalues[i]); + c_avalues[i] = &vals15[i]; + break; + case 16: + c_atypes[i] = &ffi_type_ulong; + vals16[i] = (unsigned long)sexp_uint_value(avalues[i]); + c_avalues[i] = &vals16[i]; + break; + case 17: + c_atypes[i] = &ffi_type_float; + vals17[i] = (float)sexp_flonum_value(avalues[i]); + c_avalues[i] = &vals17[i]; + break; + case 18: + c_atypes[i] = &ffi_type_double; + vals18[i] = (double)sexp_flonum_value(avalues[i]); + c_avalues[i] = &vals18[i]; + break; + case 19: + c_atypes[i] = &ffi_type_void; + arg = NULL; + c_avalues[i] = NULL; + break; + case 20: + c_atypes[i] = &ffi_type_pointer; + if(sexp_cpointerp(avalues[i])) { + vals20[i] = sexp_cpointer_value(avalues[i]); + } else { + vals20[i] = NULL; + } + c_avalues[i] = &vals20[i]; + break; + default: + printf(\"Undefined argument type integer: %i, index: %i\\n\", atypes[i], i); + //c_avalues[i] = sexp_cpointer_value(avalues[i]); + break; + } + } + + ffi_type* c_rtype = &ffi_type_void; + switch(rtype) { + case 1: c_rtype = &ffi_type_sint8; break; + case 2: c_rtype = &ffi_type_uint8; break; + case 3: c_rtype = &ffi_type_sint16; break; + case 4: c_rtype = &ffi_type_uint16; break; + case 5: c_rtype = &ffi_type_sint32; break; + case 6: c_rtype = &ffi_type_uint32; break; + case 7: c_rtype = &ffi_type_sint64; break; + case 8: c_rtype = &ffi_type_uint64; break; + case 9: c_rtype = &ffi_type_schar; break; + case 10: c_rtype = &ffi_type_uchar; break; + case 11: c_rtype = &ffi_type_sshort; break; + case 12: c_rtype = &ffi_type_ushort; break; + case 13: c_rtype = &ffi_type_sint; break; + case 14: c_rtype = &ffi_type_uint; break; + case 15: c_rtype = &ffi_type_slong; break; + case 16: c_rtype = &ffi_type_ulong; break; + case 17: c_rtype = &ffi_type_float; break; + case 18: c_rtype = &ffi_type_double; break; + case 19: c_rtype = &ffi_type_void; break; + case 20: c_rtype = &ffi_type_pointer; break; + default: + printf(\"Undefined return type: %i\\n\", rtype); + c_rtype = &ffi_type_pointer; + break; + } + + int r = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, c_rtype, c_atypes); + + void* rvalue = malloc(rvalue_size); + ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues); + return rvalue; + }") +(define-c (maybe-null pointer void*) + (internal-ffi-call internal_ffi_call) + (unsigned-int + unsigned-int + (array unsigned-int) + (maybe-null pointer void*) + unsigned-int + (array sexp))) + +(c-declare + "void* scheme_procedure_to_pointer(sexp proc) { + if(sexp_procedurep(proc) == 1) { + return 0; //&sexp_unbox_fixnum(proc); + } else { + printf(\"NOT A FUNCTION\\n\"); + } + return (void*)proc; + }") +(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp)) diff --git a/foreign/c/chibi-scheme-primitives.c b/foreign/c/chibi-scheme-primitives.c new file mode 100644 index 0000000..acae2cb --- /dev/null +++ b/foreign/c/chibi-scheme-primitives.c @@ -0,0 +1,3 @@ +/* Automatically generated by chibi-ffi; version: 0.5 */ + +#include diff --git a/foreign/c/chicken-primitives.scm b/foreign/c/chicken-primitives.scm new file mode 100644 index 0000000..987861c --- /dev/null +++ b/foreign/c/chicken-primitives.scm @@ -0,0 +1,198 @@ +(define (primitives-init set-procedure get-procedure) #t) + +(define type->native-type ; Chicken has this procedure in three places + (lambda (type) + (cond ((equal? type 'i8) 'byte) + ((equal? type 'u8) 'unsigned-byte) + ((equal? type 'i16) 'short) + ((equal? type 'u16) 'unsigned-short) + ((equal? type 'i32) 'integer32) + ((equal? type 'u32) 'unsigned-integer32) + ((equal? type 'i64) 'integer64) + ((equal? type 'u64) 'unsigned-integer64) + ((equal? type 'char) 'char) + ((equal? type 'uchar) 'unsigned-char) + ((equal? type 'short) 'short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'uint) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'ulong) '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 'i8) 'byte) + ((equal? type 'u8) 'unsigned-byte) + ((equal? type 'i16) 'short) + ((equal? type 'u16) 'unsigned-short) + ((equal? type 'i32) 'integer32) + ((equal? type 'u32) 'unsigned-integer32) + ((equal? type 'i64) 'integer64) + ((equal? type 'u64) 'unsigned-integer64) + ((equal? type 'char) 'char) + ((equal? type 'uchar) 'unsigned-char) + ((equal? type 'short) 'short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'uint) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'ulong) '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 'i8) 'byte) + ((equal? type 'u8) 'unsigned-byte) + ((equal? type 'i16) 'short) + ((equal? type 'u16) 'unsigned-short) + ((equal? type 'i32) 'integer32) + ((equal? type 'u32) 'unsigned-integer32) + ((equal? type 'i64) 'integer64) + ((equal? type 'u64) 'unsigned-integer64) + ((equal? type 'char) 'char) + ((equal? type 'uchar) 'unsigned-char) + ((equal? type 'short) 'short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'uint) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'ulong) '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 'i8) (foreign-value "sizeof(int8_t)" int)) + ((equal? type 'u8) (foreign-value "sizeof(uint8_t)" int)) + ((equal? type 'i16) (foreign-value "sizeof(int16_t)" int)) + ((equal? type 'u16) (foreign-value "sizeof(uint16_t)" int)) + ((equal? type 'i32) (foreign-value "sizeof(int32_t)" int)) + ((equal? type 'u32) (foreign-value "sizeof(uint32_t)" int)) + ((equal? type 'i64) (foreign-value "sizeof(int64_t)" int)) + ((equal? type 'u64) (foreign-value "sizeof(uint64_t)" int)) + ((equal? type 'char) (foreign-value "sizeof(char)" int)) + ((equal? type 'uchar) (foreign-value "sizeof(unsigned char)" int)) + ((equal? type 'short) (foreign-value "sizeof(short)" int)) + ((equal? type 'ushort) (foreign-value "sizeof(unsigned short)" int)) + ((equal? type 'int) (foreign-value "sizeof(int)" int)) + ((equal? type 'uint) (foreign-value "sizeof(unsigned int)" int)) + ((equal? type 'long) (foreign-value "sizeof(long)" int)) + ((equal? type 'ulong) (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 align-of-type + (lambda (type) + (cond ((equal? type 'i8) (foreign-value "_Alignof(int8_t)" int)) + ((equal? type 'u8) (foreign-value "_Alignof(uint8_t)" int)) + ((equal? type 'i16) (foreign-value "_Alignof(int16_t)" int)) + ((equal? type 'u16) (foreign-value "_Alignof(uint16_t)" int)) + ((equal? type 'i32) (foreign-value "_Alignof(int32_t)" int)) + ((equal? type 'u32) (foreign-value "_Alignof(uint32_t)" int)) + ((equal? type 'i64) (foreign-value "_Alignof(int64_t)" int)) + ((equal? type 'u64) (foreign-value "_Alignof(uint64_t)" int)) + ((equal? type 'char) (foreign-value "_Alignof(char)" int)) + ((equal? type 'uchar) (foreign-value "_Alignof(unsigned char)" int)) + ((equal? type 'short) (foreign-value "_Alignof(short)" int)) + ((equal? type 'ushort) (foreign-value "_Alignof(unsigned short)" int)) + ((equal? type 'int) (foreign-value "_Alignof(int)" int)) + ((equal? type 'uint) (foreign-value "_Alignof(unsigned int)" int)) + ((equal? type 'long) (foreign-value "_Alignof(long)" int)) + ((equal? type 'ulong) (foreign-value "_Alignof(unsigned long)" int)) + ((equal? type 'float) (foreign-value "_Alignof(float)" int)) + ((equal? type 'double) (foreign-value "_Alignof(double)" int)) + ((equal? type 'pointer) (foreign-value "_Alignof(void*)" int)) + ((equal? type 'string) (foreign-value "_Alignof(void*)" int)) + ((equal? type 'callback) (foreign-value "_Alignof(void*)" int))))) + +(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-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 (make-c-null) (foreign-value "NULL" c-pointer)) + +(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))))) diff --git a/foreign/c/chicken-primitives.sld b/foreign/c/chicken-primitives.sld new file mode 100644 index 0000000..a52c740 --- /dev/null +++ b/foreign/c/chicken-primitives.sld @@ -0,0 +1,35 @@ +(define-library + (foreign c chicken-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (chicken base) + (chicken foreign) + (chicken locative) + (chicken syntax) + (chicken memory) + (chicken random)) + (export primitives-init + size-of-type + align-of-type + shared-object-load + define-c-procedure + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null + c-null? + ;; Chicken specific + foreign-declare + foreign-safe-lambda + void + pointer? + foreign-declare + address->pointer + pointer->address) + (include "chicken-primitives.scm")) diff --git a/foreign/c/cyclone-primitives.c b/foreign/c/cyclone-primitives.c new file mode 100644 index 0000000..bbbee12 --- /dev/null +++ b/foreign/c/cyclone-primitives.c @@ -0,0 +1,2533 @@ +/** + ** This file was automatically generated by the Cyclone scheme compiler + ** http://justinethier.github.io/cyclone/ + ** + ** (c) 2014-2024 Justin Ethier + ** Version 0.37.0 + ** + **/ + +#define closcall1(td, clo, buf) \ +if (obj_is_not_closure(clo)) { \ + Cyc_apply(td, clo, 1, buf ); \ +} else { \ + ((clo)->fn)(td, clo, 1, buf); \ +;\ +} +#define return_closcall1(td, clo,a1) { \ + char top; \ + object buf[1]; buf[0] = a1;\ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + GC(td, clo, buf, 1); \ + return; \ + } else {\ + closcall1(td, (closure) (clo), buf); \ + return;\ + } \ +} + +#define continue_or_gc1(td, clo,a1) { \ + char *top = alloca(sizeof(char)); \ + if (stack_overflow(top, (((gc_thread_data *)data)->stack_limit))) { \ + object buf[1]; buf[0] = a1;\ + GC(td, clo, buf, 1); \ + return; \ + } else {\ + continue;\ + } \ +} + +#define return_direct1(td, _fn,a1) { \ + char top; \ + object buf[1]; buf[0] = a1; \ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + mclosure0(c1, (function_type) _fn); \ + GC(td, &c1, buf, 1); \ + return; \ + } else { \ + (_fn)(td, (closure)_fn, 1, buf); \ + }} + +#define return_direct_with_clo1(td, clo, _fn,a1) { \ + char top; \ + object buf[1]; buf[0] = a1;\ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + GC(td, clo, buf, 1); \ + return; \ + } else { \ + (_fn)(td, (closure)(clo), 1, buf); \ + }} + +#define closcall2(td, clo, buf) \ +if (obj_is_not_closure(clo)) { \ + Cyc_apply(td, clo, 2, buf ); \ +} else { \ + ((clo)->fn)(td, clo, 2, buf); \ +;\ +} +#define return_closcall2(td, clo,a1,a2) { \ + char top; \ + object buf[2]; buf[0] = a1;buf[1] = a2;\ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + GC(td, clo, buf, 2); \ + return; \ + } else {\ + closcall2(td, (closure) (clo), buf); \ + return;\ + } \ +} + +#define continue_or_gc2(td, clo,a1,a2) { \ + char *top = alloca(sizeof(char)); \ + if (stack_overflow(top, (((gc_thread_data *)data)->stack_limit))) { \ + object buf[2]; buf[0] = a1;buf[1] = a2;\ + GC(td, clo, buf, 2); \ + return; \ + } else {\ + continue;\ + } \ +} + +#define return_direct2(td, _fn,a1,a2) { \ + char top; \ + object buf[2]; buf[0] = a1;buf[1] = a2; \ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + mclosure0(c1, (function_type) _fn); \ + GC(td, &c1, buf, 2); \ + return; \ + } else { \ + (_fn)(td, (closure)_fn, 2, buf); \ + }} + +#define return_direct_with_clo2(td, clo, _fn,a1,a2) { \ + char top; \ + object buf[2]; buf[0] = a1;buf[1] = a2;\ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + GC(td, clo, buf, 2); \ + return; \ + } else { \ + (_fn)(td, (closure)(clo), 2, buf); \ + }} + +#define closcall3(td, clo, buf) \ +if (obj_is_not_closure(clo)) { \ + Cyc_apply(td, clo, 3, buf ); \ +} else { \ + ((clo)->fn)(td, clo, 3, buf); \ +;\ +} +#define return_closcall3(td, clo,a1,a2,a3) { \ + char top; \ + object buf[3]; buf[0] = a1;buf[1] = a2;buf[2] = a3;\ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + GC(td, clo, buf, 3); \ + return; \ + } else {\ + closcall3(td, (closure) (clo), buf); \ + return;\ + } \ +} + +#define continue_or_gc3(td, clo,a1,a2,a3) { \ + char *top = alloca(sizeof(char)); \ + if (stack_overflow(top, (((gc_thread_data *)data)->stack_limit))) { \ + object buf[3]; buf[0] = a1;buf[1] = a2;buf[2] = a3;\ + GC(td, clo, buf, 3); \ + return; \ + } else {\ + continue;\ + } \ +} + +#define return_direct3(td, _fn,a1,a2,a3) { \ + char top; \ + object buf[3]; buf[0] = a1;buf[1] = a2;buf[2] = a3; \ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + mclosure0(c1, (function_type) _fn); \ + GC(td, &c1, buf, 3); \ + return; \ + } else { \ + (_fn)(td, (closure)_fn, 3, buf); \ + }} + +#define return_direct_with_clo3(td, clo, _fn,a1,a2,a3) { \ + char top; \ + object buf[3]; buf[0] = a1;buf[1] = a2;buf[2] = a3;\ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + GC(td, clo, buf, 3); \ + return; \ + } else { \ + (_fn)(td, (closure)(clo), 3, buf); \ + }} + +#define closcall4(td, clo, buf) \ +if (obj_is_not_closure(clo)) { \ + Cyc_apply(td, clo, 4, buf ); \ +} else { \ + ((clo)->fn)(td, clo, 4, buf); \ +;\ +} +#define return_closcall4(td, clo,a1,a2,a3,a4) { \ + char top; \ + object buf[4]; buf[0] = a1;buf[1] = a2;buf[2] = a3;buf[3] = a4;\ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + GC(td, clo, buf, 4); \ + return; \ + } else {\ + closcall4(td, (closure) (clo), buf); \ + return;\ + } \ +} + +#define continue_or_gc4(td, clo,a1,a2,a3,a4) { \ + char *top = alloca(sizeof(char)); \ + if (stack_overflow(top, (((gc_thread_data *)data)->stack_limit))) { \ + object buf[4]; buf[0] = a1;buf[1] = a2;buf[2] = a3;buf[3] = a4;\ + GC(td, clo, buf, 4); \ + return; \ + } else {\ + continue;\ + } \ +} + +#define return_direct4(td, _fn,a1,a2,a3,a4) { \ + char top; \ + object buf[4]; buf[0] = a1;buf[1] = a2;buf[2] = a3;buf[3] = a4; \ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + mclosure0(c1, (function_type) _fn); \ + GC(td, &c1, buf, 4); \ + return; \ + } else { \ + (_fn)(td, (closure)_fn, 4, buf); \ + }} + +#define return_direct_with_clo4(td, clo, _fn,a1,a2,a3,a4) { \ + char top; \ + object buf[4]; buf[0] = a1;buf[1] = a2;buf[2] = a3;buf[3] = a4;\ + if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \ + GC(td, clo, buf, 4); \ + return; \ + } else { \ + (_fn)(td, (closure)(clo), 4, buf); \ + }} + +#include "cyclone/types.h" +object __glo_lib_91init_117foreigncprimitives_19191cyclone_foreign_c_primitives_91cyclone = NULL; +object __glo_c_91bytevector_91u8_91ref_foreign_c_primitives_91cyclone = NULL; +object __glo_c_91bytevector_91u8_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_c_91bytevector_91pointer_91ref_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91double_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91float_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91unsigned_91long_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91long_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91unsigned_91int_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91int_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91unsigned_91short_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91short_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91char_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91uint64_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91int64_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91uint32_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91int32_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91uint16_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91int16_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91uint8_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91int8_91get_foreign_c_primitives_91cyclone = NULL; +object __glo_c_91bytevector_91pointer_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91double_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91float_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91unsigned_91long_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91long_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91unsigned_91int_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91int_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91unsigned_91short_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91short_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91char_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91uint64_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91int64_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91uint32_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91int32_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91uint16_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91int16_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91uint8_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91int8_91set_67_foreign_c_primitives_91cyclone = NULL; +object __glo_shared_91object_91load_foreign_c_primitives_91cyclone = NULL; +object __glo_define_91c_91library_foreign_c_primitives_91cyclone = NULL; +object __glo_pointer_91address_foreign_c_primitives_91cyclone = NULL; +object __glo_align_91of_91type_foreign_c_primitives_91cyclone = NULL; +object __glo_size_91of_91type_foreign_c_primitives_91cyclone = NULL; +object __glo_define_91c_91callback_foreign_c_primitives_91cyclone = NULL; +object __glo_define_91c_91procedure_foreign_c_primitives_91cyclone = NULL; +object __glo_c_91bytevector_127_foreign_c_primitives_91cyclone = NULL; +extern object __glo_member_scheme_base; +extern object __glo_assoc_scheme_base; +extern object __glo_cons_91source_scheme_base; +extern object __glo_syntax_91rules_scheme_base; +extern object __glo_letrec_85_scheme_base; +extern object __glo_guard_scheme_base; +extern object __glo_guard_91aux_scheme_base; +extern object __glo_define_91record_91type_scheme_base; +extern object __glo_record_127_scheme_base; +extern object __glo_is_91a_127_scheme_base; +extern object __glo_register_91simple_91type_scheme_base; +extern object __glo_make_91type_91predicate_scheme_base; +extern object __glo_make_91constructor_scheme_base; +extern object __glo_make_91constructor_95args_scheme_base; +extern object __glo_make_91getter_scheme_base; +extern object __glo_make_91setter_scheme_base; +extern object __glo_slot_91ref_scheme_base; +extern object __glo_slot_91set_67_scheme_base; +extern object __glo_type_91slot_91offset_scheme_base; +extern object __glo_make_91record_91marker_scheme_base; +extern object __glo_receive_scheme_base; +extern object __glo_abs_scheme_base; +extern object __glo_max_scheme_base; +extern object __glo_min_scheme_base; +extern object __glo_modulo_scheme_base; +extern object __glo_floor_91remainder_scheme_base; +extern object __glo_even_127_scheme_base; +extern object __glo_exact_91integer_127_scheme_base; +extern object __glo_exact_91integer_91sqrt_scheme_base; +extern object __glo_exact_127_scheme_base; +extern object __glo_inexact_127_scheme_base; +extern object __glo_odd_127_scheme_base; +extern object __glo_complex_127_scheme_base; +extern object __glo_rational_127_scheme_base; +extern object __glo_bignum_127_scheme_base; +extern object __glo_gcd_scheme_base; +extern object __glo_lcm_scheme_base; +extern object __glo_quotient_scheme_base; +extern object __glo_remainder_scheme_base; +extern object __glo_truncate_91quotient_scheme_base; +extern object __glo_truncate_91remainder_scheme_base; +extern object __glo_truncate_95_scheme_base; +extern object __glo_floor_91quotient_scheme_base; +extern object __glo_floor_91remainder_scheme_base; +extern object __glo_floor_95_scheme_base; +extern object __glo_square_scheme_base; +extern object __glo_expt_scheme_base; +extern object __glo_call_91with_91current_91continuation_scheme_base; +extern object __glo_call_95cc_scheme_base; +extern object __glo_call_91with_91values_scheme_base; +extern object __glo_dynamic_91wind_scheme_base; +extern object __glo_values_scheme_base; +extern object __glo_char_123_127_scheme_base; +extern object __glo_char_121_127_scheme_base; +extern object __glo_char_125_127_scheme_base; +extern object __glo_char_121_123_127_scheme_base; +extern object __glo_char_125_123_127_scheme_base; +extern object __glo_string_123_127_scheme_base; +extern object __glo_string_121_127_scheme_base; +extern object __glo_string_121_123_127_scheme_base; +extern object __glo_string_125_127_scheme_base; +extern object __glo_string_125_123_127_scheme_base; +extern object __glo_fast_91string_123_127_scheme_base; +extern object __glo_fast_91string_121_127_scheme_base; +extern object __glo_fast_91string_121_123_127_scheme_base; +extern object __glo_fast_91string_125_127_scheme_base; +extern object __glo_fast_91string_125_123_127_scheme_base; +extern object __glo_foldl_scheme_base; +extern object __glo_foldr_scheme_base; +extern object __glo_not_scheme_base; +extern object __glo_list_127_scheme_base; +extern object __glo_zero_127_scheme_base; +extern object __glo_positive_127_scheme_base; +extern object __glo_negative_127_scheme_base; +extern object __glo_append_scheme_base; +extern object __glo__list_scheme_base; +extern object __glo_make_91list_scheme_base; +extern object __glo_list_91copy_scheme_base; +extern object __glo_map_scheme_base; +extern object __glo_Cyc_91map_91loop_911_scheme_base; +extern object __glo_Cyc_91map_91loop_912_scheme_base; +extern object __glo_Cyc_91for_91each_91loop_911_scheme_base; +extern object __glo_Cyc_91for_91each_91loop_912_scheme_base; +extern object __glo_for_91each_scheme_base; +extern object __glo_list_91tail_scheme_base; +extern object __glo_list_91ref_scheme_base; +extern object __glo_list_91set_67_scheme_base; +extern object __glo_reverse_scheme_base; +extern object __glo_boolean_123_127_scheme_base; +extern object __glo_symbol_123_127_scheme_base; +extern object __glo_Cyc_91obj_123_127_scheme_base; +extern object __glo_vector_scheme_base; +extern object __glo_vector_91append_scheme_base; +extern object __glo_vector_91copy_scheme_base; +extern object __glo_vector_91copy_67_scheme_base; +extern object __glo_vector_91fill_67_scheme_base; +extern object __glo_vector_91_125list_scheme_base; +extern object __glo_vector_91_125string_scheme_base; +extern object __glo_vector_91map_scheme_base; +extern object __glo_vector_91for_91each_scheme_base; +extern object __glo_make_91string_scheme_base; +extern object __glo_string_scheme_base; +extern object __glo_string_91copy_scheme_base; +extern object __glo_string_91copy_67_scheme_base; +extern object __glo_string_91fill_67_scheme_base; +extern object __glo_string_91_125list_scheme_base; +extern object __glo_string_91_125vector_scheme_base; +extern object __glo_string_91map_scheme_base; +extern object __glo_string_91for_91each_scheme_base; +extern object __glo_make_91parameter_scheme_base; +extern object __glo_current_91output_91port_scheme_base; +extern object __glo_current_91input_91port_scheme_base; +extern object __glo_current_91error_91port_scheme_base; +extern object __glo_call_91with_91port_scheme_base; +extern object __glo_error_91object_127_scheme_base; +extern object __glo_error_91object_91message_scheme_base; +extern object __glo_error_91object_91irritants_scheme_base; +extern object __glo_error_95loc_scheme_base; +extern object __glo_error_scheme_base; +extern object __glo_raise_scheme_base; +extern object __glo_raise_91continuable_scheme_base; +extern object __glo_with_91handler_scheme_base; +extern object __glo_with_91exception_91handler_scheme_base; +extern object __glo_Cyc_91add_91exception_91handler_scheme_base; +extern object __glo_Cyc_91remove_91exception_91handler_scheme_base; +extern object __glo_newline_scheme_base; +extern object __glo_write_91char_scheme_base; +extern object __glo_write_91string_scheme_base; +extern object __glo_write_91string_911_scheme_base; +extern object __glo_write_91string_912_scheme_base; +extern object __glo_flush_91output_91port_scheme_base; +extern object __glo_char_91ready_127_scheme_base; +extern object __glo_peek_91char_scheme_base; +extern object __glo_read_91char_scheme_base; +extern object __glo_read_91line_scheme_base; +extern object __glo_read_91string_scheme_base; +extern object __glo_input_91port_127_scheme_base; +extern object __glo_output_91port_127_scheme_base; +extern object __glo_input_91port_91open_127_scheme_base; +extern object __glo_output_91port_91open_127_scheme_base; +extern object __glo_get_91output_91string_scheme_base; +extern object __glo_open_91output_91string_scheme_base; +extern object __glo_open_91input_91string_scheme_base; +extern object __glo_get_91output_91bytevector_scheme_base; +extern object __glo_open_91input_91bytevector_scheme_base; +extern object __glo_open_91output_91bytevector_scheme_base; +extern object __glo_features_scheme_base; +extern object __glo_Cyc_91add_91feature_67_scheme_base; +extern object __glo_Cyc_91version_scheme_base; +extern object __glo_any_scheme_base; +extern object __glo_every_scheme_base; +extern object __glo_and_scheme_base; +extern object __glo_or_scheme_base; +extern object __glo_let_scheme_base; +extern object __glo_let_85_scheme_base; +extern object __glo_letrec_scheme_base; +extern object __glo_let_85_91values_scheme_base; +extern object __glo_let_91values_scheme_base; +extern object __glo_define_91values_scheme_base; +extern object __glo_begin_scheme_base; +extern object __glo__case_scheme_base; +extern object __glo_cond_scheme_base; +extern object __glo_cond_91expand_scheme_base; +extern object __glo__do_scheme_base; +extern object __glo_when_scheme_base; +extern object __glo_unless_scheme_base; +extern object __glo_quasiquote_scheme_base; +extern object __glo_floor_scheme_base; +extern object __glo_ceiling_scheme_base; +extern object __glo_truncate_scheme_base; +extern object __glo_round_scheme_base; +extern object __glo_exact_scheme_base; +extern object __glo_inexact_scheme_base; +extern object __glo_eof_91object_scheme_base; +extern object __glo__void_scheme_base; +extern object __glo_syntax_91error_scheme_base; +extern object __glo_bytevector_91copy_scheme_base; +extern object __glo_bytevector_91copy_67_scheme_base; +extern object __glo_utf8_91_125string_scheme_base; +extern object __glo_string_91_125utf8_scheme_base; +extern object __glo_denominator_scheme_base; +extern object __glo_numerator_scheme_base; +extern object __glo_parameterize_scheme_base; +extern object __glo_read_91bytevector_scheme_base; +extern object __glo_read_91bytevector_67_scheme_base; +extern object __glo_write_91bytevector_scheme_base; +extern object __glo_peek_91u8_scheme_base; +extern object __glo_read_91u8_scheme_base; +extern object __glo_write_91u8_scheme_base; +extern object __glo_binary_91port_127_scheme_base; +extern object __glo_textual_91port_127_scheme_base; +extern object __glo_rationalize_scheme_base; +extern object __glo_display_scheme_write; +extern object __glo_write_scheme_write; +extern object __glo_write_91shared_scheme_write; +extern object __glo_write_91simple_scheme_write; +extern object __glo_char_91alphabetic_127_scheme__char; +extern object __glo_char_91downcase_scheme__char; +extern object __glo_char_91foldcase_scheme__char; +extern object __glo_char_91lower_91case_127_scheme__char; +extern object __glo_char_91numeric_127_scheme__char; +extern object __glo_char_91upcase_scheme__char; +extern object __glo_char_91upper_91case_127_scheme__char; +extern object __glo_char_91whitespace_127_scheme__char; +extern object __glo_char_91ci_121_123_127_scheme__char; +extern object __glo_char_91ci_121_127_scheme__char; +extern object __glo_char_91ci_123_127_scheme__char; +extern object __glo_char_91ci_125_123_127_scheme__char; +extern object __glo_char_91ci_125_127_scheme__char; +extern object __glo_digit_91value_scheme__char; +extern object __glo_string_91upcase_scheme__char; +extern object __glo_string_91downcase_scheme__char; +extern object __glo_string_91foldcase_scheme__char; +extern object __glo_string_91ci_121_123_127_scheme__char; +extern object __glo_string_91ci_121_127_scheme__char; +extern object __glo_string_91ci_123_127_scheme__char; +extern object __glo_string_91ci_125_123_127_scheme__char; +extern object __glo_string_91ci_125_127_scheme__char; +extern object __glo_call_91with_91input_91file_scheme_file; +extern object __glo_call_91with_91output_91file_scheme_file; +extern object __glo_with_91input_91from_91file_scheme_file; +extern object __glo_with_91output_91to_91file_scheme_file; +extern object __glo_acos_scheme_inexact; +extern object __glo_asin_scheme_inexact; +extern object __glo_atan_scheme_inexact; +extern object __glo_cos_scheme_inexact; +extern object __glo_exp_scheme_inexact; +extern object __glo_finite_127_scheme_inexact; +extern object __glo_infinite_127_scheme_inexact; +extern object __glo_log_scheme_inexact; +extern object __glo_nan_127_scheme_inexact; +extern object __glo_sin_scheme_inexact; +extern object __glo_sqrt_scheme_inexact; +extern object __glo_tan_scheme_inexact; +extern object __glo_command_91line_scheme_process_91context; +extern object __glo_emergency_91exit_scheme_process_91context; +extern object __glo_get_91environment_91variable_scheme_process_91context; +extern object __glo_get_91environment_91variables_scheme_process_91context; +extern object __glo_opaque_127_cyclone_foreign; +extern object __glo_opaque_91null_127_cyclone_foreign; +extern object __glo_make_91opaque_cyclone_foreign; +extern object __glo_c_91code_cyclone_foreign; +extern object __glo_c_91value_cyclone_foreign; +extern object __glo_c_91define_cyclone_foreign; +extern object __glo_c_91_125scm_cyclone_foreign; +extern object __glo_scm_91_125c_cyclone_foreign; +extern object __glo_c_91define_91type_cyclone_foreign; +extern object __glo_prim_127_scheme_cyclone_primitives; +extern object __glo__85primitives_85_scheme_cyclone_primitives; +extern object __glo__85primitives_91num_91args_85_scheme_cyclone_primitives; +extern object __glo_prim_91call_127_scheme_cyclone_primitives; +extern object __glo_prim_91_125c_91func_scheme_cyclone_primitives; +extern object __glo_prim_91_125c_91func_91uses_91alloca_127_scheme_cyclone_primitives; +extern object __glo_prim_95data_91arg_127_scheme_cyclone_primitives; +extern object __glo_prim_95c_91var_91pointer_scheme_cyclone_primitives; +extern object __glo_prim_95c_91var_91assign_scheme_cyclone_primitives; +extern object __glo_prim_95cvar_127_scheme_cyclone_primitives; +extern object __glo_prim_117inline_91convert_91prim_91call_scheme_cyclone_primitives; +extern object __glo_prim_117check_91arg_91count_scheme_cyclone_primitives; +extern object __glo_prim_117mutates_127_scheme_cyclone_primitives; +extern object __glo_prim_117cont_127_scheme_cyclone_primitives; +extern object __glo_prim_117cont_95no_91args_127_scheme_cyclone_primitives; +extern object __glo_prim_117arg_91count_127_scheme_cyclone_primitives; +extern object __glo_prim_117allocates_91object_127_scheme_cyclone_primitives; +extern object __glo_prim_117immutable_91args_95result_127_scheme_cyclone_primitives; +extern object __glo_prim_117udf_127_scheme_cyclone_primitives; +extern object __glo_prim_117add_91udf_67_scheme_cyclone_primitives; +extern object __glo_prim_117func_91_125prim_scheme_cyclone_primitives; +extern object __glo_fast_91string_123_127_191_191inline_191_191_scheme_base; +extern object __glo_fast_91string_121_127_191_191inline_191_191_scheme_base; +extern object __glo_fast_91string_121_123_127_191_191inline_191_191_scheme_base; +extern object __glo_fast_91string_125_127_191_191inline_191_191_scheme_base; +extern object __glo_fast_91string_125_123_127_191_191inline_191_191_scheme_base; +extern object __glo__75write_91bytevector_191_191inline_191_191_scheme_base; +extern object __glo_not_191_191inline_191_191_scheme_base; +extern object __glo_list_127_191_191inline_191_191_scheme_base; +extern object __glo_zero_127_191_191inline_191_191_scheme_base; +extern object __glo_positive_127_191_191inline_191_191_scheme_base; +extern object __glo_negative_127_191_191inline_191_191_scheme_base; +extern object __glo_floor_191_191inline_191_191_scheme_base; +extern object __glo_ceiling_191_191inline_191_191_scheme_base; +extern object __glo_truncate_191_191inline_191_191_scheme_base; +extern object __glo_round_191_191inline_191_191_scheme_base; +extern object __glo_exact_191_191inline_191_191_scheme_base; +extern object __glo_inexact_191_191inline_191_191_scheme_base; +extern object __glo__191sqrt_191_191inline_191_191_scheme_base; +extern object __glo_exact_91integer_127_191_191inline_191_191_scheme_base; +extern object __glo_exact_127_191_191inline_191_191_scheme_base; +extern object __glo_complex_127_191_191inline_191_191_scheme_base; +extern object __glo_fixnum_127_191_191inline_191_191_scheme_base; +extern object __glo_quotient_191_191inline_191_191_scheme_base; +extern object __glo_square_191_191inline_191_191_scheme_base; +extern object __glo_eof_91object_191_191inline_191_191_scheme_base; +extern object __glo_void_191_191inline_191_191_scheme_base; +extern object __glo_make_91record_91marker_191_191inline_191_191_scheme_base; +#include "cyclone/runtime.h" +defsymbol(align_91of_91type); +defsymbol(c_91bytevector_91u8_91set_67); +defsymbol(c_91bytevector_91u8_91ref); +defsymbol(include_91c_91header); +defsymbol(headers); +defsymbol(shared_91object_91load); +defsymbol(scheme_91name); +defsymbol(define); +defsymbol(begin); +defsymbol(int8); +defsymbol(uint8); +defsymbol(int16); +defsymbol(uint16); +defsymbol(int32); +defsymbol(uint32); +defsymbol(int64); +defsymbol(uint64); +defsymbol(pointer); +defsymbol(_void); +defsymbol(callback); +defsymbol(c_91void); +defsymbol(opaque); +defsymbol(_double); +defsymbol(_float); +defsymbol(unsigned_91long); +defsymbol(_long); +defsymbol(unsigned_91int); +defsymbol(unsigned_91short); +defsymbol(_short); +defsymbol(unsigned_91char); +defsymbol(_char); +defsymbol(_int); +defsymbol(c_91define); +static void __lambda_55(void *data, object clo, int argc, object *args) ;/*closure _,object k_73652*/ +static void __lambda_56(void *data, object clo, int argc, object *args) ;/*object self_73704, object r_73654*/ +static void __lambda_57(void *data, object clo, int argc, object *args) ;/*object self_73705, object r_73655*/ +static void __lambda_94(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_93(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_92(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_91(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_90(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_89(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_88(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_87(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_86(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_85(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_84(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_83(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_82(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_81(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_80(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_79(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_78(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_77(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset)*/ +static void __lambda_76(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_75(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_74(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_73(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_72(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_71(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_70(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_69(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_68(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_67(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_66(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_65(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_64(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_63(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_62(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_61(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_60(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_59(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer, object offset, object value)*/ +static void __lambda_50(void *data, object clo, int argc, object *args) ;/*closure _,object k_73636, object expr_73397_73449, object rename_73398_73450, object compare_73399_73451*/ +static void __lambda_53(void *data, object clo, int argc, object *args) ;/*object self_73700, object k_73640, object header_73410_73454*/ +static void __lambda_54(void *data, object clo, int argc, object *args) ;/*object self_73701, object r_73643*/ +static void __lambda_51(void *data, object clo, int argc, object *args) ;/*object self_73702, object r_73639*/ +static void __lambda_52(void *data, object clo, int argc, object *args) ;/*object self_73703, object includes_73405_73453*/ +static void __lambda_32(void *data, object clo, int argc, object *args) ;/*closure _,object k_73589, object expr_73338_73355_73380_73432, object rename_73339_73356_73381_73433, object compare_73340_73357_73382_73434*/ +static void __lambda_33(void *data, object clo, int argc, object *args) ;/*object self_73683, object v_931_73346_73362_73384_73436*/ +static void __lambda_46(void *data, object clo, int argc, object *args) ;/*object self_73684, object tmp_73359_73361_73383_73435*/ +static void __lambda_49(void *data, object clo, int argc, object *args) ;/*object self_73685, object r_73590*/ +static void __lambda_47(void *data, object clo, int argc, object *args) ;/*object self_73686, object k_73592*/ +static void __lambda_48(void *data, object clo, int argc, object *args) ;/*object self_73687, object r_73593*/ +static void __lambda_34(void *data, object clo, int argc, object *args) ;/*object self_73688, object k_73595*/ +static void __lambda_35(void *data, object clo, int argc, object *args) ;/*object self_73689, object r_73610*/ +static void __lambda_36(void *data, object clo, int argc, object *args) ;/*object self_73690, object r_73625*/ +static void __lambda_37(void *data, object clo, int argc, object *args) ;/*object self_73691, object r_73628*/ +static void __lambda_38(void *data, object clo, int argc, object *args) ;/*object self_73692, object r_73626*/ +static void __lambda_39(void *data, object clo, int argc, object *args) ;/*object self_73693, object r_73613*/ +static void __lambda_40(void *data, object clo, int argc, object *args) ;/*object self_73694, object r_73619*/ +static void __lambda_41(void *data, object clo, int argc, object *args) ;/*object self_73695, object r_73620*/ +static void __lambda_42(void *data, object clo, int argc, object *args) ;/*object self_73696, object r_73616*/ +static void __lambda_43(void *data, object clo, int argc, object *args) ;/*object self_73697, object r_73614*/ +static void __lambda_44(void *data, object clo, int argc, object *args) ;/*object self_73698, object r_73611*/ +static void __lambda_45(void *data, object clo, int argc, object *args) ;/*object self_73699, object r_73609*/ +static void __lambda_58(void *data, object clo, int argc, object *args) ;/*(void *data, int argc, closure _, object k, object pointer)*/ +static void __lambda_31(void *data, object clo, int argc, object *args) ;/*closure _,object k_73546, object type_73162_73431*/ +static void __lambda_30(void *data, object clo, int argc, object *args) ;/*closure _,object k_73543, object scheme_91name_73158_73427, object return_91type_73159_73428, object argument_91types_73160_73429, object procedure_73161_73430*/ +static void __lambda_2(void *data, object clo, int argc, object *args) ;/*closure _,object k_73460, object expr_7367_73417, object rename_7368_73418, object compare_7369_73419*/ +static void __lambda_8(void *data, object clo, int argc, object *args) ;/*object self_73656, object k_73498, object type_7393_73426*/ +static void __lambda_9(void *data, object clo, int argc, object *args) ;/*object self_73657, object r_73499*/ +static void __lambda_10(void *data, object clo, int argc, object *args) ;/*object self_73658, object r_73500*/ +static void __lambda_11(void *data, object clo, int argc, object *args) ;/*object self_73659, object r_73501*/ +static void __lambda_12(void *data, object clo, int argc, object *args) ;/*object self_73660, object r_73502*/ +static void __lambda_13(void *data, object clo, int argc, object *args) ;/*object self_73661, object r_73503*/ +static void __lambda_14(void *data, object clo, int argc, object *args) ;/*object self_73662, object r_73504*/ +static void __lambda_15(void *data, object clo, int argc, object *args) ;/*object self_73663, object r_73505*/ +static void __lambda_16(void *data, object clo, int argc, object *args) ;/*object self_73664, object r_73506*/ +static void __lambda_17(void *data, object clo, int argc, object *args) ;/*object self_73665, object r_73507*/ +static void __lambda_18(void *data, object clo, int argc, object *args) ;/*object self_73666, object r_73508*/ +static void __lambda_19(void *data, object clo, int argc, object *args) ;/*object self_73667, object r_73509*/ +static void __lambda_20(void *data, object clo, int argc, object *args) ;/*object self_73668, object r_73510*/ +static void __lambda_21(void *data, object clo, int argc, object *args) ;/*object self_73669, object r_73511*/ +static void __lambda_22(void *data, object clo, int argc, object *args) ;/*object self_73670, object r_73512*/ +static void __lambda_23(void *data, object clo, int argc, object *args) ;/*object self_73671, object r_73513*/ +static void __lambda_24(void *data, object clo, int argc, object *args) ;/*object self_73672, object r_73514*/ +static void __lambda_25(void *data, object clo, int argc, object *args) ;/*object self_73673, object r_73515*/ +static void __lambda_26(void *data, object clo, int argc, object *args) ;/*object self_73674, object r_73516*/ +static void __lambda_27(void *data, object clo, int argc, object *args) ;/*object self_73675, object r_73517*/ +static void __lambda_28(void *data, object clo, int argc, object *args) ;/*object self_73676, object r_73518*/ +static void __lambda_29(void *data, object clo, int argc, object *args) ;/*object self_73677, object r_73519*/ +static void __lambda_3(void *data, object clo, int argc, object *args) ;/*object self_73678, object type_91_125native_91type_7372_73420*/ +static void __lambda_4(void *data, object clo, int argc, object *args) ;/*object self_73679, object c_91name_7378_73422*/ +static void __lambda_5(void *data, object clo, int argc, object *args) ;/*object self_73680, object return_91type_7381_73423*/ +static void __lambda_7(void *data, object clo, int argc, object *args) ;/*object self_73681, object argument_91types_7384_73424*/ +static void __lambda_6(void *data, object clo, int argc, object *args) ;/*object self_73682, object k_73477*/ +static void __lambda_1(void *data, object clo, int argc, object *args) ;/*closure _,object k_73457, object object_7366_73416*/ + +static void __lambda_55(void *data, object _, int argc, object *args) /* closure _,object k_73652 */ + { +object k_73652 = args[0]; + Cyc_st_add(data, "./foreign/c/cyclone-primitives.sld:lib-init:foreigncprimitives_91cyclone"); + +closureN_type c_731324; +object e_731336 [1]; +c_731324.hdr.mark = gc_color_red; + c_731324.hdr.grayed = 0; +c_731324.tag = closureN_tag; + c_731324.fn = (function_type)__lambda_56; +c_731324.num_args = 1; +c_731324.num_elements = 1; +c_731324.elements = (object *)e_731336; +c_731324.elements[0] = k_73652; + + +object c_731339 = global_set_cps_id(data,(closure)&c_731324,"__glo_align_91of_91type_foreign_c_primitives_91cyclone", __glo_align_91of_91type_foreign_c_primitives_91cyclone, __glo_size_91of_91type_foreign_c_primitives_91cyclone); +return_closcall1(data,(closure)&c_731324, c_731339);; +} + +static void __lambda_56(void *data, object self_73704, int argc, object *args) /* object self_73704, object r_73654 */ + { + + +closureN_type c_731326; +object e_731332 [1]; +c_731326.hdr.mark = gc_color_red; + c_731326.hdr.grayed = 0; +c_731326.tag = closureN_tag; + c_731326.fn = (function_type)__lambda_57; +c_731326.num_args = 1; +c_731326.num_elements = 1; +c_731326.elements = (object *)e_731332; +c_731326.elements[0] = ((closureN)self_73704)->elements[0]; + + +object c_731335 = global_set_cps_id(data,(closure)&c_731326,"__glo_c_91bytevector_91u8_91set_67_foreign_c_primitives_91cyclone", __glo_c_91bytevector_91u8_91set_67_foreign_c_primitives_91cyclone, __glo_pointer_91uint8_91set_67_foreign_c_primitives_91cyclone); +return_closcall1(data,(closure)&c_731326, c_731335);; +} + +static void __lambda_57(void *data, object self_73705, int argc, object *args) /* object self_73705, object r_73655 */ + { + + +object c_731331 = global_set_cps_id(data, ((closureN)self_73705)->elements[0],"__glo_c_91bytevector_91u8_91ref_foreign_c_primitives_91cyclone", __glo_c_91bytevector_91u8_91ref_foreign_c_primitives_91cyclone, __glo_pointer_91uint8_91get_foreign_c_primitives_91cyclone); +return_direct_with_clo1(data, ((closureN)self_73705)->elements[0], (((closure) ((closureN)self_73705)->elements[0])->fn), c_731331);; +} + +static void __lambda_94(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset)); + return_closcall1(data, k, &opq); } +static void __lambda_93(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];double* p = opaque_ptr(pointer) + obj_obj2int(offset); + alloca_double(d, *p); + return_closcall1(data, k, d); } +static void __lambda_92(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];float* p = opaque_ptr(pointer) + obj_obj2int(offset); + alloca_double(d, *p); + return_closcall1(data, k, d); } +static void __lambda_91(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_90(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];long* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_89(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_88(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];int* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_87(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_86(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];short* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_85(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];char* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_char2obj(*p)); } +static void __lambda_84(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_83(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_82(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_81(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_80(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_79(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_78(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_77(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + return_closcall1(data, k, obj_int2obj(*p)); } +static void __lambda_76(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];uintptr_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = (uintptr_t)&opaque_ptr(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_75(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];double* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = double_value(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_74(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];float* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = double_value(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_73(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_72(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];long* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_71(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_70(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];int* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_69(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_68(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];short* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_67(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];char* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2char(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_66(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_65(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_64(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_63(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_62(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_61(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_60(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_59(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];object offset = args[2];object value = args[3];int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset); + *p = obj_obj2int(value); + return_closcall1(data, k, make_boolean(boolean_t)); } +static void __lambda_50(void *data, object _, int argc, object *args) /* closure _,object k_73636, object expr_73397_73449, object rename_73398_73450, object compare_73399_73451 */ + { +object k_73636 = args[0]; object expr_73397_73449 = args[1]; + Cyc_st_add(data, "./foreign/c/cyclone-primitives.sld:shared-object-load"); + +closureN_type c_731257; +object e_731268 [2]; +c_731257.hdr.mark = gc_color_red; + c_731257.hdr.grayed = 0; +c_731257.tag = closureN_tag; + c_731257.fn = (function_type)__lambda_51; +c_731257.num_args = 1; +c_731257.num_elements = 2; +c_731257.elements = (object *)e_731268; +c_731257.elements[0] = expr_73397_73449; +c_731257.elements[1] = k_73636; + + +mmacro(c_731269, (function_type)__lambda_53);c_731269.num_args = 1; +return_direct_with_clo1(data,(closure)&c_731257,__lambda_51, &c_731269);; +} + +static void __lambda_53(void *data, object self_73700, int argc, object *args) /* object self_73700, object k_73640, object header_73410_73454 */ + { + object k_73640 = args[0]; object header_73410_73454 = args[1]; + +closureN_type c_731271; +object e_731280 [1]; +c_731271.hdr.mark = gc_color_red; + c_731271.hdr.grayed = 0; +c_731271.tag = closureN_tag; + c_731271.fn = (function_type)__lambda_54; +c_731271.num_args = 1; +c_731271.num_elements = 1; +c_731271.elements = (object *)e_731280; +c_731271.elements[0] = k_73640; + + +make_utf8_string_with_len(c_731284, "<", 1, 1); + +make_utf8_string_with_len(c_731285, ">", 1, 1); + +object c_731283 = Cyc_string_append(data,(closure)&c_731271,3,&c_731284, header_73410_73454, &c_731285); +return_closcall1(data,(closure)&c_731271, c_731283);; +} + +static void __lambda_54(void *data, object self_73701, int argc, object *args) /* object self_73701, object r_73643 */ + { + object r_73643 = args[0]; + +pair_type local_731276; + +pair_type local_731279; +return_direct_with_clo1(data, ((closureN)self_73701)->elements[0], (((closure) ((closureN)self_73701)->elements[0])->fn), set_pair_as_expr(&local_731276, quote_include_91c_91header, set_pair_as_expr(&local_731279, r_73643, NULL)));; +} + +static void __lambda_51(void *data, object self_73702, int argc, object *args) /* object self_73702, object r_73639 */ + { + object r_73639 = args[0]; + +closureN_type c_731259; +object e_731262 [1]; +c_731259.hdr.mark = gc_color_red; + c_731259.hdr.grayed = 0; +c_731259.tag = closureN_tag; + c_731259.fn = (function_type)__lambda_52; +c_731259.num_args = 1; +c_731259.num_elements = 1; +c_731259.elements = (object *)e_731262; +c_731259.elements[0] = ((closureN)self_73702)->elements[1]; + + + + + +return_direct_with_clo3(data, __glo_Cyc_91map_91loop_911_scheme_base, (((closure) __glo_Cyc_91map_91loop_911_scheme_base)->fn), &c_731259, r_73639, Cyc_cadr(data, Cyc_cadr(data, ((closureN)self_73702)->elements[0])));; +} + +static void __lambda_52(void *data, object self_73703, int argc, object *args) /* object self_73703, object includes_73405_73453 */ + { + object includes_73405_73453 = args[0]; + return_direct_with_clo1(data, ((closureN)self_73703)->elements[0], (((closure) ((closureN)self_73703)->elements[0])->fn), includes_73405_73453);; +} + +static void __lambda_32(void *data, object _, int argc, object *args) /* closure _,object k_73589, object expr_73338_73355_73380_73432, object rename_73339_73356_73381_73433, object compare_73340_73357_73382_73434 */ + { +object k_73589 = args[0]; object expr_73338_73355_73380_73432 = args[1]; object rename_73339_73356_73381_73433 = args[2]; + Cyc_st_add(data, "./foreign/c/cyclone-primitives.sld:define-c-library"); + +closureN_type c_731086; +object e_731252 [3]; +c_731086.hdr.mark = gc_color_red; + c_731086.hdr.grayed = 0; +c_731086.tag = closureN_tag; + c_731086.fn = (function_type)__lambda_33; +c_731086.num_args = 1; +c_731086.num_elements = 3; +c_731086.elements = (object *)e_731252; +c_731086.elements[0] = expr_73338_73355_73380_73432; +c_731086.elements[1] = k_73589; +c_731086.elements[2] = rename_73339_73356_73381_73433; + + + +return_direct_with_clo1(data,(closure)&c_731086,__lambda_33, Cyc_cdr(data, expr_73338_73355_73380_73432));; +} + +static void __lambda_33(void *data, object self_73683, int argc, object *args) /* object self_73683, object v_931_73346_73362_73384_73436 */ + { + object v_931_73346_73362_73384_73436 = args[0]; + +closureN_type c_731088; +object e_731227 [2]; +c_731088.hdr.mark = gc_color_red; + c_731088.hdr.grayed = 0; +c_731088.tag = closureN_tag; + c_731088.fn = (function_type)__lambda_34; +c_731088.num_args = 0; +c_731088.num_elements = 2; +c_731088.elements = (object *)e_731227; +c_731088.elements[0] = ((closureN)self_73683)->elements[2]; +c_731088.elements[1] = v_931_73346_73362_73384_73436; + + +closureN_type c_731228; +object e_731251 [2]; +c_731228.hdr.mark = gc_color_red; + c_731228.hdr.grayed = 0; +c_731228.tag = closureN_tag; + c_731228.fn = (function_type)__lambda_46; +c_731228.num_args = 1; +c_731228.num_elements = 2; +c_731228.elements = (object *)e_731251; +c_731228.elements[0] = ((closureN)self_73683)->elements[0]; +c_731228.elements[1] = ((closureN)self_73683)->elements[1]; + +return_direct_with_clo1(data,(closure)&c_731088,__lambda_34, &c_731228);; +} + +static void __lambda_46(void *data, object self_73684, int argc, object *args) /* object self_73684, object tmp_73359_73361_73383_73435 */ + { + object tmp_73359_73361_73383_73435 = args[0]; + +closureN_type c_731230; +object e_731244 [2]; +c_731230.hdr.mark = gc_color_red; + c_731230.hdr.grayed = 0; +c_731230.tag = closureN_tag; + c_731230.fn = (function_type)__lambda_47; +c_731230.num_args = 0; +c_731230.num_elements = 2; +c_731230.elements = (object *)e_731244; +c_731230.elements[0] = ((closureN)self_73684)->elements[0]; +c_731230.elements[1] = tmp_73359_73361_73383_73435; + + +closureN_type c_731245; +object e_731250 [1]; +c_731245.hdr.mark = gc_color_red; + c_731245.hdr.grayed = 0; +c_731245.tag = closureN_tag; + c_731245.fn = (function_type)__lambda_49; +c_731245.num_args = 1; +c_731245.num_elements = 1; +c_731245.elements = (object *)e_731250; +c_731245.elements[0] = ((closureN)self_73684)->elements[1]; + +return_direct_with_clo1(data,(closure)&c_731230,__lambda_47, &c_731245);; +} + +static void __lambda_49(void *data, object self_73685, int argc, object *args) /* object self_73685, object r_73590 */ + { + object r_73590 = args[0]; + + +return_direct_with_clo1(data, ((closureN)self_73685)->elements[0], (((closure) ((closureN)self_73685)->elements[0])->fn), Cyc_car(data, r_73590));; +} + +static void __lambda_47(void *data, object self_73686, int argc, object *args) /* object self_73686, object k_73592 */ + { + object k_73592 = args[0]; + if( (boolean_f != ((closureN)self_73686)->elements[1]) ){ + return_direct_with_clo1(data, k_73592, (((closure) k_73592)->fn), ((closureN)self_73686)->elements[1]); +} else { + +closureN_type c_731235; +object e_731241 [1]; +c_731235.hdr.mark = gc_color_red; + c_731235.hdr.grayed = 0; +c_731235.tag = closureN_tag; + c_731235.fn = (function_type)__lambda_48; +c_731235.num_args = 1; +c_731235.num_elements = 1; +c_731235.elements = (object *)e_731241; +c_731235.elements[0] = k_73592; + + +make_utf8_string_with_len(c_731242, "no expansion for", 16, 16); +return_direct_with_clo3(data, __glo_error_95loc_scheme_base, (((closure) __glo_error_95loc_scheme_base)->fn), &c_731235, &c_731242, ((closureN)self_73686)->elements[0]);} +;; +} + +static void __lambda_48(void *data, object self_73687, int argc, object *args) /* object self_73687, object r_73593 */ + { + object r_73593 = args[0]; + +pair_type local_731240; +return_direct_with_clo1(data, ((closureN)self_73687)->elements[0], (((closure) ((closureN)self_73687)->elements[0])->fn), set_pair_as_expr(&local_731240, r_73593, boolean_f));; +} + +static void __lambda_34(void *data, object self_73688, int argc, object *args) /* object self_73688, object k_73595 */ + { + object k_73595 = args[0]; + +if( (boolean_f != Cyc_is_pair(((closureN)self_73688)->elements[1])) ){ + + +if( (boolean_f != Cyc_is_pair(Cyc_cdr(data, ((closureN)self_73688)->elements[1]))) ){ + + + +if( (boolean_f != Cyc_is_pair(Cyc_cdr(data, Cyc_cdr(data, ((closureN)self_73688)->elements[1])))) ){ + + + + Cyc_car(data, Cyc_cdr(data, Cyc_cdr(data, ((closureN)self_73688)->elements[1]))); + + + +if( (boolean_f != Cyc_is_pair(Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, ((closureN)self_73688)->elements[1]))))) ){ + + + + + Cyc_car(data, Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, ((closureN)self_73688)->elements[1])))); + + + + +if( (boolean_f != Cyc_is_null(Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, ((closureN)self_73688)->elements[1])))))) ){ + +closureN_type c_731128; +object e_731205 [3]; +c_731128.hdr.mark = gc_color_red; + c_731128.hdr.grayed = 0; +c_731128.tag = closureN_tag; + c_731128.fn = (function_type)__lambda_35; +c_731128.num_args = 1; +c_731128.num_elements = 3; +c_731128.elements = (object *)e_731205; +c_731128.elements[0] = k_73595; +c_731128.elements[1] = ((closureN)self_73688)->elements[0]; +c_731128.elements[2] = ((closureN)self_73688)->elements[1]; + +return_closcall2(data, ((closureN)self_73688)->elements[0], &c_731128, quote_begin); +} else { + return_direct_with_clo1(data, k_73595, (((closure) k_73595)->fn), boolean_f);} +; +} else { + return_direct_with_clo1(data, k_73595, (((closure) k_73595)->fn), boolean_f);} +; +} else { + return_direct_with_clo1(data, k_73595, (((closure) k_73595)->fn), boolean_f);} +; +} else { + return_direct_with_clo1(data, k_73595, (((closure) k_73595)->fn), boolean_f);} +; +} else { + return_direct_with_clo1(data, k_73595, (((closure) k_73595)->fn), boolean_f);} +;; +} + +static void __lambda_35(void *data, object self_73689, int argc, object *args) /* object self_73689, object r_73610 */ + { + object r_73610 = args[0]; + +closureN_type c_731131; +object e_731204 [4]; +c_731131.hdr.mark = gc_color_red; + c_731131.hdr.grayed = 0; +c_731131.tag = closureN_tag; + c_731131.fn = (function_type)__lambda_36; +c_731131.num_args = 1; +c_731131.num_elements = 4; +c_731131.elements = (object *)e_731204; +c_731131.elements[0] = ((closureN)self_73689)->elements[0]; +c_731131.elements[1] = r_73610; +c_731131.elements[2] = ((closureN)self_73689)->elements[1]; +c_731131.elements[3] = ((closureN)self_73689)->elements[2]; + +return_closcall2(data, ((closureN)self_73689)->elements[1], &c_731131, quote_define);; +} + +static void __lambda_36(void *data, object self_73690, int argc, object *args) /* object self_73690, object r_73625 */ + { + object r_73625 = args[0]; + +closureN_type c_731133; +object e_731202 [5]; +c_731133.hdr.mark = gc_color_red; + c_731133.hdr.grayed = 0; +c_731133.tag = closureN_tag; + c_731133.fn = (function_type)__lambda_37; +c_731133.num_args = 1; +c_731133.num_elements = 5; +c_731133.elements = (object *)e_731202; +c_731133.elements[0] = ((closureN)self_73690)->elements[0]; +c_731133.elements[1] = ((closureN)self_73690)->elements[1]; +c_731133.elements[2] = r_73625; +c_731133.elements[3] = ((closureN)self_73690)->elements[2]; +c_731133.elements[4] = ((closureN)self_73690)->elements[3]; + + +make_pair(c_731203,boolean_t,NULL);c_731203.hdr.immutable = 1; +return_direct_with_clo4(data, __glo_cons_91source_scheme_base, (((closure) __glo_cons_91source_scheme_base)->fn), &c_731133, boolean_t, NULL, &c_731203);; +} + +static void __lambda_37(void *data, object self_73691, int argc, object *args) /* object self_73691, object r_73628 */ + { + object r_73628 = args[0]; + +closureN_type c_731135; +object e_731196 [5]; +c_731135.hdr.mark = gc_color_red; + c_731135.hdr.grayed = 0; +c_731135.tag = closureN_tag; + c_731135.fn = (function_type)__lambda_38; +c_731135.num_args = 1; +c_731135.num_elements = 5; +c_731135.elements = (object *)e_731196; +c_731135.elements[0] = ((closureN)self_73691)->elements[0]; +c_731135.elements[1] = ((closureN)self_73691)->elements[1]; +c_731135.elements[2] = ((closureN)self_73691)->elements[2]; +c_731135.elements[3] = ((closureN)self_73691)->elements[3]; +c_731135.elements[4] = ((closureN)self_73691)->elements[4]; + + + + +make_pair(c_731201,boolean_t,NULL);c_731201.hdr.immutable = 1; + +make_pair(c_731200,quote_scheme_91name,&c_731201);c_731200.hdr.immutable = 1; +return_direct_with_clo4(data, __glo_cons_91source_scheme_base, (((closure) __glo_cons_91source_scheme_base)->fn), &c_731135, Cyc_car(data, ((closureN)self_73691)->elements[4]), r_73628, &c_731200);; +} + +static void __lambda_38(void *data, object self_73692, int argc, object *args) /* object self_73692, object r_73626 */ + { + object r_73626 = args[0]; + +closureN_type c_731137; +object e_731191 [4]; +c_731137.hdr.mark = gc_color_red; + c_731137.hdr.grayed = 0; +c_731137.tag = closureN_tag; + c_731137.fn = (function_type)__lambda_39; +c_731137.num_args = 1; +c_731137.num_elements = 4; +c_731137.elements = (object *)e_731191; +c_731137.elements[0] = ((closureN)self_73692)->elements[0]; +c_731137.elements[1] = ((closureN)self_73692)->elements[1]; +c_731137.elements[2] = ((closureN)self_73692)->elements[3]; +c_731137.elements[3] = ((closureN)self_73692)->elements[4]; + + +make_pair(c_731195,boolean_t,NULL);c_731195.hdr.immutable = 1; + +make_pair(c_731194,quote_scheme_91name,&c_731195);c_731194.hdr.immutable = 1; + +make_pair(c_731193,quote_define,&c_731194);c_731193.hdr.immutable = 1; +return_direct_with_clo4(data, __glo_cons_91source_scheme_base, (((closure) __glo_cons_91source_scheme_base)->fn), &c_731137, ((closureN)self_73692)->elements[2], r_73626, &c_731193);; +} + +static void __lambda_39(void *data, object self_73693, int argc, object *args) /* object self_73693, object r_73613 */ + { + object r_73613 = args[0]; + +closureN_type c_731140; +object e_731190 [4]; +c_731140.hdr.mark = gc_color_red; + c_731140.hdr.grayed = 0; +c_731140.tag = closureN_tag; + c_731140.fn = (function_type)__lambda_40; +c_731140.num_args = 1; +c_731140.num_elements = 4; +c_731140.elements = (object *)e_731190; +c_731140.elements[0] = ((closureN)self_73693)->elements[0]; +c_731140.elements[1] = ((closureN)self_73693)->elements[1]; +c_731140.elements[2] = r_73613; +c_731140.elements[3] = ((closureN)self_73693)->elements[3]; + +return_closcall2(data, ((closureN)self_73693)->elements[2], &c_731140, quote_shared_91object_91load);; +} + +static void __lambda_40(void *data, object self_73694, int argc, object *args) /* object self_73694, object r_73619 */ + { + object r_73619 = args[0]; + +closureN_type c_731142; +object e_731183 [4]; +c_731142.hdr.mark = gc_color_red; + c_731142.hdr.grayed = 0; +c_731142.tag = closureN_tag; + c_731142.fn = (function_type)__lambda_41; +c_731142.num_args = 1; +c_731142.num_elements = 4; +c_731142.elements = (object *)e_731183; +c_731142.elements[0] = ((closureN)self_73694)->elements[0]; +c_731142.elements[1] = ((closureN)self_73694)->elements[1]; +c_731142.elements[2] = ((closureN)self_73694)->elements[2]; +c_731142.elements[3] = r_73619; + + + + + + +make_pair(c_731189,quote_headers,NULL);c_731189.hdr.immutable = 1; +return_direct_with_clo4(data, __glo_cons_91source_scheme_base, (((closure) __glo_cons_91source_scheme_base)->fn), &c_731142, Cyc_car(data, Cyc_cdr(data, ((closureN)self_73694)->elements[3])), NULL, &c_731189);; +} + +static void __lambda_41(void *data, object self_73695, int argc, object *args) /* object self_73695, object r_73620 */ + { + object r_73620 = args[0]; + +closureN_type c_731144; +object e_731179 [3]; +c_731144.hdr.mark = gc_color_red; + c_731144.hdr.grayed = 0; +c_731144.tag = closureN_tag; + c_731144.fn = (function_type)__lambda_42; +c_731144.num_args = 1; +c_731144.num_elements = 3; +c_731144.elements = (object *)e_731179; +c_731144.elements[0] = ((closureN)self_73695)->elements[0]; +c_731144.elements[1] = ((closureN)self_73695)->elements[1]; +c_731144.elements[2] = ((closureN)self_73695)->elements[2]; + + +make_pair(c_731182,quote_headers,NULL);c_731182.hdr.immutable = 1; + +make_pair(c_731181,quote_shared_91object_91load,&c_731182);c_731181.hdr.immutable = 1; +return_direct_with_clo4(data, __glo_cons_91source_scheme_base, (((closure) __glo_cons_91source_scheme_base)->fn), &c_731144, ((closureN)self_73695)->elements[3], r_73620, &c_731181);; +} + +static void __lambda_42(void *data, object self_73696, int argc, object *args) /* object self_73696, object r_73616 */ + { + object r_73616 = args[0]; + +closureN_type c_731146; +object e_731175 [3]; +c_731146.hdr.mark = gc_color_red; + c_731146.hdr.grayed = 0; +c_731146.tag = closureN_tag; + c_731146.fn = (function_type)__lambda_43; +c_731146.num_args = 1; +c_731146.num_elements = 3; +c_731146.elements = (object *)e_731175; +c_731146.elements[0] = ((closureN)self_73696)->elements[0]; +c_731146.elements[1] = ((closureN)self_73696)->elements[1]; +c_731146.elements[2] = ((closureN)self_73696)->elements[2]; + + +make_pair(c_731178,quote_headers,NULL);c_731178.hdr.immutable = 1; + +make_pair(c_731177,quote_shared_91object_91load,&c_731178);c_731177.hdr.immutable = 1; + +make_pair(c_731176,&c_731177,NULL);c_731176.hdr.immutable = 1; +return_direct_with_clo4(data, __glo_cons_91source_scheme_base, (((closure) __glo_cons_91source_scheme_base)->fn), &c_731146, r_73616, NULL, &c_731176);; +} + +static void __lambda_43(void *data, object self_73697, int argc, object *args) /* object self_73697, object r_73614 */ + { + object r_73614 = args[0]; + +closureN_type c_731148; +object e_731166 [2]; +c_731148.hdr.mark = gc_color_red; + c_731148.hdr.grayed = 0; +c_731148.tag = closureN_tag; + c_731148.fn = (function_type)__lambda_44; +c_731148.num_args = 1; +c_731148.num_elements = 2; +c_731148.elements = (object *)e_731166; +c_731148.elements[0] = ((closureN)self_73697)->elements[0]; +c_731148.elements[1] = ((closureN)self_73697)->elements[1]; + + +make_pair(c_731171,boolean_t,NULL);c_731171.hdr.immutable = 1; + +make_pair(c_731170,quote_scheme_91name,&c_731171);c_731170.hdr.immutable = 1; + +make_pair(c_731169,quote_define,&c_731170);c_731169.hdr.immutable = 1; + +make_pair(c_731174,quote_headers,NULL);c_731174.hdr.immutable = 1; + +make_pair(c_731173,quote_shared_91object_91load,&c_731174);c_731173.hdr.immutable = 1; + +make_pair(c_731172,&c_731173,NULL);c_731172.hdr.immutable = 1; + +make_pair(c_731168,&c_731169,&c_731172);c_731168.hdr.immutable = 1; +return_direct_with_clo4(data, __glo_cons_91source_scheme_base, (((closure) __glo_cons_91source_scheme_base)->fn), &c_731148, ((closureN)self_73697)->elements[2], r_73614, &c_731168);; +} + +static void __lambda_44(void *data, object self_73698, int argc, object *args) /* object self_73698, object r_73611 */ + { + object r_73611 = args[0]; + +closureN_type c_731150; +object e_731156 [1]; +c_731150.hdr.mark = gc_color_red; + c_731150.hdr.grayed = 0; +c_731150.tag = closureN_tag; + c_731150.fn = (function_type)__lambda_45; +c_731150.num_args = 1; +c_731150.num_elements = 1; +c_731150.elements = (object *)e_731156; +c_731150.elements[0] = ((closureN)self_73698)->elements[0]; + + +make_pair(c_731162,boolean_t,NULL);c_731162.hdr.immutable = 1; + +make_pair(c_731161,quote_scheme_91name,&c_731162);c_731161.hdr.immutable = 1; + +make_pair(c_731160,quote_define,&c_731161);c_731160.hdr.immutable = 1; + +make_pair(c_731165,quote_headers,NULL);c_731165.hdr.immutable = 1; + +make_pair(c_731164,quote_shared_91object_91load,&c_731165);c_731164.hdr.immutable = 1; + +make_pair(c_731163,&c_731164,NULL);c_731163.hdr.immutable = 1; + +make_pair(c_731159,&c_731160,&c_731163);c_731159.hdr.immutable = 1; + +make_pair(c_731158,quote_begin,&c_731159);c_731158.hdr.immutable = 1; +return_direct_with_clo4(data, __glo_cons_91source_scheme_base, (((closure) __glo_cons_91source_scheme_base)->fn), &c_731150, ((closureN)self_73698)->elements[1], r_73611, &c_731158);; +} + +static void __lambda_45(void *data, object self_73699, int argc, object *args) /* object self_73699, object r_73609 */ + { + object r_73609 = args[0]; + +pair_type local_731155; +return_direct_with_clo1(data, ((closureN)self_73699)->elements[0], (((closure) ((closureN)self_73699)->elements[0])->fn), set_pair_as_expr(&local_731155, r_73609, boolean_f));; +} + +static void __lambda_58(void *data, object _, int argc, object *args) {object k = args[0];object pointer = args[1];make_c_opaque(opq, &(void*)opaque_ptr(pointer)); + return_closcall1(data, k, &opq); } +static void __lambda_31(void *data, object _, int argc, object *args) /* closure _,object k_73546, object type_73162_73431 */ + { +object k_73546 = args[0]; object type_73162_73431 = args[1]; + Cyc_st_add(data, "./foreign/c/cyclone-primitives.sld:size-of-type"); + +if( (boolean_f != equalp(type_73162_73431, quote_int8)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(int8_t))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_uint8)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(uint8_t))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_int16)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(int16_t))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_uint16)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(uint16_t))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_int32)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(int32_t))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_uint32)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(uint32_t))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_int64)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(int64_t))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_uint64)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(uint64_t))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote__char)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(char))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_unsigned_91char)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(unsigned char))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote__short)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(short))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_unsigned_91short)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(unsigned short))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote__int)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(int))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_unsigned_91int)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(unsigned int))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote__long)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(long))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_unsigned_91long)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(unsigned long))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote__float)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(float))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote__double)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(double))); +} else { + +if( (boolean_f != equalp(type_73162_73431, quote_pointer)) ){ + + +return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), obj_int2obj(sizeof(void*))); +} else { + return_direct_with_clo1(data, k_73546, (((closure) k_73546)->fn), boolean_f);} +;} +;} +;} +;} +;} +;} +;} +;} +;} +;} +;} +;} +;} +;} +;} +;} +;} +;} +;; +} + +static void __lambda_30(void *data, object _, int argc, object *args) /* closure _,object k_73543, object scheme_91name_73158_73427, object return_91type_73159_73428, object argument_91types_73160_73429, object procedure_73161_73430 */ + { +object k_73543 = args[0]; + Cyc_st_add(data, "./foreign/c/cyclone-primitives.sld:define-c-callback"); + +make_utf8_string_with_len(c_731004, "define-callback not yet implemented on Cyclone", 46, 46); +return_direct_with_clo2(data, __glo_error_scheme_base, (((closure) __glo_error_scheme_base)->fn), k_73543, &c_731004);; +} + +static void __lambda_2(void *data, object _, int argc, object *args) /* closure _,object k_73460, object expr_7367_73417, object rename_7368_73418, object compare_7369_73419 */ + { +object k_73460 = args[0]; object expr_7367_73417 = args[1]; + Cyc_st_add(data, "./foreign/c/cyclone-primitives.sld:define-c-procedure"); + +closureN_type c_73710; +object e_73829 [2]; +c_73710.hdr.mark = gc_color_red; + c_73710.hdr.grayed = 0; +c_73710.tag = closureN_tag; + c_73710.fn = (function_type)__lambda_3; +c_73710.num_args = 1; +c_73710.num_elements = 2; +c_73710.elements = (object *)e_73829; +c_73710.elements[0] = expr_7367_73417; +c_73710.elements[1] = k_73460; + + +mmacro(c_73830, (function_type)__lambda_8);c_73830.num_args = 1; +return_direct_with_clo1(data,(closure)&c_73710,__lambda_3, &c_73830);; +} + +static void __lambda_8(void *data, object self_73656, int argc, object *args) /* object self_73656, object k_73498, object type_7393_73426 */ + { + object k_73498 = args[0]; object type_7393_73426 = args[1]; + +closureN_type c_73832; +object e_73999 [2]; +c_73832.hdr.mark = gc_color_red; + c_73832.hdr.grayed = 0; +c_73832.tag = closureN_tag; + c_73832.fn = (function_type)__lambda_9; +c_73832.num_args = 1; +c_73832.num_elements = 2; +c_73832.elements = (object *)e_73999; +c_73832.elements[0] = k_73498; +c_73832.elements[1] = type_7393_73426; + + + +return_direct_with_clo1(data,(closure)&c_73832,__lambda_9, equalp(type_7393_73426, quote_int8));; +} + +static void __lambda_9(void *data, object self_73657, int argc, object *args) /* object self_73657, object r_73499 */ + { + object r_73499 = args[0]; + if( (boolean_f != r_73499) ){ + return_direct_with_clo1(data, ((closureN)self_73657)->elements[0], (((closure) ((closureN)self_73657)->elements[0])->fn), quote__int); +} else { + +closureN_type c_73836; +object e_73995 [2]; +c_73836.hdr.mark = gc_color_red; + c_73836.hdr.grayed = 0; +c_73836.tag = closureN_tag; + c_73836.fn = (function_type)__lambda_10; +c_73836.num_args = 1; +c_73836.num_elements = 2; +c_73836.elements = (object *)e_73995; +c_73836.elements[0] = ((closureN)self_73657)->elements[0]; +c_73836.elements[1] = ((closureN)self_73657)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73836,__lambda_10, equalp(((closureN)self_73657)->elements[1], quote_uint8));} +;; +} + +static void __lambda_10(void *data, object self_73658, int argc, object *args) /* object self_73658, object r_73500 */ + { + object r_73500 = args[0]; + if( (boolean_f != r_73500) ){ + return_direct_with_clo1(data, ((closureN)self_73658)->elements[0], (((closure) ((closureN)self_73658)->elements[0])->fn), quote__int); +} else { + +closureN_type c_73840; +object e_73991 [2]; +c_73840.hdr.mark = gc_color_red; + c_73840.hdr.grayed = 0; +c_73840.tag = closureN_tag; + c_73840.fn = (function_type)__lambda_11; +c_73840.num_args = 1; +c_73840.num_elements = 2; +c_73840.elements = (object *)e_73991; +c_73840.elements[0] = ((closureN)self_73658)->elements[0]; +c_73840.elements[1] = ((closureN)self_73658)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73840,__lambda_11, equalp(((closureN)self_73658)->elements[1], quote_int16));} +;; +} + +static void __lambda_11(void *data, object self_73659, int argc, object *args) /* object self_73659, object r_73501 */ + { + object r_73501 = args[0]; + if( (boolean_f != r_73501) ){ + return_direct_with_clo1(data, ((closureN)self_73659)->elements[0], (((closure) ((closureN)self_73659)->elements[0])->fn), quote__int); +} else { + +closureN_type c_73844; +object e_73987 [2]; +c_73844.hdr.mark = gc_color_red; + c_73844.hdr.grayed = 0; +c_73844.tag = closureN_tag; + c_73844.fn = (function_type)__lambda_12; +c_73844.num_args = 1; +c_73844.num_elements = 2; +c_73844.elements = (object *)e_73987; +c_73844.elements[0] = ((closureN)self_73659)->elements[0]; +c_73844.elements[1] = ((closureN)self_73659)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73844,__lambda_12, equalp(((closureN)self_73659)->elements[1], quote_uint16));} +;; +} + +static void __lambda_12(void *data, object self_73660, int argc, object *args) /* object self_73660, object r_73502 */ + { + object r_73502 = args[0]; + if( (boolean_f != r_73502) ){ + return_direct_with_clo1(data, ((closureN)self_73660)->elements[0], (((closure) ((closureN)self_73660)->elements[0])->fn), quote__int); +} else { + +closureN_type c_73848; +object e_73983 [2]; +c_73848.hdr.mark = gc_color_red; + c_73848.hdr.grayed = 0; +c_73848.tag = closureN_tag; + c_73848.fn = (function_type)__lambda_13; +c_73848.num_args = 1; +c_73848.num_elements = 2; +c_73848.elements = (object *)e_73983; +c_73848.elements[0] = ((closureN)self_73660)->elements[0]; +c_73848.elements[1] = ((closureN)self_73660)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73848,__lambda_13, equalp(((closureN)self_73660)->elements[1], quote_int32));} +;; +} + +static void __lambda_13(void *data, object self_73661, int argc, object *args) /* object self_73661, object r_73503 */ + { + object r_73503 = args[0]; + if( (boolean_f != r_73503) ){ + return_direct_with_clo1(data, ((closureN)self_73661)->elements[0], (((closure) ((closureN)self_73661)->elements[0])->fn), quote__int); +} else { + +closureN_type c_73852; +object e_73979 [2]; +c_73852.hdr.mark = gc_color_red; + c_73852.hdr.grayed = 0; +c_73852.tag = closureN_tag; + c_73852.fn = (function_type)__lambda_14; +c_73852.num_args = 1; +c_73852.num_elements = 2; +c_73852.elements = (object *)e_73979; +c_73852.elements[0] = ((closureN)self_73661)->elements[0]; +c_73852.elements[1] = ((closureN)self_73661)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73852,__lambda_14, equalp(((closureN)self_73661)->elements[1], quote_uint32));} +;; +} + +static void __lambda_14(void *data, object self_73662, int argc, object *args) /* object self_73662, object r_73504 */ + { + object r_73504 = args[0]; + if( (boolean_f != r_73504) ){ + return_direct_with_clo1(data, ((closureN)self_73662)->elements[0], (((closure) ((closureN)self_73662)->elements[0])->fn), quote__int); +} else { + +closureN_type c_73856; +object e_73975 [2]; +c_73856.hdr.mark = gc_color_red; + c_73856.hdr.grayed = 0; +c_73856.tag = closureN_tag; + c_73856.fn = (function_type)__lambda_15; +c_73856.num_args = 1; +c_73856.num_elements = 2; +c_73856.elements = (object *)e_73975; +c_73856.elements[0] = ((closureN)self_73662)->elements[0]; +c_73856.elements[1] = ((closureN)self_73662)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73856,__lambda_15, equalp(((closureN)self_73662)->elements[1], quote_int64));} +;; +} + +static void __lambda_15(void *data, object self_73663, int argc, object *args) /* object self_73663, object r_73505 */ + { + object r_73505 = args[0]; + if( (boolean_f != r_73505) ){ + return_direct_with_clo1(data, ((closureN)self_73663)->elements[0], (((closure) ((closureN)self_73663)->elements[0])->fn), quote__int); +} else { + +closureN_type c_73860; +object e_73971 [2]; +c_73860.hdr.mark = gc_color_red; + c_73860.hdr.grayed = 0; +c_73860.tag = closureN_tag; + c_73860.fn = (function_type)__lambda_16; +c_73860.num_args = 1; +c_73860.num_elements = 2; +c_73860.elements = (object *)e_73971; +c_73860.elements[0] = ((closureN)self_73663)->elements[0]; +c_73860.elements[1] = ((closureN)self_73663)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73860,__lambda_16, equalp(((closureN)self_73663)->elements[1], quote_uint64));} +;; +} + +static void __lambda_16(void *data, object self_73664, int argc, object *args) /* object self_73664, object r_73506 */ + { + object r_73506 = args[0]; + if( (boolean_f != r_73506) ){ + return_direct_with_clo1(data, ((closureN)self_73664)->elements[0], (((closure) ((closureN)self_73664)->elements[0])->fn), quote__int); +} else { + +closureN_type c_73864; +object e_73967 [2]; +c_73864.hdr.mark = gc_color_red; + c_73864.hdr.grayed = 0; +c_73864.tag = closureN_tag; + c_73864.fn = (function_type)__lambda_17; +c_73864.num_args = 1; +c_73864.num_elements = 2; +c_73864.elements = (object *)e_73967; +c_73864.elements[0] = ((closureN)self_73664)->elements[0]; +c_73864.elements[1] = ((closureN)self_73664)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73864,__lambda_17, equalp(((closureN)self_73664)->elements[1], quote__char));} +;; +} + +static void __lambda_17(void *data, object self_73665, int argc, object *args) /* object self_73665, object r_73507 */ + { + object r_73507 = args[0]; + if( (boolean_f != r_73507) ){ + return_direct_with_clo1(data, ((closureN)self_73665)->elements[0], (((closure) ((closureN)self_73665)->elements[0])->fn), quote__char); +} else { + +closureN_type c_73868; +object e_73963 [2]; +c_73868.hdr.mark = gc_color_red; + c_73868.hdr.grayed = 0; +c_73868.tag = closureN_tag; + c_73868.fn = (function_type)__lambda_18; +c_73868.num_args = 1; +c_73868.num_elements = 2; +c_73868.elements = (object *)e_73963; +c_73868.elements[0] = ((closureN)self_73665)->elements[0]; +c_73868.elements[1] = ((closureN)self_73665)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73868,__lambda_18, equalp(((closureN)self_73665)->elements[1], quote_unsigned_91char));} +;; +} + +static void __lambda_18(void *data, object self_73666, int argc, object *args) /* object self_73666, object r_73508 */ + { + object r_73508 = args[0]; + if( (boolean_f != r_73508) ){ + return_direct_with_clo1(data, ((closureN)self_73666)->elements[0], (((closure) ((closureN)self_73666)->elements[0])->fn), quote_unsigned_91char); +} else { + +closureN_type c_73872; +object e_73959 [2]; +c_73872.hdr.mark = gc_color_red; + c_73872.hdr.grayed = 0; +c_73872.tag = closureN_tag; + c_73872.fn = (function_type)__lambda_19; +c_73872.num_args = 1; +c_73872.num_elements = 2; +c_73872.elements = (object *)e_73959; +c_73872.elements[0] = ((closureN)self_73666)->elements[0]; +c_73872.elements[1] = ((closureN)self_73666)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73872,__lambda_19, equalp(((closureN)self_73666)->elements[1], quote__short));} +;; +} + +static void __lambda_19(void *data, object self_73667, int argc, object *args) /* object self_73667, object r_73509 */ + { + object r_73509 = args[0]; + if( (boolean_f != r_73509) ){ + return_direct_with_clo1(data, ((closureN)self_73667)->elements[0], (((closure) ((closureN)self_73667)->elements[0])->fn), quote__short); +} else { + +closureN_type c_73876; +object e_73955 [2]; +c_73876.hdr.mark = gc_color_red; + c_73876.hdr.grayed = 0; +c_73876.tag = closureN_tag; + c_73876.fn = (function_type)__lambda_20; +c_73876.num_args = 1; +c_73876.num_elements = 2; +c_73876.elements = (object *)e_73955; +c_73876.elements[0] = ((closureN)self_73667)->elements[0]; +c_73876.elements[1] = ((closureN)self_73667)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73876,__lambda_20, equalp(((closureN)self_73667)->elements[1], quote_unsigned_91short));} +;; +} + +static void __lambda_20(void *data, object self_73668, int argc, object *args) /* object self_73668, object r_73510 */ + { + object r_73510 = args[0]; + if( (boolean_f != r_73510) ){ + return_direct_with_clo1(data, ((closureN)self_73668)->elements[0], (((closure) ((closureN)self_73668)->elements[0])->fn), quote_unsigned_91short); +} else { + +closureN_type c_73880; +object e_73951 [2]; +c_73880.hdr.mark = gc_color_red; + c_73880.hdr.grayed = 0; +c_73880.tag = closureN_tag; + c_73880.fn = (function_type)__lambda_21; +c_73880.num_args = 1; +c_73880.num_elements = 2; +c_73880.elements = (object *)e_73951; +c_73880.elements[0] = ((closureN)self_73668)->elements[0]; +c_73880.elements[1] = ((closureN)self_73668)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73880,__lambda_21, equalp(((closureN)self_73668)->elements[1], quote__int));} +;; +} + +static void __lambda_21(void *data, object self_73669, int argc, object *args) /* object self_73669, object r_73511 */ + { + object r_73511 = args[0]; + if( (boolean_f != r_73511) ){ + return_direct_with_clo1(data, ((closureN)self_73669)->elements[0], (((closure) ((closureN)self_73669)->elements[0])->fn), quote__int); +} else { + +closureN_type c_73884; +object e_73947 [2]; +c_73884.hdr.mark = gc_color_red; + c_73884.hdr.grayed = 0; +c_73884.tag = closureN_tag; + c_73884.fn = (function_type)__lambda_22; +c_73884.num_args = 1; +c_73884.num_elements = 2; +c_73884.elements = (object *)e_73947; +c_73884.elements[0] = ((closureN)self_73669)->elements[0]; +c_73884.elements[1] = ((closureN)self_73669)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73884,__lambda_22, equalp(((closureN)self_73669)->elements[1], quote_unsigned_91int));} +;; +} + +static void __lambda_22(void *data, object self_73670, int argc, object *args) /* object self_73670, object r_73512 */ + { + object r_73512 = args[0]; + if( (boolean_f != r_73512) ){ + return_direct_with_clo1(data, ((closureN)self_73670)->elements[0], (((closure) ((closureN)self_73670)->elements[0])->fn), quote_unsigned_91int); +} else { + +closureN_type c_73888; +object e_73943 [2]; +c_73888.hdr.mark = gc_color_red; + c_73888.hdr.grayed = 0; +c_73888.tag = closureN_tag; + c_73888.fn = (function_type)__lambda_23; +c_73888.num_args = 1; +c_73888.num_elements = 2; +c_73888.elements = (object *)e_73943; +c_73888.elements[0] = ((closureN)self_73670)->elements[0]; +c_73888.elements[1] = ((closureN)self_73670)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73888,__lambda_23, equalp(((closureN)self_73670)->elements[1], quote__long));} +;; +} + +static void __lambda_23(void *data, object self_73671, int argc, object *args) /* object self_73671, object r_73513 */ + { + object r_73513 = args[0]; + if( (boolean_f != r_73513) ){ + return_direct_with_clo1(data, ((closureN)self_73671)->elements[0], (((closure) ((closureN)self_73671)->elements[0])->fn), quote__long); +} else { + +closureN_type c_73892; +object e_73939 [2]; +c_73892.hdr.mark = gc_color_red; + c_73892.hdr.grayed = 0; +c_73892.tag = closureN_tag; + c_73892.fn = (function_type)__lambda_24; +c_73892.num_args = 1; +c_73892.num_elements = 2; +c_73892.elements = (object *)e_73939; +c_73892.elements[0] = ((closureN)self_73671)->elements[0]; +c_73892.elements[1] = ((closureN)self_73671)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73892,__lambda_24, equalp(((closureN)self_73671)->elements[1], quote_unsigned_91long));} +;; +} + +static void __lambda_24(void *data, object self_73672, int argc, object *args) /* object self_73672, object r_73514 */ + { + object r_73514 = args[0]; + if( (boolean_f != r_73514) ){ + return_direct_with_clo1(data, ((closureN)self_73672)->elements[0], (((closure) ((closureN)self_73672)->elements[0])->fn), quote_unsigned_91long); +} else { + +closureN_type c_73896; +object e_73935 [2]; +c_73896.hdr.mark = gc_color_red; + c_73896.hdr.grayed = 0; +c_73896.tag = closureN_tag; + c_73896.fn = (function_type)__lambda_25; +c_73896.num_args = 1; +c_73896.num_elements = 2; +c_73896.elements = (object *)e_73935; +c_73896.elements[0] = ((closureN)self_73672)->elements[0]; +c_73896.elements[1] = ((closureN)self_73672)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73896,__lambda_25, equalp(((closureN)self_73672)->elements[1], quote__float));} +;; +} + +static void __lambda_25(void *data, object self_73673, int argc, object *args) /* object self_73673, object r_73515 */ + { + object r_73515 = args[0]; + if( (boolean_f != r_73515) ){ + return_direct_with_clo1(data, ((closureN)self_73673)->elements[0], (((closure) ((closureN)self_73673)->elements[0])->fn), quote__float); +} else { + +closureN_type c_73900; +object e_73931 [2]; +c_73900.hdr.mark = gc_color_red; + c_73900.hdr.grayed = 0; +c_73900.tag = closureN_tag; + c_73900.fn = (function_type)__lambda_26; +c_73900.num_args = 1; +c_73900.num_elements = 2; +c_73900.elements = (object *)e_73931; +c_73900.elements[0] = ((closureN)self_73673)->elements[0]; +c_73900.elements[1] = ((closureN)self_73673)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73900,__lambda_26, equalp(((closureN)self_73673)->elements[1], quote__double));} +;; +} + +static void __lambda_26(void *data, object self_73674, int argc, object *args) /* object self_73674, object r_73516 */ + { + object r_73516 = args[0]; + if( (boolean_f != r_73516) ){ + return_direct_with_clo1(data, ((closureN)self_73674)->elements[0], (((closure) ((closureN)self_73674)->elements[0])->fn), quote__double); +} else { + +closureN_type c_73904; +object e_73927 [2]; +c_73904.hdr.mark = gc_color_red; + c_73904.hdr.grayed = 0; +c_73904.tag = closureN_tag; + c_73904.fn = (function_type)__lambda_27; +c_73904.num_args = 1; +c_73904.num_elements = 2; +c_73904.elements = (object *)e_73927; +c_73904.elements[0] = ((closureN)self_73674)->elements[0]; +c_73904.elements[1] = ((closureN)self_73674)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73904,__lambda_27, equalp(((closureN)self_73674)->elements[1], quote_pointer));} +;; +} + +static void __lambda_27(void *data, object self_73675, int argc, object *args) /* object self_73675, object r_73517 */ + { + object r_73517 = args[0]; + if( (boolean_f != r_73517) ){ + return_direct_with_clo1(data, ((closureN)self_73675)->elements[0], (((closure) ((closureN)self_73675)->elements[0])->fn), quote_opaque); +} else { + +closureN_type c_73908; +object e_73923 [2]; +c_73908.hdr.mark = gc_color_red; + c_73908.hdr.grayed = 0; +c_73908.tag = closureN_tag; + c_73908.fn = (function_type)__lambda_28; +c_73908.num_args = 1; +c_73908.num_elements = 2; +c_73908.elements = (object *)e_73923; +c_73908.elements[0] = ((closureN)self_73675)->elements[0]; +c_73908.elements[1] = ((closureN)self_73675)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73908,__lambda_28, equalp(((closureN)self_73675)->elements[1], quote__void));} +;; +} + +static void __lambda_28(void *data, object self_73676, int argc, object *args) /* object self_73676, object r_73518 */ + { + object r_73518 = args[0]; + if( (boolean_f != r_73518) ){ + return_direct_with_clo1(data, ((closureN)self_73676)->elements[0], (((closure) ((closureN)self_73676)->elements[0])->fn), quote_c_91void); +} else { + +closureN_type c_73912; +object e_73919 [2]; +c_73912.hdr.mark = gc_color_red; + c_73912.hdr.grayed = 0; +c_73912.tag = closureN_tag; + c_73912.fn = (function_type)__lambda_29; +c_73912.num_args = 1; +c_73912.num_elements = 2; +c_73912.elements = (object *)e_73919; +c_73912.elements[0] = ((closureN)self_73676)->elements[0]; +c_73912.elements[1] = ((closureN)self_73676)->elements[1]; + + + +return_direct_with_clo1(data,(closure)&c_73912,__lambda_29, equalp(((closureN)self_73676)->elements[1], quote_callback));} +;; +} + +static void __lambda_29(void *data, object self_73677, int argc, object *args) /* object self_73677, object r_73519 */ + { + object r_73519 = args[0]; + if( (boolean_f != r_73519) ){ + return_direct_with_clo1(data, ((closureN)self_73677)->elements[0], (((closure) ((closureN)self_73677)->elements[0])->fn), quote_opaque); +} else { + +make_utf8_string_with_len(c_73917, "type->native-type -- No such type", 33, 33); +return_direct_with_clo3(data, __glo_error_scheme_base, (((closure) __glo_error_scheme_base)->fn), ((closureN)self_73677)->elements[0], &c_73917, ((closureN)self_73677)->elements[1]);} +;; +} + +static void __lambda_3(void *data, object self_73678, int argc, object *args) /* object self_73678, object type_91_125native_91type_7372_73420 */ + { + object type_91_125native_91type_7372_73420 = args[0]; + +closureN_type c_73712; +object e_73812 [3]; +c_73712.hdr.mark = gc_color_red; + c_73712.hdr.grayed = 0; +c_73712.tag = closureN_tag; + c_73712.fn = (function_type)__lambda_4; +c_73712.num_args = 1; +c_73712.num_elements = 3; +c_73712.elements = (object *)e_73812; +c_73712.elements[0] = ((closureN)self_73678)->elements[0]; +c_73712.elements[1] = ((closureN)self_73678)->elements[1]; +c_73712.elements[2] = type_91_125native_91type_7372_73420; + + + + + + + + + + + + + + +object c_73815 = Cyc_symbol2string(data,(closure)&c_73712,Cyc_car(data, Cyc_cdr(data, Cyc_car(data, Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, ((closureN)self_73678)->elements[0]))))))); +return_closcall1(data,(closure)&c_73712, c_73815);; +} + +static void __lambda_4(void *data, object self_73679, int argc, object *args) /* object self_73679, object c_91name_7378_73422 */ + { + object c_91name_7378_73422 = args[0]; + +closureN_type c_73715; +object e_73796 [4]; +c_73715.hdr.mark = gc_color_red; + c_73715.hdr.grayed = 0; +c_73715.tag = closureN_tag; + c_73715.fn = (function_type)__lambda_5; +c_73715.num_args = 1; +c_73715.num_elements = 4; +c_73715.elements = (object *)e_73796; +c_73715.elements[0] = c_91name_7378_73422; +c_73715.elements[1] = ((closureN)self_73679)->elements[0]; +c_73715.elements[2] = ((closureN)self_73679)->elements[1]; +c_73715.elements[3] = ((closureN)self_73679)->elements[2]; + + + + + + + + + + + + + + + +return_closcall2(data, ((closureN)self_73679)->elements[2], &c_73715, Cyc_car(data, Cyc_cdr(data, Cyc_car(data, Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, ((closureN)self_73679)->elements[0]))))))));; +} + +static void __lambda_5(void *data, object self_73680, int argc, object *args) /* object self_73680, object return_91type_7381_73423 */ + { + object return_91type_7381_73423 = args[0]; + +closureN_type c_73717; +object e_73753 [2]; +c_73717.hdr.mark = gc_color_red; + c_73717.hdr.grayed = 0; +c_73717.tag = closureN_tag; + c_73717.fn = (function_type)__lambda_6; +c_73717.num_args = 0; +c_73717.num_elements = 2; +c_73717.elements = (object *)e_73753; +c_73717.elements[0] = ((closureN)self_73680)->elements[1]; +c_73717.elements[1] = ((closureN)self_73680)->elements[3]; + + +closureN_type c_73754; +object e_73795 [4]; +c_73754.hdr.mark = gc_color_red; + c_73754.hdr.grayed = 0; +c_73754.tag = closureN_tag; + c_73754.fn = (function_type)__lambda_7; +c_73754.num_args = 1; +c_73754.num_elements = 4; +c_73754.elements = (object *)e_73795; +c_73754.elements[0] = ((closureN)self_73680)->elements[0]; +c_73754.elements[1] = ((closureN)self_73680)->elements[1]; +c_73754.elements[2] = ((closureN)self_73680)->elements[2]; +c_73754.elements[3] = return_91type_7381_73423; + +return_direct_with_clo1(data,(closure)&c_73717,__lambda_6, &c_73754);; +} + +static void __lambda_7(void *data, object self_73681, int argc, object *args) /* object self_73681, object argument_91types_7384_73424 */ + { + object argument_91types_7384_73424 = args[0]; + +if( (boolean_f != Cyc_is_null(argument_91types_7384_73424)) ){ + +pair_type local_73761; + +pair_type local_73764; + + + +pair_type local_73770; + +pair_type local_73774; +return_direct_with_clo1(data, ((closureN)self_73681)->elements[2], (((closure) ((closureN)self_73681)->elements[2])->fn), set_pair_as_expr(&local_73761, quote_c_91define, set_pair_as_expr(&local_73764, Cyc_cadr(data, ((closureN)self_73681)->elements[1]), set_pair_as_expr(&local_73770, ((closureN)self_73681)->elements[3], set_pair_as_expr(&local_73774, ((closureN)self_73681)->elements[0], NULL))))); +} else { + +pair_type local_73780; + +pair_type local_73783; + + + +pair_type local_73789; + +pair_type local_73793; +return_direct_with_clo1(data, ((closureN)self_73681)->elements[2], (((closure) ((closureN)self_73681)->elements[2])->fn), set_pair_as_expr(&local_73780, quote_c_91define, set_pair_as_expr(&local_73783, Cyc_cadr(data, ((closureN)self_73681)->elements[1]), set_pair_as_expr(&local_73789, ((closureN)self_73681)->elements[3], set_pair_as_expr(&local_73793, ((closureN)self_73681)->elements[0], argument_91types_7384_73424)))));} +;; +} + +static void __lambda_6(void *data, object self_73682, int argc, object *args) /* object self_73682, object k_73477 */ + { + object k_73477 = args[0]; + + + + + + + + +if( (boolean_f != Cyc_is_null(Cyc_cadr(data, Cyc_car(data, Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, ((closureN)self_73682)->elements[0]))))))))) ){ + return_direct_with_clo1(data, k_73477, (((closure) k_73477)->fn), NULL); +} else { + + + + + + + + + + + + + + +return_direct_with_clo3(data, __glo_Cyc_91map_91loop_911_scheme_base, (((closure) __glo_Cyc_91map_91loop_911_scheme_base)->fn), k_73477, ((closureN)self_73682)->elements[1], Cyc_cadr(data, Cyc_car(data, Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, Cyc_cdr(data, ((closureN)self_73682)->elements[0]))))))));} +;; +} + +static void __lambda_1(void *data, object _, int argc, object *args) /* closure _,object k_73457, object object_7366_73416 */ + { +object k_73457 = args[0]; object object_7366_73416 = args[1]; + Cyc_st_add(data, "./foreign/c/cyclone-primitives.sld:c-bytevector?"); +return_direct_with_clo2(data, __glo_opaque_127_cyclone_foreign, (((closure) __glo_opaque_127_cyclone_foreign)->fn), k_73457, object_7366_73416);; +} + +void c_foreigncprimitives_91cyclone_inlinable_lambdas(void *data, object clo, int argc, object *args){ +object buf[1]; object cont = args[0]; +buf[0] = NULL; (((closure)cont)->fn)(data, cont, 1, buf); + } +void c_foreigncprimitives_91cyclone_entry_pt_first_lambda(void *data, object clo, int argc, object *args){ +Cyc_set_globals_changed((gc_thread_data *)data); + quote_align_91of_91type = find_or_add_symbol("align-of-type"); + quote_c_91bytevector_91u8_91set_67 = find_or_add_symbol("c-bytevector-u8-set!"); + quote_c_91bytevector_91u8_91ref = find_or_add_symbol("c-bytevector-u8-ref"); + quote_include_91c_91header = find_or_add_symbol("include-c-header"); + quote_headers = find_or_add_symbol("headers"); + quote_shared_91object_91load = find_or_add_symbol("shared-object-load"); + quote_scheme_91name = find_or_add_symbol("scheme-name"); + quote_define = find_or_add_symbol("define"); + quote_begin = find_or_add_symbol("begin"); + quote_int8 = find_or_add_symbol("int8"); + quote_uint8 = find_or_add_symbol("uint8"); + quote_int16 = find_or_add_symbol("int16"); + quote_uint16 = find_or_add_symbol("uint16"); + quote_int32 = find_or_add_symbol("int32"); + quote_uint32 = find_or_add_symbol("uint32"); + quote_int64 = find_or_add_symbol("int64"); + quote_uint64 = find_or_add_symbol("uint64"); + quote_pointer = find_or_add_symbol("pointer"); + quote__void = find_or_add_symbol("void"); + quote_callback = find_or_add_symbol("callback"); + quote_c_91void = find_or_add_symbol("c-void"); + quote_opaque = find_or_add_symbol("opaque"); + quote__double = find_or_add_symbol("double"); + quote__float = find_or_add_symbol("float"); + quote_unsigned_91long = find_or_add_symbol("unsigned-long"); + quote__long = find_or_add_symbol("long"); + quote_unsigned_91int = find_or_add_symbol("unsigned-int"); + quote_unsigned_91short = find_or_add_symbol("unsigned-short"); + quote__short = find_or_add_symbol("short"); + quote_unsigned_91char = find_or_add_symbol("unsigned-char"); + quote__char = find_or_add_symbol("char"); + quote__int = find_or_add_symbol("int"); + quote_c_91define = find_or_add_symbol("c-define"); + + add_global("__glo_lib_91init_117foreigncprimitives_19191cyclone_foreign_c_primitives_91cyclone", (object *) &__glo_lib_91init_117foreigncprimitives_19191cyclone_foreign_c_primitives_91cyclone); + add_global("__glo_c_91bytevector_91u8_91ref_foreign_c_primitives_91cyclone", (object *) &__glo_c_91bytevector_91u8_91ref_foreign_c_primitives_91cyclone); + add_global("__glo_c_91bytevector_91u8_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_c_91bytevector_91u8_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_c_91bytevector_91pointer_91ref_foreign_c_primitives_91cyclone", (object *) &__glo_c_91bytevector_91pointer_91ref_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91double_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91double_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91float_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91float_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91unsigned_91long_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91unsigned_91long_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91long_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91long_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91unsigned_91int_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91unsigned_91int_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91int_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91int_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91unsigned_91short_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91unsigned_91short_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91short_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91short_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91char_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91char_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91uint64_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91uint64_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91int64_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91int64_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91uint32_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91uint32_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91int32_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91int32_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91uint16_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91uint16_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91int16_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91int16_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91uint8_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91uint8_91get_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91int8_91get_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91int8_91get_foreign_c_primitives_91cyclone); + add_global("__glo_c_91bytevector_91pointer_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_c_91bytevector_91pointer_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91double_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91double_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91float_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91float_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91unsigned_91long_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91unsigned_91long_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91long_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91long_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91unsigned_91int_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91unsigned_91int_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91int_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91int_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91unsigned_91short_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91unsigned_91short_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91short_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91short_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91char_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91char_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91uint64_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91uint64_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91int64_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91int64_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91uint32_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91uint32_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91int32_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91int32_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91uint16_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91uint16_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91int16_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91int16_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91uint8_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91uint8_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91int8_91set_67_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91int8_91set_67_foreign_c_primitives_91cyclone); + add_global("__glo_shared_91object_91load_foreign_c_primitives_91cyclone", (object *) &__glo_shared_91object_91load_foreign_c_primitives_91cyclone); + add_global("__glo_define_91c_91library_foreign_c_primitives_91cyclone", (object *) &__glo_define_91c_91library_foreign_c_primitives_91cyclone); + add_global("__glo_pointer_91address_foreign_c_primitives_91cyclone", (object *) &__glo_pointer_91address_foreign_c_primitives_91cyclone); + add_global("__glo_align_91of_91type_foreign_c_primitives_91cyclone", (object *) &__glo_align_91of_91type_foreign_c_primitives_91cyclone); + add_global("__glo_size_91of_91type_foreign_c_primitives_91cyclone", (object *) &__glo_size_91of_91type_foreign_c_primitives_91cyclone); + add_global("__glo_define_91c_91callback_foreign_c_primitives_91cyclone", (object *) &__glo_define_91c_91callback_foreign_c_primitives_91cyclone); + add_global("__glo_define_91c_91procedure_foreign_c_primitives_91cyclone", (object *) &__glo_define_91c_91procedure_foreign_c_primitives_91cyclone); + add_global("__glo_c_91bytevector_127_foreign_c_primitives_91cyclone", (object *) &__glo_c_91bytevector_127_foreign_c_primitives_91cyclone); + mclosure0(c_731322, (function_type)__lambda_55);c_731322.num_args = 0; + __glo_lib_91init_117foreigncprimitives_19191cyclone_foreign_c_primitives_91cyclone = &c_731322; + mclosure0(c_731321, (function_type)__lambda_94);c_731321.num_args = 2; + __glo_c_91bytevector_91pointer_91ref_foreign_c_primitives_91cyclone = &c_731321; + mclosure0(c_731320, (function_type)__lambda_93);c_731320.num_args = 2; + __glo_pointer_91double_91get_foreign_c_primitives_91cyclone = &c_731320; + mclosure0(c_731319, (function_type)__lambda_92);c_731319.num_args = 2; + __glo_pointer_91float_91get_foreign_c_primitives_91cyclone = &c_731319; + mclosure0(c_731318, (function_type)__lambda_91);c_731318.num_args = 2; + __glo_pointer_91unsigned_91long_91get_foreign_c_primitives_91cyclone = &c_731318; + mclosure0(c_731317, (function_type)__lambda_90);c_731317.num_args = 2; + __glo_pointer_91long_91get_foreign_c_primitives_91cyclone = &c_731317; + mclosure0(c_731316, (function_type)__lambda_89);c_731316.num_args = 2; + __glo_pointer_91unsigned_91int_91get_foreign_c_primitives_91cyclone = &c_731316; + mclosure0(c_731315, (function_type)__lambda_88);c_731315.num_args = 2; + __glo_pointer_91int_91get_foreign_c_primitives_91cyclone = &c_731315; + mclosure0(c_731314, (function_type)__lambda_87);c_731314.num_args = 2; + __glo_pointer_91unsigned_91short_91get_foreign_c_primitives_91cyclone = &c_731314; + mclosure0(c_731313, (function_type)__lambda_86);c_731313.num_args = 2; + __glo_pointer_91short_91get_foreign_c_primitives_91cyclone = &c_731313; + mclosure0(c_731312, (function_type)__lambda_85);c_731312.num_args = 2; + __glo_pointer_91char_91get_foreign_c_primitives_91cyclone = &c_731312; + mclosure0(c_731311, (function_type)__lambda_84);c_731311.num_args = 2; + __glo_pointer_91uint64_91get_foreign_c_primitives_91cyclone = &c_731311; + mclosure0(c_731310, (function_type)__lambda_83);c_731310.num_args = 2; + __glo_pointer_91int64_91get_foreign_c_primitives_91cyclone = &c_731310; + mclosure0(c_731309, (function_type)__lambda_82);c_731309.num_args = 2; + __glo_pointer_91uint32_91get_foreign_c_primitives_91cyclone = &c_731309; + mclosure0(c_731308, (function_type)__lambda_81);c_731308.num_args = 2; + __glo_pointer_91int32_91get_foreign_c_primitives_91cyclone = &c_731308; + mclosure0(c_731307, (function_type)__lambda_80);c_731307.num_args = 2; + __glo_pointer_91uint16_91get_foreign_c_primitives_91cyclone = &c_731307; + mclosure0(c_731306, (function_type)__lambda_79);c_731306.num_args = 2; + __glo_pointer_91int16_91get_foreign_c_primitives_91cyclone = &c_731306; + mclosure0(c_731305, (function_type)__lambda_78);c_731305.num_args = 2; + __glo_pointer_91uint8_91get_foreign_c_primitives_91cyclone = &c_731305; + mclosure0(c_731304, (function_type)__lambda_77);c_731304.num_args = 2; + __glo_pointer_91int8_91get_foreign_c_primitives_91cyclone = &c_731304; + mclosure0(c_731303, (function_type)__lambda_76);c_731303.num_args = 3; + __glo_c_91bytevector_91pointer_91set_67_foreign_c_primitives_91cyclone = &c_731303; + mclosure0(c_731302, (function_type)__lambda_75);c_731302.num_args = 3; + __glo_pointer_91double_91set_67_foreign_c_primitives_91cyclone = &c_731302; + mclosure0(c_731301, (function_type)__lambda_74);c_731301.num_args = 3; + __glo_pointer_91float_91set_67_foreign_c_primitives_91cyclone = &c_731301; + mclosure0(c_731300, (function_type)__lambda_73);c_731300.num_args = 3; + __glo_pointer_91unsigned_91long_91set_67_foreign_c_primitives_91cyclone = &c_731300; + mclosure0(c_731299, (function_type)__lambda_72);c_731299.num_args = 3; + __glo_pointer_91long_91set_67_foreign_c_primitives_91cyclone = &c_731299; + mclosure0(c_731298, (function_type)__lambda_71);c_731298.num_args = 3; + __glo_pointer_91unsigned_91int_91set_67_foreign_c_primitives_91cyclone = &c_731298; + mclosure0(c_731297, (function_type)__lambda_70);c_731297.num_args = 3; + __glo_pointer_91int_91set_67_foreign_c_primitives_91cyclone = &c_731297; + mclosure0(c_731296, (function_type)__lambda_69);c_731296.num_args = 3; + __glo_pointer_91unsigned_91short_91set_67_foreign_c_primitives_91cyclone = &c_731296; + mclosure0(c_731295, (function_type)__lambda_68);c_731295.num_args = 3; + __glo_pointer_91short_91set_67_foreign_c_primitives_91cyclone = &c_731295; + mclosure0(c_731294, (function_type)__lambda_67);c_731294.num_args = 3; + __glo_pointer_91char_91set_67_foreign_c_primitives_91cyclone = &c_731294; + mclosure0(c_731293, (function_type)__lambda_66);c_731293.num_args = 3; + __glo_pointer_91uint64_91set_67_foreign_c_primitives_91cyclone = &c_731293; + mclosure0(c_731292, (function_type)__lambda_65);c_731292.num_args = 3; + __glo_pointer_91int64_91set_67_foreign_c_primitives_91cyclone = &c_731292; + mclosure0(c_731291, (function_type)__lambda_64);c_731291.num_args = 3; + __glo_pointer_91uint32_91set_67_foreign_c_primitives_91cyclone = &c_731291; + mclosure0(c_731290, (function_type)__lambda_63);c_731290.num_args = 3; + __glo_pointer_91int32_91set_67_foreign_c_primitives_91cyclone = &c_731290; + mclosure0(c_731289, (function_type)__lambda_62);c_731289.num_args = 3; + __glo_pointer_91uint16_91set_67_foreign_c_primitives_91cyclone = &c_731289; + mclosure0(c_731288, (function_type)__lambda_61);c_731288.num_args = 3; + __glo_pointer_91int16_91set_67_foreign_c_primitives_91cyclone = &c_731288; + mclosure0(c_731287, (function_type)__lambda_60);c_731287.num_args = 3; + __glo_pointer_91uint8_91set_67_foreign_c_primitives_91cyclone = &c_731287; + mclosure0(c_731286, (function_type)__lambda_59);c_731286.num_args = 3; + __glo_pointer_91int8_91set_67_foreign_c_primitives_91cyclone = &c_731286; + mmacro(c_731255, (function_type)__lambda_50);c_731255.num_args = 3; + __glo_shared_91object_91load_foreign_c_primitives_91cyclone = &c_731255; + mmacro(c_731084, (function_type)__lambda_32);c_731084.num_args = 3; + __glo_define_91c_91library_foreign_c_primitives_91cyclone = &c_731084; + mclosure0(c_731083, (function_type)__lambda_58);c_731083.num_args = 1; + __glo_pointer_91address_foreign_c_primitives_91cyclone = &c_731083; + mclosure0(c_731005, (function_type)__lambda_31);c_731005.num_args = 1; + __glo_size_91of_91type_foreign_c_primitives_91cyclone = &c_731005; + mclosure0(c_731002, (function_type)__lambda_30);c_731002.num_args = 4; + __glo_define_91c_91callback_foreign_c_primitives_91cyclone = &c_731002; + mmacro(c_73708, (function_type)__lambda_2);c_73708.num_args = 3; + __glo_define_91c_91procedure_foreign_c_primitives_91cyclone = &c_73708; + mclosure0(c_73706, (function_type)__lambda_1);c_73706.num_args = 1; + __glo_c_91bytevector_127_foreign_c_primitives_91cyclone = &c_73706; + __glo_c_91bytevector_91u8_91ref_foreign_c_primitives_91cyclone = boolean_f; + __glo_c_91bytevector_91u8_91set_67_foreign_c_primitives_91cyclone = boolean_f; + __glo_align_91of_91type_foreign_c_primitives_91cyclone = boolean_f; + + mclosure0(clo_731341, c_foreigncprimitives_91cyclone_inlinable_lambdas); make_pair(pair_731340, find_or_add_symbol("c_foreigncprimitives_91cyclone_inlinable_lambdas"), &clo_731341); + make_cvar(cvar_731342, (object *)&__glo_lib_91init_117foreigncprimitives_19191cyclone_foreign_c_primitives_91cyclone);make_pair(pair_731343, find_or_add_symbol("lib-init:foreigncprimitives_91cyclone"), &cvar_731342); + make_cvar(cvar_731344, (object *)&__glo_c_91bytevector_91u8_91ref_foreign_c_primitives_91cyclone);make_pair(pair_731345, find_or_add_symbol("c-bytevector-u8-ref"), &cvar_731344); + make_cvar(cvar_731346, (object *)&__glo_c_91bytevector_91u8_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731347, find_or_add_symbol("c-bytevector-u8-set!"), &cvar_731346); + make_cvar(cvar_731348, (object *)&__glo_c_91bytevector_91pointer_91ref_foreign_c_primitives_91cyclone);make_pair(pair_731349, find_or_add_symbol("c-bytevector-pointer-ref"), &cvar_731348); + make_cvar(cvar_731350, (object *)&__glo_pointer_91double_91get_foreign_c_primitives_91cyclone);make_pair(pair_731351, find_or_add_symbol("pointer-double-get"), &cvar_731350); + make_cvar(cvar_731352, (object *)&__glo_pointer_91float_91get_foreign_c_primitives_91cyclone);make_pair(pair_731353, find_or_add_symbol("pointer-float-get"), &cvar_731352); + make_cvar(cvar_731354, (object *)&__glo_pointer_91unsigned_91long_91get_foreign_c_primitives_91cyclone);make_pair(pair_731355, find_or_add_symbol("pointer-unsigned-long-get"), &cvar_731354); + make_cvar(cvar_731356, (object *)&__glo_pointer_91long_91get_foreign_c_primitives_91cyclone);make_pair(pair_731357, find_or_add_symbol("pointer-long-get"), &cvar_731356); + make_cvar(cvar_731358, (object *)&__glo_pointer_91unsigned_91int_91get_foreign_c_primitives_91cyclone);make_pair(pair_731359, find_or_add_symbol("pointer-unsigned-int-get"), &cvar_731358); + make_cvar(cvar_731360, (object *)&__glo_pointer_91int_91get_foreign_c_primitives_91cyclone);make_pair(pair_731361, find_or_add_symbol("pointer-int-get"), &cvar_731360); + make_cvar(cvar_731362, (object *)&__glo_pointer_91unsigned_91short_91get_foreign_c_primitives_91cyclone);make_pair(pair_731363, find_or_add_symbol("pointer-unsigned-short-get"), &cvar_731362); + make_cvar(cvar_731364, (object *)&__glo_pointer_91short_91get_foreign_c_primitives_91cyclone);make_pair(pair_731365, find_or_add_symbol("pointer-short-get"), &cvar_731364); + make_cvar(cvar_731366, (object *)&__glo_pointer_91char_91get_foreign_c_primitives_91cyclone);make_pair(pair_731367, find_or_add_symbol("pointer-char-get"), &cvar_731366); + make_cvar(cvar_731368, (object *)&__glo_pointer_91uint64_91get_foreign_c_primitives_91cyclone);make_pair(pair_731369, find_or_add_symbol("pointer-uint64-get"), &cvar_731368); + make_cvar(cvar_731370, (object *)&__glo_pointer_91int64_91get_foreign_c_primitives_91cyclone);make_pair(pair_731371, find_or_add_symbol("pointer-int64-get"), &cvar_731370); + make_cvar(cvar_731372, (object *)&__glo_pointer_91uint32_91get_foreign_c_primitives_91cyclone);make_pair(pair_731373, find_or_add_symbol("pointer-uint32-get"), &cvar_731372); + make_cvar(cvar_731374, (object *)&__glo_pointer_91int32_91get_foreign_c_primitives_91cyclone);make_pair(pair_731375, find_or_add_symbol("pointer-int32-get"), &cvar_731374); + make_cvar(cvar_731376, (object *)&__glo_pointer_91uint16_91get_foreign_c_primitives_91cyclone);make_pair(pair_731377, find_or_add_symbol("pointer-uint16-get"), &cvar_731376); + make_cvar(cvar_731378, (object *)&__glo_pointer_91int16_91get_foreign_c_primitives_91cyclone);make_pair(pair_731379, find_or_add_symbol("pointer-int16-get"), &cvar_731378); + make_cvar(cvar_731380, (object *)&__glo_pointer_91uint8_91get_foreign_c_primitives_91cyclone);make_pair(pair_731381, find_or_add_symbol("pointer-uint8-get"), &cvar_731380); + make_cvar(cvar_731382, (object *)&__glo_pointer_91int8_91get_foreign_c_primitives_91cyclone);make_pair(pair_731383, find_or_add_symbol("pointer-int8-get"), &cvar_731382); + make_cvar(cvar_731384, (object *)&__glo_c_91bytevector_91pointer_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731385, find_or_add_symbol("c-bytevector-pointer-set!"), &cvar_731384); + make_cvar(cvar_731386, (object *)&__glo_pointer_91double_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731387, find_or_add_symbol("pointer-double-set!"), &cvar_731386); + make_cvar(cvar_731388, (object *)&__glo_pointer_91float_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731389, find_or_add_symbol("pointer-float-set!"), &cvar_731388); + make_cvar(cvar_731390, (object *)&__glo_pointer_91unsigned_91long_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731391, find_or_add_symbol("pointer-unsigned-long-set!"), &cvar_731390); + make_cvar(cvar_731392, (object *)&__glo_pointer_91long_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731393, find_or_add_symbol("pointer-long-set!"), &cvar_731392); + make_cvar(cvar_731394, (object *)&__glo_pointer_91unsigned_91int_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731395, find_or_add_symbol("pointer-unsigned-int-set!"), &cvar_731394); + make_cvar(cvar_731396, (object *)&__glo_pointer_91int_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731397, find_or_add_symbol("pointer-int-set!"), &cvar_731396); + make_cvar(cvar_731398, (object *)&__glo_pointer_91unsigned_91short_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731399, find_or_add_symbol("pointer-unsigned-short-set!"), &cvar_731398); + make_cvar(cvar_731400, (object *)&__glo_pointer_91short_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731401, find_or_add_symbol("pointer-short-set!"), &cvar_731400); + make_cvar(cvar_731402, (object *)&__glo_pointer_91char_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731403, find_or_add_symbol("pointer-char-set!"), &cvar_731402); + make_cvar(cvar_731404, (object *)&__glo_pointer_91uint64_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731405, find_or_add_symbol("pointer-uint64-set!"), &cvar_731404); + make_cvar(cvar_731406, (object *)&__glo_pointer_91int64_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731407, find_or_add_symbol("pointer-int64-set!"), &cvar_731406); + make_cvar(cvar_731408, (object *)&__glo_pointer_91uint32_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731409, find_or_add_symbol("pointer-uint32-set!"), &cvar_731408); + make_cvar(cvar_731410, (object *)&__glo_pointer_91int32_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731411, find_or_add_symbol("pointer-int32-set!"), &cvar_731410); + make_cvar(cvar_731412, (object *)&__glo_pointer_91uint16_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731413, find_or_add_symbol("pointer-uint16-set!"), &cvar_731412); + make_cvar(cvar_731414, (object *)&__glo_pointer_91int16_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731415, find_or_add_symbol("pointer-int16-set!"), &cvar_731414); + make_cvar(cvar_731416, (object *)&__glo_pointer_91uint8_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731417, find_or_add_symbol("pointer-uint8-set!"), &cvar_731416); + make_cvar(cvar_731418, (object *)&__glo_pointer_91int8_91set_67_foreign_c_primitives_91cyclone);make_pair(pair_731419, find_or_add_symbol("pointer-int8-set!"), &cvar_731418); + make_cvar(cvar_731420, (object *)&__glo_shared_91object_91load_foreign_c_primitives_91cyclone);make_pair(pair_731421, find_or_add_symbol("shared-object-load"), &cvar_731420); + make_cvar(cvar_731422, (object *)&__glo_define_91c_91library_foreign_c_primitives_91cyclone);make_pair(pair_731423, find_or_add_symbol("define-c-library"), &cvar_731422); + make_cvar(cvar_731424, (object *)&__glo_pointer_91address_foreign_c_primitives_91cyclone);make_pair(pair_731425, find_or_add_symbol("pointer-address"), &cvar_731424); + make_cvar(cvar_731426, (object *)&__glo_align_91of_91type_foreign_c_primitives_91cyclone);make_pair(pair_731427, find_or_add_symbol("align-of-type"), &cvar_731426); + make_cvar(cvar_731428, (object *)&__glo_size_91of_91type_foreign_c_primitives_91cyclone);make_pair(pair_731429, find_or_add_symbol("size-of-type"), &cvar_731428); + make_cvar(cvar_731430, (object *)&__glo_define_91c_91callback_foreign_c_primitives_91cyclone);make_pair(pair_731431, find_or_add_symbol("define-c-callback"), &cvar_731430); + make_cvar(cvar_731432, (object *)&__glo_define_91c_91procedure_foreign_c_primitives_91cyclone);make_pair(pair_731433, find_or_add_symbol("define-c-procedure"), &cvar_731432); + make_cvar(cvar_731434, (object *)&__glo_c_91bytevector_127_foreign_c_primitives_91cyclone);make_pair(pair_731435, find_or_add_symbol("c-bytevector?"), &cvar_731434); +make_pair(c_731483, &pair_731340,Cyc_global_variables); +make_pair(c_731482, &pair_731343, &c_731483); +make_pair(c_731481, &pair_731345, &c_731482); +make_pair(c_731480, &pair_731347, &c_731481); +make_pair(c_731479, &pair_731349, &c_731480); +make_pair(c_731478, &pair_731351, &c_731479); +make_pair(c_731477, &pair_731353, &c_731478); +make_pair(c_731476, &pair_731355, &c_731477); +make_pair(c_731475, &pair_731357, &c_731476); +make_pair(c_731474, &pair_731359, &c_731475); +make_pair(c_731473, &pair_731361, &c_731474); +make_pair(c_731472, &pair_731363, &c_731473); +make_pair(c_731471, &pair_731365, &c_731472); +make_pair(c_731470, &pair_731367, &c_731471); +make_pair(c_731469, &pair_731369, &c_731470); +make_pair(c_731468, &pair_731371, &c_731469); +make_pair(c_731467, &pair_731373, &c_731468); +make_pair(c_731466, &pair_731375, &c_731467); +make_pair(c_731465, &pair_731377, &c_731466); +make_pair(c_731464, &pair_731379, &c_731465); +make_pair(c_731463, &pair_731381, &c_731464); +make_pair(c_731462, &pair_731383, &c_731463); +make_pair(c_731461, &pair_731385, &c_731462); +make_pair(c_731460, &pair_731387, &c_731461); +make_pair(c_731459, &pair_731389, &c_731460); +make_pair(c_731458, &pair_731391, &c_731459); +make_pair(c_731457, &pair_731393, &c_731458); +make_pair(c_731456, &pair_731395, &c_731457); +make_pair(c_731455, &pair_731397, &c_731456); +make_pair(c_731454, &pair_731399, &c_731455); +make_pair(c_731453, &pair_731401, &c_731454); +make_pair(c_731452, &pair_731403, &c_731453); +make_pair(c_731451, &pair_731405, &c_731452); +make_pair(c_731450, &pair_731407, &c_731451); +make_pair(c_731449, &pair_731409, &c_731450); +make_pair(c_731448, &pair_731411, &c_731449); +make_pair(c_731447, &pair_731413, &c_731448); +make_pair(c_731446, &pair_731415, &c_731447); +make_pair(c_731445, &pair_731417, &c_731446); +make_pair(c_731444, &pair_731419, &c_731445); +make_pair(c_731443, &pair_731421, &c_731444); +make_pair(c_731442, &pair_731423, &c_731443); +make_pair(c_731441, &pair_731425, &c_731442); +make_pair(c_731440, &pair_731427, &c_731441); +make_pair(c_731439, &pair_731429, &c_731440); +make_pair(c_731438, &pair_731431, &c_731439); +make_pair(c_731437, &pair_731433, &c_731438); +make_pair(c_731436, &pair_731435, &c_731437); +Cyc_global_variables = &c_731436; +object buf[1]; buf[0] = ((closure1_type *)clo)->element; +(((closure)__glo_lib_91init_117foreigncprimitives_19191cyclone_foreign_c_primitives_91cyclone)->fn)(data, buf[0], 1, buf); +} +void c_foreigncprimitives_91cyclone_entry_pt(void *data, object cont, int argc, object value){ + register_library("foreign_c_primitives_91cyclone"); + c_foreigncprimitives_91cyclone_entry_pt_first_lambda(data, cont, argc, value); +} diff --git a/foreign/c/cyclone-primitives.sld b/foreign/c/cyclone-primitives.sld new file mode 100644 index 0000000..23ecdd4 --- /dev/null +++ b/foreign/c/cyclone-primitives.sld @@ -0,0 +1,296 @@ +(define-library + (foreign c primitives-cyclone) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (cyclone foreign) + (scheme cyclone primitives)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + ;define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (begin + (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))))) + + ;; FIXME + (define align-of-type size-of-type) + + (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 c-bytevector-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-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 c-bytevector-pointer-ref + "(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)))) diff --git a/foreign/c/define-c-library.scm b/foreign/c/define-c-library.scm new file mode 100644 index 0000000..4c1d00d --- /dev/null +++ b/foreign/c/define-c-library.scm @@ -0,0 +1,160 @@ +(define-syntax define-c-library + (syntax-rules () + ((_ scheme-name headers object-name options) + (define scheme-name + (let* ((os (cond-expand (windows 'windows) (guile 'unix) (else 'unix))) + (arch (cond-expand (i386 'i386) (guile 'x86_64) (else 'x86_64))) + (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 (substring str last-index index)))) + (set! last-index (+ index 1)))) + ((equal? (length str-l) (+ index 1)) + (set! res (append res (list (substring str last-index (+ index 1))))))) + (set! index (+ index 1))))) + (for-each splitter str-l) + res))) + (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 (if (symbol=? os 'windows) "\\" "/")) + (auto-load-paths + (if (symbol=? os 'windows) + (append + (if (get-environment-variable "FOREIGN_C_LOAD_PATH") + (string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") (string-ref ";" 0)) + (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") + (string-split (get-environment-variable "PATH") (string-ref ";" 0)) + (list)) + (if (get-environment-variable "PWD") + (list (get-environment-variable "PWD")) + (list))) + (append + (if (get-environment-variable "FOREIGN_C_LOAD_PATH") + (string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") (string-ref ":" 0)) + (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") + (string-split (get-environment-variable "LD_LIBRARY_PATH") (string-ref ":" 0)) + (list)) + (if (symbol=? arch 'i386) + (list + "/lib/i386-linux-gnu" + "/usr/lib/i386-linux-gnu" + "/lib32" + "/usr/lib32") + (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 (if (symbol=? os 'windows) "" "lib")) + (platform-file-extension (if (symbol=? os 'windows) ".dll" ".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 + (if (symbol=? os 'windows) + "" + platform-file-extension) + (if (string=? version "") + "" + (string-append + (if (symbol=? os 'windows) + "-" + ".") + version)) + (if (symbol=? os 'windows) + platform-file-extension + ""))) + (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 + (gauche library-path-without-suffixes) + (racket library-path-without-suffixes) + (guile library-path) + (else library-path)))))) + versions)) + paths) + (if (not shared-object) + (error "Could not load shared object: " + (list (cons 'object object-name) + (cons 'searched-paths searched-paths) + (cons 'platform-file-extension platform-file-extension) + (cons 'versions versions))) + (cond-expand + (stklos shared-object) + (guile (shared-object-load shared-object + `((additional-versions ,additional-versions)))) + (else (shared-object-load shared-object + `((additional-versions ,additional-versions))))))))))) diff --git a/foreign/c/gambit-primitives.scm b/foreign/c/gambit-primitives.scm new file mode 100644 index 0000000..1f3e384 --- /dev/null +++ b/foreign/c/gambit-primitives.scm @@ -0,0 +1,240 @@ +(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) + (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/foreign/c/gambit-primitives.sld b/foreign/c/gambit-primitives.sld new file mode 100644 index 0000000..7ce0bd6 --- /dev/null +++ b/foreign/c/gambit-primitives.sld @@ -0,0 +1,20 @@ +(define-library + (foreign c gambit-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (only (gambit) c-declare c-lambda c-define define-macro)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + ;define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (include "gambit-primitives.scm")) diff --git a/foreign/c/gauche-primitives.scm b/foreign/c/gauche-primitives.scm new file mode 100644 index 0000000..f43a283 --- /dev/null +++ b/foreign/c/gauche-primitives.scm @@ -0,0 +1,98 @@ +(define (primitives-init set-procedure get-procedure) #t) + +(define internal-size-of-type + (lambda (type) + (cond ((eq? type 'i8) (size-of-type 'int8)) + ((eq? type 'u8) (size-of-type 'uint8)) + ((eq? type 'i16) (size-of-type 'int16)) + ((eq? type 'u16) (size-of-type 'uint16)) + ((eq? type 'i32) (size-of-type 'int32)) + ((eq? type 'u32) (size-of-type 'uint32)) + ((eq? type 'i64) (size-of-type 'int64)) + ((eq? type 'u64) (size-of-type 'uint64)) + ((eq? type 'char) (size-of-type 'char)) + ((eq? type 'uchar) (size-of-type 'char)) + ((eq? type 'short) (size-of-type 'short)) + ((eq? type 'ushort) (size-of-type 'unsigned-short)) + ((eq? type 'int) (size-of-type 'int)) + ((eq? type 'uint) (size-of-type 'unsigned-int)) + ((eq? type 'long) (size-of-type 'long)) + ((eq? type 'ulong) (size-of-type 'unsigned-long)) + ((eq? type 'float) (size-of-type 'float)) + ((eq? type 'double) (size-of-type 'double)) + ((eq? type 'pointer) (size-of-type 'pointer))))) + +(define internal-align-of-type + (lambda (type) + (cond ((eq? type 'i8) (align-of-type 'int8)) + ((eq? type 'u8) (align-of-type 'uint8)) + ((eq? type 'i16) (align-of-type 'int16)) + ((eq? type 'u16) (align-of-type 'uint16)) + ((eq? type 'i32) (align-of-type 'int32)) + ((eq? type 'u32) (align-of-type 'uint32)) + ((eq? type 'i64) (align-of-type 'int64)) + ((eq? type 'u64) (align-of-type 'uint64)) + ((eq? type 'char) (align-of-type 'char)) + ((eq? type 'uchar) (align-of-type 'char)) + ((eq? type 'short) (align-of-type 'short)) + ((eq? type 'ushort) (align-of-type 'unsigned-short)) + ((eq? type 'int) (align-of-type 'int)) + ((eq? type 'uint) (align-of-type 'unsigned-int)) + ((eq? type 'long) (align-of-type 'long)) + ((eq? type 'ulong) (align-of-type 'unsigned-long)) + ((eq? type 'float) (align-of-type 'float)) + ((eq? type 'double) (align-of-type 'double)) + ((eq? type 'pointer) (align-of-type 'pointer))))) + +(define shared-object-load + (lambda (path options) + (if (null? options) + (open-shared-library path) + (open-shared-library path (cadr (assoc 'additional-versions options)))))) + +(define type->native-type + (lambda (type) + (cond ((equal? type 'i8) 'int8) + ((equal? type 'u8) 'uint8) + ((equal? type 'i16) 'int16) + ((equal? type 'u16) 'uint16) + ((equal? type 'i32) 'int32) + ((equal? type 'u32) 'uint32) + ((equal? type 'i64) 'int64) + ((equal? type 'u64) 'uint64) + ((equal? type 'char) 'char) + ((equal? type 'uchar) 'char) + ((equal? type 'short) 'short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'uint) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'ulong) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'pointer) + ((equal? type 'void) 'pointer) + ((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 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 make-c-null null-pointer) +(define c-null? null-pointer?) + + diff --git a/foreign/c/gauche-primitives.sld b/foreign/c/gauche-primitives.sld new file mode 100644 index 0000000..f4033c5 --- /dev/null +++ b/foreign/c/gauche-primitives.sld @@ -0,0 +1,24 @@ +(define-library + (foreign c gauche-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (gauche ffi)) + (export primitives-init + internal-size-of-type + align-of-type + shared-object-load + define-c-procedure + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null + c-null? + (rename internal-size-of-type size-of-type) + (rename internal-align-of-type align-of-type)) + (include "gauche-primitives.scm")) diff --git a/foreign/c/guile-primitives.scm b/foreign/c/guile-primitives.scm new file mode 100644 index 0000000..9a4cd57 --- /dev/null +++ b/foreign/c/guile-primitives.scm @@ -0,0 +1,96 @@ +(define (primitives-init set-procedure get-procedure) + #t) + +(define os 'unix) +(define implementation 'guile) +(define arch 'x86_64) +(define libc-name "c") + +(define type->native-type + (lambda (type) + (cond ((equal? type 'i8) int8) + ((equal? type 'u8) uint8) + ((equal? type 'i16) int16) + ((equal? type 'u16) uint16) + ((equal? type 'i32) int32) + ((equal? type 'u32) uint32) + ((equal? type 'i64) int64) + ((equal? type 'u64) uint64) + ((equal? type 'char) int8) + ((equal? type 'uchar) uint8) + ((equal? type 'short) short) + ((equal? type 'ushort) unsigned-short) + ((equal? type 'int) int) + ((equal? type 'uint) unsigned-int) + ((equal? type 'long) long) + ((equal? type 'ulong) unsigned-long) + ((equal? type 'float) float) + ((equal? type 'double) double) + ((equal? type 'pointer) '*) + ((equal? type 'void) void) + ((equal? type 'callback) '*) + (else #f)))) + +(define c-bytevector? + (lambda (object) + (pointer? object))) + +(define-syntax define-c-procedure + (syntax-rules () + ((_ scheme-name shared-object c-name return-type argument-types) + (define scheme-name + (pointer->procedure (type->native-type return-type) + (foreign-library-pointer shared-object + (symbol->string 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 + (procedure->pointer (type->native-type return-type) + procedure + (map type->native-type argument-types)))))) + +(define size-of-type + (lambda (type) + (let ((native-type (type->native-type type))) + (cond ((equal? native-type void) 0) + (native-type (sizeof native-type)) + (else #f))))) + +(define align-of-type + (lambda (type) + (let ((native-type (type->native-type type))) + (cond ((equal? native-type void) 0) + (native-type (alignof native-type)) + (else #f))))) + +(define shared-object-load + (lambda (path options) + (load-foreign-library path))) + +(define (c-bytevector-u8-set! cbv offset byte) + (bytevector-u8-set! (pointer->bytevector cbv (+ offset 100)) offset byte)) + +(define (c-bytevector-u8-ref cbv offset) + (bytevector-u8-ref (pointer->bytevector cbv (+ offset 100)) offset)) + +(define (c-bytevector-pointer-set! cbv offset pointer) + (bytevector-uint-set! (pointer->bytevector cbv (+ offset 100)) + offset + (pointer-address pointer) + (native-endianness) + (size-of-type 'uint))) + +(define (c-bytevector-pointer-ref cbv offset) + (make-pointer (bytevector-uint-ref (pointer->bytevector cbv (+ offset 100)) + offset + (native-endianness) + (size-of-type 'uint)))) + +(define (make-c-null) (make-pointer (pointer-address %null-pointer))) + +(define (c-null? pointer) + (and (pointer? pointer) + (null-pointer? pointer))) diff --git a/foreign/c/guile-primitives.sld b/foreign/c/guile-primitives.sld new file mode 100644 index 0000000..73b01a2 --- /dev/null +++ b/foreign/c/guile-primitives.sld @@ -0,0 +1,29 @@ +(define-library + (foreign c guile-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (system foreign) + (system foreign-library)) + (export primitives-init + size-of-type + align-of-type + shared-object-load + define-c-procedure + ;define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null + c-null? + ;; Guile specific + implementation + os + arch + libc-name) + (include "guile-primitives.scm")) diff --git a/foreign/c/ikarus-primitives.sld b/foreign/c/ikarus-primitives.sld new file mode 100644 index 0000000..430072b --- /dev/null +++ b/foreign/c/ikarus-primitives.sld @@ -0,0 +1,123 @@ +(define-library + (foreign c ikarus-primitives) + (export primitives-init + size-of-type + align-of-type + shared-object-load + define-c-procedure + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null + c-null?) + (import (rnrs base) + (rnrs lists) + (rnrs control) + (rnrs files) + (rnrs io simple) + (rnrs programs) + (only (rnrs bytevectors) + make-bytevector + bytevector-length + utf8->string + string->utf8 + bytevector-u8-ref + bytevector-u8-set!) + (only (rnrs r5rs) + remainder + quotient) + (ikarus include) + (ikarus foreign)) + (begin + (define (primitives-init set-procedure get-procedure) #t) + + (define size-of-type + (lambda (type) + (cond ((eq? type 'i8) 1) + ((eq? type 'u8) 1) + ((eq? type 'i16) 2) + ((eq? type 'u16) 2) + ((eq? type 'i32) 4) + ((eq? type 'u32) 4) + ((eq? type 'i64) 8) + ((eq? type 'u64) 8) + ((eq? type 'char) 1) + ((eq? type 'uchar) 1) + ((eq? type 'short) 2) + ((eq? type 'ushort) 2) + ((eq? type 'int) 4) + ((eq? type 'uint) 4) + ((eq? type 'long) 8) + ((eq? type 'ulong) 8) + ((eq? type 'float) 4) + ((eq? type 'double) 8) + ((eq? type 'pointer) 8) + ((eq? type 'void) 0) + (else #f)))) + + ;; FIXME + (define align-of-type size-of-type) + + (define (type->native-type type) + (cond ((equal? type 'i8) 'signed-char) + ((equal? type 'u8) 'unsigned-char) + ((equal? type 'i16) 'signed-short) + ((equal? type 'u16) 'unsigned-short) + ((equal? type 'i32) 'signed-int) + ((equal? type 'u32) 'unsigned-int) + ((equal? type 'i64) 'signed-long) + ((equal? type 'u64) 'unsigned-long) + ((equal? type 'char) 'signed-char) + ((equal? type 'uchar) 'unsigned-char) + ((equal? type 'short) 'signed-short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'signed-int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'signed-long) + ((equal? type 'ulong) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'pointer) + ((equal? type 'void) 'void) + (error "Unsupported type: " type))) + + (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 + ((make-c-callout (type->native-type return-type) + (map type->native-type argument-types)) + (dlsym shared-object (symbol->string c-name))))))) + + (define shared-object-load + (lambda (path options) + (dlopen path))) + + (define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + (pointer-set-c-char! c-bytevector k byte))) + + (define c-bytevector-u8-ref + (lambda (c-bytevector k) + (pointer-ref-c-unsigned-char c-bytevector k))) + + (define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (pointer-set-c-pointer! c-bytevector k pointer))) + + (define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (pointer-ref-c-pointer c-bytevector k))) + + (define (make-c-null) + (integer->pointer 0)) + + (define (c-null? pointer) + (and (pointer? pointer) + (= (pointer->integer pointer) 0))))) diff --git a/foreign/c/ironscheme-primitives.sld b/foreign/c/ironscheme-primitives.sld new file mode 100644 index 0000000..4fa3a2a --- /dev/null +++ b/foreign/c/ironscheme-primitives.sld @@ -0,0 +1,140 @@ +(define-library + (foreign c ironscheme-primitives) + (import (rnrs base) + (rnrs lists) + (rnrs control) + (rnrs files) + (rnrs io simple) + (rnrs programs) + (only (rnrs bytevectors) + make-bytevector + bytevector-length + utf8->string + string->utf8 + bytevector-u8-ref + bytevector-u8-set!) + (only (rnrs r5rs) + remainder + quotient) + (ironscheme) + (ironscheme clr) + (ironscheme clr internal) + (ironscheme ffi) + (srfi :0)) + (export primitives-init + size-of-type + align-of-type + shared-object-load + define-c-procedure + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null + c-null?) + (begin + (clr-using System.Runtime.InteropServices) + + (define (primitives-init set-procedure get-procedure) #t) + + ;; FIXME + (define size-of-type + (lambda (type) + (cond ((eq? type 'i8) 1) + ((eq? type 'u8) 1) + ((eq? type 'i16) 2) + ((eq? type 'u16) 2) + ((eq? type 'i32) 4) + ((eq? type 'u32) 4) + ((eq? type 'i64) 8) + ((eq? type 'u64) 8) + ((eq? type 'char) 1) + ((eq? type 'uchar) 1) + ((eq? type 'short) 2) + ((eq? type 'ushort) 2) + ((eq? type 'int) 4) + ((eq? type 'unsigned-int) 4) + ((eq? type 'long) 8) + ((eq? type 'ulong) 8) + ((eq? type 'float) 4) + ((eq? type 'double) 8) + ((eq? type 'pointer) 8) + ((eq? type 'void) 0) + (else #f)))) + + ;; FIXME + (define align-of-type size-of-type) + + ;; FIXME + (define (type->native-type type) + (cond ((equal? type 'i8) 'int8) + ((equal? type 'u8) 'uint8) + ((equal? type 'i16) 'int16) + ((equal? type 'u16) 'uint16) + ((equal? type 'i32) 'int32) + ((equal? type 'u32) 'uint32) + ((equal? type 'i64) 'in64) + ((equal? type 'u64) 'uint64) + ((equal? type 'char) 'char) + ((equal? type 'uchar) 'uchar) + ((equal? type 'short) 'int16) + ((equal? type 'ushort) 'uint16) + ((equal? type 'int) 'int32) + ((equal? type 'uint) 'uint32) + ((equal? type 'long) 'int64) + ((equal? type 'ulong) 'uint64) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'void) 'void) + ((equal? type 'pointer) 'void*) + (error "Unsupported type: " type))) + + (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 + ((make-ffi-callout (type->native-type return-type) + (map type->native-type argument-types)) + (cond-expand + (windows (dlsym shared-object (symbol->string c-name))) + (else (apply (pinvoke-call libc dlsym void* (void* string)) + (list shared-object (symbol->string c-name)))))))))) + + (define shared-object-load + (lambda (path options) + (cond-expand + (windows (dlopen path)) + (else (apply (pinvoke-call libc dlopen void* (string int)) + (list path 0)))))) + + (define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + (clr-static-call Marshal + (WriteByte IntPtr Int32 Byte) + c-bytevector + k + (clr-static-call Convert (ToByte Int32) byte)))) + + (define c-bytevector-u8-ref + (lambda (c-bytevector k) + (clr-static-call Convert + (ToInt32 Byte) + (clr-static-call Marshal (ReadByte IntPtr Int32) c-bytevector k)))) + + (define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (write-intptr! c-bytevector k pointer))) + + (define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (read-intptr c-bytevector k))) + + (define make-c-null null-pointer) + (define (c-null? pointer) + (and (pointer? pointer) + (null-pointer? pointer))))) diff --git a/foreign/c/kawa-primitives.scm b/foreign/c/kawa-primitives.scm new file mode 100644 index 0000000..580b294 --- /dev/null +++ b/foreign/c/kawa-primitives.scm @@ -0,0 +1,175 @@ +(define (primitives-init set-procedure get-procedure) #t) + +(define arena (invoke-static java.lang.foreign.Arena 'global)) +(define method-handle-lookup (invoke-static java.lang.invoke.MethodHandles 'lookup)) +(define native-linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) +(define INTEGER-MAX-VALUE (static-field java.lang.Integer 'MAX_VALUE)) + +(define value->object + (lambda (value type) + (cond ((equal? type 'byte) + (java.lang.Byte value)) + ((equal? type 'int8) + (java.lang.Integer value)) + ((equal? type 'uint8) + (java.lang.Integer value)) + ((equal? type 'short) + (java.lang.Short value)) + ((equal? type 'unsigned-short) + (java.lang.Short value)) + ((equal? type 'int) + (java.lang.Integer value)) + ((equal? type 'unsigned-int) + (java.lang.Integer value)) + ((equal? type 'long) + (java.lang.Long value)) + ((equal? type 'unsigned-long) + (java.lang.Long value)) + ((equal? type 'float) + (java.lang.Float value)) + ((equal? type 'double) + (java.lang.Double value)) + ((equal? type 'char) + (java.lang.Char value)) + (else value)))) + +(define type->native-type + (lambda (type) + (cond + ((equal? type 'i8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 1)) + ((equal? type 'u8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1)) + ((equal? type 'i16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) + ((equal? type 'u16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) + ((equal? type 'i32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) + ((equal? type 'u32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) + ((equal? type 'i64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) + ((equal? type 'u64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) + ((equal? type 'char) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR) 'withByteAlignment 1)) + ((equal? type 'uchar) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR) 'withByteAlignment 1)) + ((equal? type 'short) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT) 'withByteAlignment 2)) + ((equal? type 'ushort) (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 'uint) (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 'ulong) (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 '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 size-of-type + (lambda (type) + (let ((native-type (type->native-type type))) + (if native-type + (invoke native-type 'byteAlignment) + #f)))) + +(define align-of-type + (lambda (type) + (let ((native-type (type->native-type type))) + (if native-type + (invoke native-type 'byteAlignment) + #f)))) + +(define shared-object-load + (lambda (path options) + (let* ((library-file (make java.io.File path)) + (file-name (invoke library-file 'getName)) + (library-parent-folder (make java.io.File (invoke library-file 'getParent))) + (absolute-path (string-append (invoke library-parent-folder 'getCanonicalPath) + "/" + file-name)) + (linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) + (lookup (invoke-static java.lang.foreign.SymbolLookup + 'libraryLookup + absolute-path + arena))) + (list (cons 'linker linker) + (cons 'lookup lookup))))) + +(define u8-value-layout + (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) + 'withByteAlignment + 1)) + +(define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + (invoke (invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE) + 'set + u8-value-layout + k + byte))) + +(define c-bytevector-u8-ref + (lambda (c-bytevector k) + (invoke (java.lang.Byte 1) + 'toUnsignedInt + (invoke + (invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE) + 'get + u8-value-layout + k)))) + +(define pointer-value-layout + (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) + 'withByteAlignment + 8)) + +(define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (invoke (invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE) + 'set + pointer-value-layout + k + pointer))) + +(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (invoke (invoke c-bytevector 'reinterpret INTEGER-MAX-VALUE) + 'get + pointer-value-layout + k))) + +;; FIXME +#;(define make-c-null + (lambda () + (static-field java.lang.foreign.MemorySegment 'NULL))) + +(define (make-c-null) + (invoke-static java.lang.foreign.MemorySegment 'ofAddress 0)) + +(define (c-null? pointer) + (and (c-bytevector? pointer) + (equal? pointer (make-c-null)))) + +(define-syntax define-c-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (error "define-c-callback not supported on kawa yet")))) diff --git a/foreign/c/kawa-primitives.sld b/foreign/c/kawa-primitives.sld new file mode 100644 index 0000000..9567374 --- /dev/null +++ b/foreign/c/kawa-primitives.sld @@ -0,0 +1,22 @@ +(define-library + (foreign c kawa-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context)) + (export primitives-init + size-of-type + align-of-type + shared-object-load + define-c-procedure + ;define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null + c-null?) + (include "kawa-primitives.scm")) diff --git a/foreign/c/larceny-primitives.scm b/foreign/c/larceny-primitives.scm new file mode 100644 index 0000000..f5ceb08 --- /dev/null +++ b/foreign/c/larceny-primitives.scm @@ -0,0 +1,105 @@ +(require 'std-ffi) +(require 'ffi-load) +(require 'foreign-ctools) +(require 'foreign-cenums) +(require 'foreign-stdlib) +(require 'foreign-sugar) +;(require 'system-interface) + +(define (type->native-type type) + (cond ((equal? type 'int8) 'char) + ((equal? type 'uint8) 'uchar) + ((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) 'void*) + ((equal? type 'void) 'void) + (error "Unsupported type: " type))) + +(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) 8) + ((eq? type 'void) 0) + (else (error "Can not get size of unknown type" type))))) + +(define align-of-type size-of-type) + +(define c-bytevector? + (lambda (object) + ;(void*? object) + (number? object))) + +(define shared-object-load + (lambda (path . options) + (foreign-file path))) + +(define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + ;; FIXME + #;(syscall syscall:poke-bytes c-bytevector k (size-of-type 'uint8) byte) + #t + )) + +(define c-bytevector-u8-ref + (lambda (c-bytevector k) + ;; FIXME + #;(syscall syscall:peek-bytes c-bytevector k (size-of-type 'uint8)) + #t + )) + +(define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + ;; FIXME + #;(syscall syscall:poke-bytes c-bytevector k (size-of-type 'pointer) pointer) + #t + )) + +(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + ;; FIXME + #;(syscall syscall:peek-bytes c-bytevector k (size-of-type 'pointer)) + #t + )) + +(define-syntax define-c-procedure + (syntax-rules () + ((_ scheme-name shared-object c-name return-type argument-types) + (define scheme-name + (foreign-procedure (symbol->string c-name) + (map type->native-type argument-types) + (type->native-type return-type)))))) + +(define (make-c-null) (foreign-null-pointer)) +(define (c-null? pointer) (foreign-null-pointer?)) + diff --git a/foreign/c/larceny-primitives.sld b/foreign/c/larceny-primitives.sld new file mode 100644 index 0000000..c8b04eb --- /dev/null +++ b/foreign/c/larceny-primitives.sld @@ -0,0 +1,50 @@ +(define-library + (foreign c larceny-primitives) + (cond-expand + (r6rs (import (rnrs base) + (rnrs lists) + (rnrs control) + (rnrs files) + (rnrs io simple) + (rnrs programs) + (only (rnrs bytevectors) + make-bytevector + bytevector-length + utf8->string + string->utf8 + bytevector-u8-ref + bytevector-u8-set!) + (only (rnrs r5rs) + remainder + quotient) + (rename (primitives r5rs:require) (r5rs:require require)) + (primitives std-ffi) + (primitives foreign-procedure) + (primitives foreign-file) + (primitives foreign-stdlib) + (primitives system-interface))) + (else + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (rename (primitives r5rs:require) (r5rs:require require)) + (primitives std-ffi) + (primitives foreign-procedure) + (primitives foreign-file) + (primitives foreign-stdlib) + (primitives system-interface)))) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null + c-null?) + (include "larceny-primitives.scm")) diff --git a/foreign/c/libc.scm b/foreign/c/libc.scm new file mode 100644 index 0000000..a7322d2 --- /dev/null +++ b/foreign/c/libc.scm @@ -0,0 +1,32 @@ +(define libc-name + (cond-expand + (windows "ucrtbase") + (haiku "root") + (guile "c") + (else "c"))) +(define-c-library libc + '("stdlib.h" "stdio.h" "string.h") + libc-name + '((additional-versions ("0" "6")))) + +(define-c-procedure c-malloc libc 'malloc 'pointer '(int)) +(define-c-procedure c-calloc libc 'calloc 'pointer '(int int)) +(define-c-procedure c-perror libc 'perror 'void '(pointer)) +(define-c-procedure c-free libc 'free 'void '(pointer)) +(define-c-procedure c-strlen libc 'strlen 'int '(pointer)) +(define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(u64 u8 int)) +(define-c-procedure c-memset-pointer->address libc 'memset 'u64 '(pointer u8 int)) + +(cond-expand + ;; FIXME + (ypsilon + (define (make-c-null) (c-memset-address->pointer 0 0 0)) + (define (c-null? pointer) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (x) (k #f)) + (lambda () + (and (c-bytevector? pointer) + (= (c-memset-pointer->address pointer 0 0) 0)))))))) + (else)) diff --git a/foreign/c/mit-scheme-primitives.sld b/foreign/c/mit-scheme-primitives.sld new file mode 100644 index 0000000..8d8e329 --- /dev/null +++ b/foreign/c/mit-scheme-primitives.sld @@ -0,0 +1,34 @@ +(define-library + (foreign c mit-scheme-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context)) + (export size-of-type + align-of-type + shared-object-load + define-c-procedure + ;define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set!) + (begin + +(declare (usual-integrations)) +(load-option 'ffi) + +;(define lib (dld-load-file "mit-scheme-foreign-c-shim.so")) +(C-include "mit-scheme-foreign-c") + +(define (hello) + (puts "Hello from puts") + ;(display "Not from puts") + (newline) + ) +;(C-call "puts" "Hello world") + ) + ) diff --git a/foreign/c/mosh-primitives.scm b/foreign/c/mosh-primitives.scm new file mode 100644 index 0000000..1df50b3 --- /dev/null +++ b/foreign/c/mosh-primitives.scm @@ -0,0 +1,113 @@ +(define (primitives-init set-procedure get-procedure) #t) + +(define size-of-type + (lambda (type) + (cond ((eq? type 'i8) 1) + ((eq? type 'u8) 1) + ((eq? type 'i16) 2) + ((eq? type 'u16) 2) + ((eq? type 'i32) 4) + ((eq? type 'u32) 4) + ((eq? type 'i64) 8) + ((eq? type 'u64) 8) + ((eq? type 'char) 1) + ((eq? type 'uchar) 1) + ((eq? type 'short) size-of-short) + ((eq? type 'ushort) size-of-unsigned-short) + ((eq? type 'int) size-of-int) + ((eq? type 'uint) size-of-unsigned-int) + ((eq? type 'long) size-of-long) + ((eq? type 'ulong) size-of-unsigned-long) + ((eq? type 'float) size-of-float) + ((eq? type 'double) size-of-double) + ((eq? type 'pointer) size-of-pointer) + ((eq? type 'callback) size-of-pointer) + ((eq? type 'void) 0) + (else #f)))) + +(define align-of-type + (lambda (type) + (cond ((eq? type 'i8) 1) + ((eq? type 'u8) 1) + ((eq? type 'i16) 2) + ((eq? type 'u16) 2) + ((eq? type 'i32) 4) + ((eq? type 'u32) 4) + ((eq? type 'i64) 8) + ((eq? type 'u64) 8) + ((eq? type 'char) 1) + ((eq? type 'uchar) 1) + ((eq? type 'short) align-of-short) + ((eq? type 'ushort) align-of-short) + ((eq? type 'int) align-of-int) + ((eq? type 'uint) align-of-int) + ((eq? type 'long) align-of-long) + ((eq? type 'ulong) align-of-unsigned-long) + ((eq? type 'float) align-of-float) + ((eq? type 'double) align-of-double) + ((eq? type 'pointer) align-of-void*) + ((eq? type 'callback) align-of-void*) + ((eq? type 'void) 0) + (else #f)))) + +(define shared-object-load + (lambda (path options) + (open-shared-library path))) + +(define c-bytevector? + (lambda (object) + (pointer? object))) + +(define c-bytevector-u8-set! pointer-set-c-uint8!) +(define c-bytevector-u8-ref pointer-ref-c-uint8) +(define c-bytevector-pointer-set! + (lambda (pointer offset value) + (pointer-set-c-pointer! pointer offset value))) +(define c-bytevector-pointer-ref + (lambda (pointer offset) + (pointer-ref-c-pointer pointer offset))) + +(define type->native-type + (lambda (type) + (cond ((equal? type 'i8) 'int8_t) + ((equal? type 'u8) 'uint8_t) + ((equal? type 'i16) 'int16_t) + ((equal? type 'u16) 'uint16_t) + ((equal? type 'i32) 'int32_t) + ((equal? type 'u32) 'uint32_t) + ((equal? type 'i64) 'int64_t) + ((equal? type 'u64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'uchar) 'char) + ((equal? type 'short) 'short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'uint) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'ulong) '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))))) + +(define (make-c-null) (integer->pointer 0)) +(define c-null? pointer-null?) diff --git a/foreign/c/mosh-primitives.sld b/foreign/c/mosh-primitives.sld new file mode 100644 index 0000000..8ea1cf9 --- /dev/null +++ b/foreign/c/mosh-primitives.sld @@ -0,0 +1,24 @@ +(define-library + (foreign c mosh-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme inexact) + (scheme process-context) + (mosh ffi)) + (export primitives-init + size-of-type + align-of-type + shared-object-load + define-c-procedure + ;define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null + c-null?) + (include "mosh-primitives.scm")) diff --git a/foreign/c/racket-primitives.rkt b/foreign/c/racket-primitives.rkt new file mode 100644 index 0000000..a15cafb --- /dev/null +++ b/foreign/c/racket-primitives.rkt @@ -0,0 +1,3 @@ +#lang r7rs +(import (except (scheme base) let let-values let*-values string-copy string-copy! string-for-each string-map string-fill! string->list)) +(include "racket-primitives.sld") diff --git a/foreign/c/racket-primitives.scm b/foreign/c/racket-primitives.scm new file mode 100644 index 0000000..4f72b31 --- /dev/null +++ b/foreign/c/racket-primitives.scm @@ -0,0 +1,86 @@ +(define (primitives-init set-procedure get-procedure) #t) + +(define type->native-type + (lambda (type) + (cond ((equal? type 'i8) _byte) + ((equal? type 'u8) _ubyte) + ((equal? type 'i16) _int16) + ((equal? type 'u16) _uint16) + ((equal? type 'i32) _int32) + ((equal? type 'u32) _uint32) + ((equal? type 'i64) _int64) + ((equal? type 'u64) _uint64) + ((equal? type 'char) _int8) + ((equal? type 'uchar) _uint8) + ((equal? type 'short) _short) + ((equal? type 'ushort) _ushort) + ((equal? type 'int) _int) + ((equal? type 'uint) _uint) + ((equal? type 'long) _long) + ((equal? type 'ulong) _ulong) + ((equal? type 'float) _float) + ((equal? type 'double) _double) + ((equal? type 'pointer) _pointer) + ((equal? type 'void) _void) + ((equal? type 'callback) _pointer) + (else #f)))) + +(define c-bytevector? + (lambda (object) + (cpointer? object))) + +(define-syntax define-c-procedure + (syntax-rules () + ((_ scheme-name shared-object c-name return-type argument-types) + (define scheme-name + (get-ffi-obj c-name + shared-object + (_cprocedure (mlist->list (map type->native-type argument-types)) + (type->native-type return-type))))))) + + +(define-syntax define-c-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name (function-ptr procedure + (_cprocedure + (mlist->list (map type->native-type argument-types)) + (type->native-type return-type))))))) + +(define size-of-type + (lambda (type) + (ctype-sizeof (type->native-type type)))) + +;; FIXME +(define align-of-type + (lambda (type) + (ctype-sizeof (type->native-type type)))) + +(define shared-object-load + (lambda (path options) + (if (and (not (null? options)) + (assoc 'additional-versions options)) + (ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions + options)) + (list #f)))) + (ffi-lib path)))) + +(define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + (ptr-set! c-bytevector _uint8 'abs k byte))) + +(define c-bytevector-u8-ref + (lambda (c-bytevector k) + (ptr-ref c-bytevector _uint8 'abs k))) + +(define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (ptr-set! c-bytevector _pointer 'abs k pointer))) + +(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (ptr-ref c-bytevector _pointer 'abs k))) + +(define (make-c-null) #f) +(define (c-null? pointer) (and (cpointer? pointer) (equal? pointer #f))) + diff --git a/foreign/c/racket-primitives.sld b/foreign/c/racket-primitives.sld new file mode 100644 index 0000000..1651bd4 --- /dev/null +++ b/foreign/c/racket-primitives.sld @@ -0,0 +1,42 @@ +(define-library + (foreign c racket-primitives) + (cond-expand + (r6rs + (import (except (rnrs) + native-endianness) + (only (racket base) + system-type + system-big-endian?) + (ffi winapi) + (compatibility mlist) + (ffi unsafe) + (ffi vector))) + (else + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (only (racket base) + system-type + system-big-endian?) + (ffi winapi) + (compatibility mlist) + (ffi unsafe) + (ffi vector)))) + (export primitives-init + size-of-type + align-of-type + shared-object-load + define-c-procedure + ;define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null ;; FIXME + c-null? ;; FIXME + ) + (include "racket-primitives.scm")) diff --git a/foreign/c/sagittarius-primitives.scm b/foreign/c/sagittarius-primitives.scm new file mode 100644 index 0000000..075ff7b --- /dev/null +++ b/foreign/c/sagittarius-primitives.scm @@ -0,0 +1,111 @@ +(define (primitives-init set-procedure get-procedure) #t) + +(define size-of-type + (lambda (type) + (cond ((eq? type 'i8) size-of-int8_t) + ((eq? type 'u8) size-of-uint8_t) + ((eq? type 'i16) size-of-int16_t) + ((eq? type 'u16) size-of-uint16_t) + ((eq? type 'i32) size-of-int32_t) + ((eq? type 'u32) size-of-uint32_t) + ((eq? type 'i64) size-of-int64_t) + ((eq? type 'u64) size-of-uint64_t) + ((eq? type 'char) size-of-char) + ((eq? type 'uchar) size-of-char) + ((eq? type 'short) size-of-short) + ((eq? type 'ushort) size-of-unsigned-short) + ((eq? type 'int) size-of-int) + ((eq? type 'uint) size-of-unsigned-int) + ((eq? type 'long) size-of-long) + ((eq? type 'ulong) size-of-unsigned-long) + ((eq? type 'float) size-of-float) + ((eq? type 'double) size-of-double) + ((eq? type 'pointer) size-of-void*) + ((eq? type 'void) 0) + ((eq? type 'callback) size-of-void*) + (else #f)))) + +(define align-of-type + (lambda (type) + (cond ((eq? type 'i8) align-of-int8_t) + ((eq? type 'u8) align-of-uint8_t) + ((eq? type 'i16) align-of-int16_t) + ((eq? type 'u16) align-of-uint16_t) + ((eq? type 'i32) align-of-int32_t) + ((eq? type 'u32) align-of-uint32_t) + ((eq? type 'i64) align-of-int64_t) + ((eq? type 'u64) align-of-uint64_t) + ((eq? type 'char) align-of-char) + ((eq? type 'uchar) align-of-char) + ((eq? type 'short) align-of-short) + ((eq? type 'ushort) align-of-unsigned-short) + ((eq? type 'int) align-of-int) + ((eq? type 'uint) align-of-unsigned-int) + ((eq? type 'long) align-of-long) + ((eq? type 'ulong) align-of-unsigned-long) + ((eq? type 'float) align-of-float) + ((eq? type 'double) align-of-double) + ((eq? type 'pointer) align-of-void*) + ((eq? type 'void) 0) + ((eq? type 'callback) align-of-void*) + (else #f)))) + +(define shared-object-load + (lambda (path options) + (open-shared-library path))) + +(define type->native-type + (lambda (type) + (cond ((equal? type 'i8) 'int8_t) + ((equal? type 'u8) 'uint8_t) + ((equal? type 'i16) 'int16_t) + ((equal? type 'u16) 'uint16_t) + ((equal? type 'i32) 'int32_t) + ((equal? type 'u32) 'uint32_t) + ((equal? type 'i64) 'int64_t) + ((equal? type 'u64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'uchar) 'char) + ((equal? type 'short) 'short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'uint) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'ulong) '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 make-c-null empty-pointer) +(define c-null? null-pointer?) + + diff --git a/foreign/c/sagittarius-primitives.sld b/foreign/c/sagittarius-primitives.sld new file mode 100644 index 0000000..526f36e --- /dev/null +++ b/foreign/c/sagittarius-primitives.sld @@ -0,0 +1,24 @@ +(define-library + (foreign c sagittarius-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (except (sagittarius ffi) c-free c-malloc define-c-struct) + (sagittarius)) + (export primitives-init + size-of-type + align-of-type + shared-object-load + define-c-procedure + ;define-c-callback + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null + c-null?) + (include "sagittarius-primitives.scm")) diff --git a/foreign/c/stklos-primitives.scm b/foreign/c/stklos-primitives.scm new file mode 100644 index 0000000..be2301c --- /dev/null +++ b/foreign/c/stklos-primitives.scm @@ -0,0 +1,122 @@ +(define (primitives-init set-procedure get-procedure) #t) + +(define (shared-object-load path options) path) + +(define type->native-type + (lambda (type) + (cond ((equal? type 'i8) :char) + ((equal? type 'u8) :char) + ((equal? type 'i16) :short) + ((equal? type 'u16) :ushort) + ((equal? type 'i32) :int) + ((equal? type 'u32) :uint) + ((equal? type 'i64) :long) + ((equal? type 'u64) :ulong) + ((equal? type 'char) :char) + ((equal? type 'uchar) :uchar) + ((equal? type 'short) :short) + ((equal? type 'ushort) :ushort) + ((equal? type 'int) :int) + ((equal? type 'uint) :uint) + ((equal? type 'long) :long) + ((equal? type 'ulong) :ulong) + ((equal? type 'float) :float) + ((equal? type 'double) :double) + ((equal? type 'pointer) :pointer) + ((equal? type 'void) :void) + ((equal? type 'callback) :pointer) + (else (error "type->native-type -- No such pffi type" type))))) + +(define c-bytevector? + (lambda (object) + (and (not (void? object)) + (cpointer? object)))) + +(define-syntax define-c-procedure + (syntax-rules () + ((_ scheme-name shared-object c-name return-type argument-types) + (begin + (define type->native-type + (lambda (type) + (cond ((equal? type 'i8) :char) + ((equal? type 'u8) :char) + ((equal? type 'i16) :short) + ((equal? type 'u16) :ushort) + ((equal? type 'i32) :int) + ((equal? type 'u32) :uint) + ((equal? type 'i64) :long) + ((equal? type 'u64) :ulong) + ((equal? type 'char) :char) + ((equal? type 'uchar) :char) + ((equal? type 'short) :short) + ((equal? type 'ushort) :ushort) + ((equal? type 'int) :int) + ((equal? type 'uint) :uint) + ((equal? type 'long) :long) + ((equal? type 'ulong) :ulong) + ((equal? type 'float) :float) + ((equal? type 'double) :double) + ((equal? type 'pointer) :pointer) + ((equal? type 'void) :void) + ((equal? type 'callback) :pointer) + (else (error "type->native-type -- No such pffi type" type))))) + (define scheme-name + (make-external-function + (symbol->string c-name) + (map type->native-type argument-types) + (type->native-type return-type) + shared-object)))))) + +(define-syntax define-c-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name + (%make-callback procedure + (map type->native-type argument-types) + (type->native-type return-type)))))) + +(define size-of-type + (lambda (type) + (cond ((equal? type 'i8) (c-size-of :int8)) + ((equal? type 'u8) (c-size-of :uint8)) + ((equal? type 'i16) (c-size-of :int16)) + ((equal? type 'u16) (c-size-of :uint16)) + ((equal? type 'i32) (c-size-of :int32)) + ((equal? type 'u32) (c-size-of :uint32)) + ((equal? type 'i64) (c-size-of :int64)) + ((equal? type 'u64) (c-size-of :uint64)) + ((equal? type 'char) (c-size-of :char)) + ((equal? type 'uchar) (c-size-of :uchar)) + ((equal? type 'short) (c-size-of :short)) + ((equal? type 'ushort) (c-size-of :ushort)) + ((equal? type 'int) (c-size-of :int)) + ((equal? type 'uint) (c-size-of :uint)) + ((equal? type 'long) (c-size-of :long)) + ((equal? type 'ulong) (c-size-of :ulong)) + ((equal? type 'float) (c-size-of :float)) + ((equal? type 'double) (c-size-of :double)) + ((equal? type 'pointer) (c-size-of :pointer))))) + +;; FIXME +(define align-of-type + (lambda (type) + (size-of-type type))) + +(define c-bytevector-u8-set! + (lambda (pointer offset value) + (cpointer-set-abs! pointer :uint8 value offset))) + +(define c-bytevector-u8-ref + (lambda (pointer offset) + (cpointer-ref-abs pointer :uint8 offset))) + +(define c-bytevector-pointer-set! + (lambda (pointer offset value) + (cpointer-set-abs! pointer :pointer value offset))) + +(define c-bytevector-pointer-ref + (lambda (pointer offset) + (cpointer-ref-abs pointer :pointer offset))) + +(define (make-c-null) #f) ;; FIXME +(define c-null? cpointer-null?) diff --git a/foreign/c/stklos-primitives.sld b/foreign/c/stklos-primitives.sld new file mode 100644 index 0000000..d268bce --- /dev/null +++ b/foreign/c/stklos-primitives.sld @@ -0,0 +1,46 @@ +(define-library + (foreign c stklos-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (only (stklos) + %make-callback + make-external-function + allocate-bytes + free-bytes + cpointer? + cpointer-null? + cpointer-data + cpointer-data-set! + cpointer-set-abs! + cpointer-ref-abs + c-size-of + void?)) + (export primitives-init + size-of-type + align-of-type + shared-object-load + define-c-procedure + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + make-c-null ;; FIXME + c-null? + ;; STklos specific + ; calculate-struct-size-and-offsets + ;struct-make + get-environment-variable + file-exists? + make-external-function + ;address->c-bytevector + ;c-bytevector-pointer-set! + ;c-bytevector-pointer-ref + void? + free-bytes + ) + (include "stklos-primitives.scm")) diff --git a/foreign/c/struct.scm b/foreign/c/struct.scm new file mode 100644 index 0000000..e685e7e --- /dev/null +++ b/foreign/c/struct.scm @@ -0,0 +1,166 @@ +#;(define-record-type + (c-struct-make c-type size pointer members) + c-struct? + (c-type c-struct:type) + (size c-struct:size) + (pointer c-struct:pointer) + (members c-struct:members)) + +(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-members + (lambda (members) + (let* + ((size 0) + (largest-member-size 0) + (data (map (lambda (member) + (let* ((name (list-ref member 0)) + (type (list-ref member 1)) + (accessor (list-ref member 2)) + (type-alignment (c-type-align 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) accessor)) + (let ((next-alignment + (round-to-next-modulo-of size type-alignment))) + (set! size (+ next-alignment type-alignment)) + (list name type next-alignment accessor))))) + members))) + data))) + + +(define-syntax define-c-struct + (syntax-rules () + ((_ name members struct-pointer (field-name field-type accessor modifier) ...) + (begin + (define accessor + (lambda (c-bytevector) + (let ((offset (let ((offset 0) + (before? #t)) + (for-each + (lambda (member) + (when (equal? (list-ref member 0) 'field-name) + (set! before? #f)) + (when before? + (set! offset + (+ offset + (c-type-align (list-ref member 1)))))) + members) + offset))) + (cond + ((equal? 'pointer field-type) + (c-bytevector-pointer-ref c-bytevector offset)) + ((c-type-signed? field-type) + (c-bytevector-sint-ref c-bytevector + offset + (native-endianness) + (c-type-size field-type))) + (else + (c-bytevector-uint-ref c-bytevector + offset + (native-endianness) + (c-type-size field-type))))))) + ... + (define modifier + (lambda (c-bytevector value) + (let ((offset (let ((offset 0) + (before? #t)) + (for-each + (lambda (member) + (when (equal? (list-ref member 0) 'field-name) + (set! before? #f)) + (when before? + (set! offset + (+ offset + (c-type-align (list-ref member 1)))))) + members) + offset))) + (cond + ((equal? 'pointer field-type) + (c-bytevector-pointer-set! c-bytevector offset value)) + ((c-type-signed? field-type) + (c-bytevector-sint-set! c-bytevector + offset + value + (native-endianness) + (c-type-size field-type))) + (else + (c-bytevector-uint-set! c-bytevector + offset + value + (native-endianness) + (c-type-size field-type))))))) + ... + (define members (calculate-struct-members + (list (list 'field-name field-type accessor) ...))) + (define name + (if (c-null? struct-pointer) + (make-c-bytevector (+ (c-type-size field-type) ...)) + struct-pointer)))))) + +(define c-struct->alist + (lambda (struct-c-bytevector struct-members) + (map (lambda (member) + (cons (list-ref member 0) + (apply (list-ref member 3) (list struct-c-bytevector)))) + struct-members))) + +#;(define-syntax define-c-struct + (syntax-rules () + ((_ name constructor pred field ...) + (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)))) + (c-struct-make c-type-string size pointer 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/foreign/c/struct.sld b/foreign/c/struct.sld new file mode 100644 index 0000000..8bd1f8a --- /dev/null +++ b/foreign/c/struct.sld @@ -0,0 +1,17 @@ +(define-library + (foreign c struct) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context)) + (export define-c-struct + c-struct->alist + ;pffi-define-struct;define-c-struct + ;pffi-struct-pointer;c-struct-bytevector + ;pffi-struct-offset-get;c-struct-offset + ;pffi-struct-set!;c-struct-set! + ;pffi-struct-get;c-struct-get + ) + (include "struct.scm")) diff --git a/foreign/c/ypsilon-primitives.scm b/foreign/c/ypsilon-primitives.scm new file mode 100644 index 0000000..da0716c --- /dev/null +++ b/foreign/c/ypsilon-primitives.scm @@ -0,0 +1,147 @@ +(define (primitives-init set-procedure get-procedure) #t) + +(define size-of-type + (lambda (type) + (cond ((eq? type 'i8) (c-sizeof int8_t)) + ((eq? type 'u8) (c-sizeof uint8_t)) + ((eq? type 'i16) (c-sizeof int16_t)) + ((eq? type 'u16) (c-sizeof uint16_t)) + ((eq? type 'i32) (c-sizeof int32_t)) + ((eq? type 'u32) (c-sizeof uint32_t)) + ((eq? type 'i64) (c-sizeof int64_t)) + ((eq? type 'u64) (c-sizeof uint64_t)) + ((eq? type 'char) (c-sizeof char)) + ((eq? type 'uchar) (c-sizeof char)) + ((eq? type 'short) (c-sizeof short)) + ((eq? type 'ushort) (c-sizeof unsigned-short)) + ((eq? type 'int) (c-sizeof int)) + ((eq? type 'uint) (c-sizeof unsigned-int)) + ((eq? type 'long) (c-sizeof long)) + ((eq? type 'ulong) (c-sizeof unsigned-long)) + ((eq? type 'float) (c-sizeof float)) + ((eq? type 'double) (c-sizeof double)) + ((eq? type 'pointer) (c-sizeof void*)) + ((eq? type 'callback) (c-sizeof void*))))) + +(define align-of-type + (lambda (type) + (cond ((eq? type 'i8) alignof:int8_t) + ((eq? type 'u8) alignof:int8_t) + ((eq? type 'i16) alignof:int16_t) + ((eq? type 'u16) alignof:int16_t) + ((eq? type 'i32) alignof:int32_t) + ((eq? type 'u32) alignof:int32_t) + ((eq? type 'i64) alignof:int64_t) + ((eq? type 'u64) alignof:int64_t) + ((eq? type 'char) alignof:int8_t) + ((eq? type 'uchar) alignof:int8_t) + ((eq? type 'short) alignof:short) + ((eq? type 'ushort) alignof:short) + ((eq? type 'int) alignof:int) + ((eq? type 'uint) alignof:int) + ((eq? type 'long) alignof:long) + ((eq? type 'ulong) alignof:long) + ((eq? type 'float) alignof:float) + ((eq? type 'double) alignof:double) + ((eq? type 'pointer) alignof:void*) + ((eq? type 'callback) alignof:void*)))) + +(define c-bytevector? + (lambda (object) + (number? object))) + +(define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + ;; Ypsilon for some reason does not have bytevector-c-uint8-set! + ;; or other bytevector-c-u*-set! procedures so we use + ;; bytevector-c-int8-set! + (bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k) + (size-of-type 'uint8)) + 0 + byte))) + +(define c-bytevector-u8-ref + (lambda (c-bytevector k) + (bytevector-c-uint8-ref (make-bytevector-mapping (+ c-bytevector k) + (size-of-type 'uint8)) + 0))) + +(define c-bytevector-pointer-set! + (lambda (c-bytevector k pointer) + (bytevector-c-void*-set! (make-bytevector-mapping (+ c-bytevector k) + (size-of-type 'pointer)) + 0 + pointer))) + +(define c-bytevector-pointer-ref + (lambda (c-bytevector k) + (bytevector-c-void*-ref (make-bytevector-mapping (+ c-bytevector k) + (size-of-type 'pointer)) + 0))) + +(define shared-object-load + (lambda (path options) + (load-shared-object path))) + +(define-macro + (define-c-procedure scheme-name shared-object c-name return-type argument-types) + (begin + (let ((type->native-type + (lambda (type) + (cond ((equal? type 'i8) 'int8_t) + ((equal? type 'u8) 'uint8_t) + ((equal? type 'i16) 'int16_t) + ((equal? type 'u16) 'uint16_t) + ((equal? type 'i32) 'int32_t) + ((equal? type 'u32) 'uint32_t) + ((equal? type 'i64) 'int64_t) + ((equal? type 'u64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'uchar) 'char) + ((equal? type 'short) 'short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'uint) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'ulong) '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 'i8) 'int8_t) + ((equal? type 'u8) 'uint8_t) + ((equal? type 'i16) 'int16_t) + ((equal? type 'u16) 'uint16_t) + ((equal? type 'i32) 'int32_t) + ((equal? type 'u32) 'uint32_t) + ((equal? type 'i64) 'int64_t) + ((equal? type 'u64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'uchar) 'char) + ((equal? type 'short) 'short) + ((equal? type 'ushort) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'uint) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'ulong) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'void*) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'void*) + (else (error "type->native-type -- No such type" type))))) + (native-return-type (type->native-type (cadr return-type))) + (native-argument-types (map type->native-type (cadr argument-types)))) + `(define ,scheme-name + (c-callback ,native-return-type ,native-argument-types ,procedure)))) diff --git a/foreign/c/ypsilon-primitives.sld b/foreign/c/ypsilon-primitives.sld new file mode 100644 index 0000000..622a034 --- /dev/null +++ b/foreign/c/ypsilon-primitives.sld @@ -0,0 +1,32 @@ +(define-library + (foreign c ypsilon-primitives) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme inexact) + (scheme process-context) + (ypsilon c-ffi) + (ypsilon c-types) + (only (core) + define-macro + syntax-case + bytevector-c-int8-set! + bytevector-c-uint8-ref)) + (export primitives-init + size-of-type + align-of-type + shared-object-load + define-c-procedure + c-bytevector? + c-bytevector-u8-ref + c-bytevector-u8-set! + c-bytevector-pointer-ref + c-bytevector-pointer-set! + ;;make-c-null ;; FIXME + ;c-null? ;; FIXME + ;; Ypsilon specific + c-function + bytevector-c-int8-set! + bytevector-c-uint8-ref) + (include "ypsilon-primitives.scm")) diff --git a/lighttpd.conf b/lighttpd.conf deleted file mode 100644 index 49181de..0000000 --- a/lighttpd.conf +++ /dev/null @@ -1,16 +0,0 @@ -server.document-root = "/your-project-path" -server.errorlog = "/your-project-path/error.log" -server.modules = ("mod_scgi") - -server.port = 3000 -scgi.debug = 1 -scgi.server = ("/" => - (( "host" => "127.0.0.1", - "port" => 3001, - "check-local" => "disable"))) - -mimetype.assign = ( - ".html" => "text/html", - ".txt" => "text/plain", - ".jpg" => "image/jpeg", - ".png" => "image/png") diff --git a/retropikzel/fcgi/test.scm b/retropikzel/fcgi/test.scm new file mode 100644 index 0000000..d3782b5 --- /dev/null +++ b/retropikzel/fcgi/test.scm @@ -0,0 +1,15 @@ +(define count 1) + +(display "Starting fcgi server") +(newline) + +(handle-request + '((port . "3002")) + (lambda (request headers parameters cookies body files) + (display "Content-type: text/html") + (display "\r\n") + (display "\r\n") + (display "Hello") + (display "Count: ") + (display count) + (set! count (+ count 1))))