Retropikzel
/
scheme-libraries
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Clean repo

This commit is contained in:
retropikzel 2026-01-19 20:27:53 +02:00
parent 508d2060d4
commit 2d1cc74416
50 changed files with 0 additions and 9311 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Dockerfile.test
View File

@ -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

1194
foreign/c-bytevectors.sld
View File

File diff suppressed because it is too large Load Diff

3
foreign/c.rkt
View File

@ -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")

861
foreign/c.scm
View File

@ -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))

137
foreign/c.sld
View File

@ -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"))

59
foreign/c/array.scm
View File

@ -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)))))

14
foreign/c/array.sld
View File

@ -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"))

0
foreign/c/bytevectors.scm
View File

101
foreign/c/capyscheme-primitives.scm
View File

@ -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)))

23
foreign/c/capyscheme-primitives.sld
View File

@ -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"))

187
foreign/c/chezscheme-primitives.scm
View File

@ -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)))

18
foreign/c/chezscheme-primitives.sld
View File

@ -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"))

854
foreign/c/chibi-primitives.c
View File

@ -1,854 +0,0 @@
/* Automatically generated by chibi-ffi; version: 0.5 */
#include <chibi/eval.h>
#include <stdint.h>
#include <dlfcn.h>
#include <stdio.h>
#include <ffi.h>
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;
}

165
foreign/c/chibi-primitives.scm
View File

@ -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))))

24
foreign/c/chibi-primitives.sld
View File

@ -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"))

BIN
foreign/c/chibi-primitives.so
View File

Binary file not shown.

324
foreign/c/chibi-primitives.stub
View File

@ -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))

3
foreign/c/chibi-scheme-primitives.c
View File

@ -1,3 +0,0 @@
/* Automatically generated by chibi-ffi; version: 0.5 */
#include <chibi/eval.h>

198
foreign/c/chicken-primitives.scm
View File

@ -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)))))

35
foreign/c/chicken-primitives.sld
View File

@ -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"))

2533
foreign/c/cyclone-primitives.c
View File

File diff suppressed because it is too large Load Diff

296
foreign/c/cyclone-primitives.sld
View File

@ -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))))

160
foreign/c/define-c-library.scm
View File

@ -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)))))))))))

240
foreign/c/gambit-primitives.scm
View File

@ -1,240 +0,0 @@
(c-declare "#include <stdlib.h>")
(c-declare "#include <stdint.h>")
(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)
)))

20
foreign/c/gambit-primitives.sld
View File

@ -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"))

98
foreign/c/gauche-primitives.scm
View File

@ -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?)

24
foreign/c/gauche-primitives.sld
View File

@ -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"))

96
foreign/c/guile-primitives.scm
View File

@ -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)))

29
foreign/c/guile-primitives.sld
View File

@ -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"))

123
foreign/c/ikarus-primitives.sld
View File

@ -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)))))

140
foreign/c/ironscheme-primitives.sld
View File

@ -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)))))

175
foreign/c/kawa-primitives.scm
View File

@ -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"))))

22
foreign/c/kawa-primitives.sld
View File

@ -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"))

105
foreign/c/larceny-primitives.scm
View File

@ -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?))

50
foreign/c/larceny-primitives.sld
View File

@ -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"))

32
foreign/c/libc.scm
View File

@ -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))

34
foreign/c/mit-scheme-primitives.sld
View File

@ -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")
)
)

113
foreign/c/mosh-primitives.scm
View File

@ -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?)

24
foreign/c/mosh-primitives.sld
View File

@ -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"))

3
foreign/c/racket-primitives.rkt
View File

@ -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")

86
foreign/c/racket-primitives.scm
View File

@ -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)))

42
foreign/c/racket-primitives.sld
View File

@ -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"))

111
foreign/c/sagittarius-primitives.scm
View File

@ -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?)

24
foreign/c/sagittarius-primitives.sld
View File

@ -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"))

122
foreign/c/stklos-primitives.scm
View File

@ -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?)

46
foreign/c/stklos-primitives.sld
View File

@ -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"))

166
foreign/c/struct.scm
View File

@ -1,166 +0,0 @@
#;(define-record-type <c-struct>
(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)))

17
foreign/c/struct.sld
View File

@ -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"))

147
foreign/c/ypsilon-primitives.scm
View File

@ -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))))

32
foreign/c/ypsilon-primitives.sld
View File

@ -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"))