diff --git a/Dockerfile.test b/Dockerfile.test index ae6e6e0..013dabc 100644 --- a/Dockerfile.test +++ b/Dockerfile.test @@ -42,5 +42,4 @@ RUN if [ "${SCHEME}" != "gauche" ]; then snow-chibi --impls=${SCHEME} --always-y 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/foreign/c-bytevectors.sld b/foreign/c-bytevectors.sld deleted file mode 100644 index 5612e07..0000000 --- a/foreign/c-bytevectors.sld +++ /dev/null @@ -1,1194 +0,0 @@ -;;; Copyright 2025 Retropikzel -;;; -;;; Permission to copy this software, in whole or in part, to use this -;;; software for any lawful purpose, and to redistribute this software -;;; is granted subject to the restriction that all copies made of this -;;; software must include this copyright and permission notice in full. -;;; -;;; This is R6RS c-Bytevectors library, modified to work with C pointers. -;;; Mostly just by adding c- prefix to each word "bytevector". -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright 2015 William D Clinger. -;;; -;;; Permission to copy this software, in whole or in part, to use this -;;; software for any lawful purpose, and to redistribute this software -;;; is granted subject to the restriction that all copies made of this -;;; software must include this copyright and permission notice in full. -;;; -;;; I also request that you send me a copy of any improvements that you -;;; make to this software so that they may be incorporated within it to -;;; the benefit of the Scheme community. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This R7RS-portable implementation of (rnrs bytevectors) is -;;; mostly derived from Larceny's src/Lib/Common/bytevector.sch. -;;; -;;; The R6RS requires implementations to select a native endianness. -;;; That choice is arbitrary, intended to affect performance but not -;;; behavior. In this implementation, the native endianness is -;;; obtained via cond-expand, which should coincide with the -;;; endianness obtained by calling the features procedure. Of the -;;; R7RS systems I've tested, only one omits endianness from its -;;; (features), and it's a slow interpreter for which the native -;;; endianness probably won't affect performance. -;;; -;;; This implementation defines a 53-bit exact integer constant, -;;; and the procedures that work with byte fields of arbitrary -;;; width may create even larger exact integers. -;;; -;;; FIXME: It should be possible to delay creation of that 53-bit -;;; constant until it's needed, which might be better for systems -;;; that don't support exact 53-bit integers. It looks as though -;;; most systems R7RS systems either support exact 53-bit integers -;;; or overflow into inexact 53-bit integers; if the constant turns -;;; out to be inexact, then the procedure that needs it will fail -;;; when it is called, which is what would happen if creation of -;;; that constant were delayed. - -(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 deleted file mode 100644 index 143ade4..0000000 --- a/foreign/c.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#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 deleted file mode 100644 index 74c9c6e..0000000 --- a/foreign/c.scm +++ /dev/null @@ -1,861 +0,0 @@ -;; (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 deleted file mode 100644 index 22850a8..0000000 --- a/foreign/c.sld +++ /dev/null @@ -1,137 +0,0 @@ -(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 deleted file mode 100644 index ce36a5d..0000000 --- a/foreign/c/array.scm +++ /dev/null @@ -1,59 +0,0 @@ -(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 deleted file mode 100644 index 48b546d..0000000 --- a/foreign/c/array.sld +++ /dev/null @@ -1,14 +0,0 @@ -(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 deleted file mode 100644 index e69de29..0000000 diff --git a/foreign/c/capyscheme-primitives.scm b/foreign/c/capyscheme-primitives.scm deleted file mode 100644 index b013ac8..0000000 --- a/foreign/c/capyscheme-primitives.scm +++ /dev/null @@ -1,101 +0,0 @@ -(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 deleted file mode 100644 index 5a494b0..0000000 --- a/foreign/c/capyscheme-primitives.sld +++ /dev/null @@ -1,23 +0,0 @@ -(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 deleted file mode 100644 index 73dd4e9..0000000 --- a/foreign/c/chezscheme-primitives.scm +++ /dev/null @@ -1,187 +0,0 @@ -(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 deleted file mode 100644 index 4275448..0000000 --- a/foreign/c/chezscheme-primitives.sld +++ /dev/null @@ -1,18 +0,0 @@ -(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 deleted file mode 100644 index ccdba9a..0000000 --- a/foreign/c/chibi-primitives.c +++ /dev/null @@ -1,854 +0,0 @@ -/* 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 deleted file mode 100644 index e734107..0000000 --- a/foreign/c/chibi-primitives.scm +++ /dev/null @@ -1,165 +0,0 @@ -(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 deleted file mode 100644 index fd6678f..0000000 --- a/foreign/c/chibi-primitives.sld +++ /dev/null @@ -1,24 +0,0 @@ -(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 deleted file mode 100755 index fc1ff0e..0000000 Binary files a/foreign/c/chibi-primitives.so and /dev/null differ diff --git a/foreign/c/chibi-primitives.stub b/foreign/c/chibi-primitives.stub deleted file mode 100644 index 38d6972..0000000 --- a/foreign/c/chibi-primitives.stub +++ /dev/null @@ -1,324 +0,0 @@ -; vim: ft=scheme - -(c-system-include "stdint.h") -(c-system-include "dlfcn.h") -(c-system-include "stdio.h") -(c-system-include "ffi.h") -(c-link "ffi") - -;; make-c-null -(c-declare "void* make_c_null() { return NULL; }") -(define-c (maybe-null pointer void*) make-c-null ()) - -;; c-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 deleted file mode 100644 index acae2cb..0000000 --- a/foreign/c/chibi-scheme-primitives.c +++ /dev/null @@ -1,3 +0,0 @@ -/* Automatically generated by chibi-ffi; version: 0.5 */ - -#include diff --git a/foreign/c/chicken-primitives.scm b/foreign/c/chicken-primitives.scm deleted file mode 100644 index 987861c..0000000 --- a/foreign/c/chicken-primitives.scm +++ /dev/null @@ -1,198 +0,0 @@ -(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 deleted file mode 100644 index a52c740..0000000 --- a/foreign/c/chicken-primitives.sld +++ /dev/null @@ -1,35 +0,0 @@ -(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 deleted file mode 100644 index bbbee12..0000000 --- a/foreign/c/cyclone-primitives.c +++ /dev/null @@ -1,2533 +0,0 @@ -/** - ** 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 deleted file mode 100644 index 23ecdd4..0000000 --- a/foreign/c/cyclone-primitives.sld +++ /dev/null @@ -1,296 +0,0 @@ -(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 deleted file mode 100644 index 4c1d00d..0000000 --- a/foreign/c/define-c-library.scm +++ /dev/null @@ -1,160 +0,0 @@ -(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 deleted file mode 100644 index 1f3e384..0000000 --- a/foreign/c/gambit-primitives.scm +++ /dev/null @@ -1,240 +0,0 @@ -(c-declare "#include ") -(c-declare "#include ") - - (define size-of-int8_t (c-lambda () int "___return(sizeof(int8_t));")) - (define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_t));")) - (define size-of-int16_t (c-lambda () int "___return(sizeof(int16_t));")) - (define size-of-uint16_t (c-lambda () int "___return(sizeof(uint16_t));")) - (define size-of-int32_t (c-lambda () int "___return(sizeof(int32_t));")) - (define size-of-uint32_t (c-lambda () int "___return(sizeof(uint32_t));")) - (define size-of-int64_t (c-lambda () int "___return(sizeof(int64_t));")) - (define size-of-uint64_t (c-lambda () int "___return(sizeof(uint64_t));")) - (define size-of-char (c-lambda () int "___return(sizeof(char));")) - (define size-of-unsigned-char (c-lambda () int "___return(sizeof(unsigned char));")) - (define size-of-short (c-lambda () int "___return(sizeof(short));")) - (define size-of-unsigned-short (c-lambda () int "___return(sizeof(unsigned short));")) - (define size-of-int (c-lambda () int "___return(sizeof(int));")) - (define size-of-unsigned-int (c-lambda () int "___return(sizeof(unsigned int));")) - (define size-of-long (c-lambda () int "___return(sizeof(long));")) - (define size-of-unsigned-long (c-lambda () int "___return(sizeof(unsigned long));")) - (define size-of-float (c-lambda () int "___return(sizeof(float));")) - (define size-of-double (c-lambda () int "___return(sizeof(double));")) - (define size-of-void* (c-lambda () int "___return(sizeof(void*));")) - - (define size-of-type - (lambda (type) - (cond ((eq? type 'int8) (size-of-int8_t)) - ((eq? type 'uint8) (size-of-uint8_t)) - ((eq? type 'int16) (size-of-int16_t)) - ((eq? type 'uint16) (size-of-uint16_t)) - ((eq? type 'int32) (size-of-int32_t)) - ((eq? type 'uint32) (size-of-uint32_t)) - ((eq? type 'int64) (size-of-int64_t)) - ((eq? type 'uint64) (size-of-uint64_t)) - ((eq? type 'char) (size-of-char)) - ((eq? type 'unsigned-char) (size-of-char)) - ((eq? type 'short) (size-of-short)) - ((eq? type 'unsigned-short) (size-of-unsigned-short)) - ((eq? type 'int) (size-of-int)) - ((eq? type 'unsigned-int) (size-of-unsigned-int)) - ((eq? type 'long) (size-of-long)) - ((eq? type 'unsigned-long) (size-of-unsigned-long)) - ((eq? type 'float) (size-of-float)) - ((eq? type 'double) (size-of-double)) - ((eq? type 'pointer) (size-of-void*)) - ((eq? type 'callback) (size-of-void*)) - ((eq? type 'void) (size-of-void*)) - (else (error "Can not get size of unknown type" type))))) - - (define-macro - (define-c-library name headers object-name . options) - (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 deleted file mode 100644 index 7ce0bd6..0000000 --- a/foreign/c/gambit-primitives.sld +++ /dev/null @@ -1,20 +0,0 @@ -(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 deleted file mode 100644 index f43a283..0000000 --- a/foreign/c/gauche-primitives.scm +++ /dev/null @@ -1,98 +0,0 @@ -(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 deleted file mode 100644 index f4033c5..0000000 --- a/foreign/c/gauche-primitives.sld +++ /dev/null @@ -1,24 +0,0 @@ -(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 deleted file mode 100644 index 9a4cd57..0000000 --- a/foreign/c/guile-primitives.scm +++ /dev/null @@ -1,96 +0,0 @@ -(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 deleted file mode 100644 index 73b01a2..0000000 --- a/foreign/c/guile-primitives.sld +++ /dev/null @@ -1,29 +0,0 @@ -(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 deleted file mode 100644 index 430072b..0000000 --- a/foreign/c/ikarus-primitives.sld +++ /dev/null @@ -1,123 +0,0 @@ -(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 deleted file mode 100644 index 4fa3a2a..0000000 --- a/foreign/c/ironscheme-primitives.sld +++ /dev/null @@ -1,140 +0,0 @@ -(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 deleted file mode 100644 index 580b294..0000000 --- a/foreign/c/kawa-primitives.scm +++ /dev/null @@ -1,175 +0,0 @@ -(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 deleted file mode 100644 index 9567374..0000000 --- a/foreign/c/kawa-primitives.sld +++ /dev/null @@ -1,22 +0,0 @@ -(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 deleted file mode 100644 index f5ceb08..0000000 --- a/foreign/c/larceny-primitives.scm +++ /dev/null @@ -1,105 +0,0 @@ -(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 deleted file mode 100644 index c8b04eb..0000000 --- a/foreign/c/larceny-primitives.sld +++ /dev/null @@ -1,50 +0,0 @@ -(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 deleted file mode 100644 index a7322d2..0000000 --- a/foreign/c/libc.scm +++ /dev/null @@ -1,32 +0,0 @@ -(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 deleted file mode 100644 index 8d8e329..0000000 --- a/foreign/c/mit-scheme-primitives.sld +++ /dev/null @@ -1,34 +0,0 @@ -(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 deleted file mode 100644 index 1df50b3..0000000 --- a/foreign/c/mosh-primitives.scm +++ /dev/null @@ -1,113 +0,0 @@ -(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 deleted file mode 100644 index 8ea1cf9..0000000 --- a/foreign/c/mosh-primitives.sld +++ /dev/null @@ -1,24 +0,0 @@ -(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 deleted file mode 100644 index a15cafb..0000000 --- a/foreign/c/racket-primitives.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#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 deleted file mode 100644 index 4f72b31..0000000 --- a/foreign/c/racket-primitives.scm +++ /dev/null @@ -1,86 +0,0 @@ -(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 deleted file mode 100644 index 1651bd4..0000000 --- a/foreign/c/racket-primitives.sld +++ /dev/null @@ -1,42 +0,0 @@ -(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 deleted file mode 100644 index 075ff7b..0000000 --- a/foreign/c/sagittarius-primitives.scm +++ /dev/null @@ -1,111 +0,0 @@ -(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 deleted file mode 100644 index 526f36e..0000000 --- a/foreign/c/sagittarius-primitives.sld +++ /dev/null @@ -1,24 +0,0 @@ -(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 deleted file mode 100644 index be2301c..0000000 --- a/foreign/c/stklos-primitives.scm +++ /dev/null @@ -1,122 +0,0 @@ -(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 deleted file mode 100644 index d268bce..0000000 --- a/foreign/c/stklos-primitives.sld +++ /dev/null @@ -1,46 +0,0 @@ -(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 deleted file mode 100644 index e685e7e..0000000 --- a/foreign/c/struct.scm +++ /dev/null @@ -1,166 +0,0 @@ -#;(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 deleted file mode 100644 index 8bd1f8a..0000000 --- a/foreign/c/struct.sld +++ /dev/null @@ -1,17 +0,0 @@ -(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 deleted file mode 100644 index da0716c..0000000 --- a/foreign/c/ypsilon-primitives.scm +++ /dev/null @@ -1,147 +0,0 @@ -(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 deleted file mode 100644 index 622a034..0000000 --- a/foreign/c/ypsilon-primitives.sld +++ /dev/null @@ -1,32 +0,0 @@ -(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"))