394 lines
14 KiB
Scheme
394 lines
14 KiB
Scheme
(define-library
|
|
(foreign c)
|
|
(cond-expand
|
|
(chibi
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme process-context)
|
|
(chibi ast)
|
|
(scheme inexact)
|
|
(chibi))
|
|
(include-shared "c/primitives/chibi/foreign-c"))
|
|
(chicken
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)
|
|
(chicken base)
|
|
(chicken foreign)
|
|
(chicken locative)
|
|
(chicken syntax)
|
|
(chicken memory)
|
|
(chicken random)))
|
|
#;(cyclone
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)
|
|
(cyclone foreign)
|
|
(scheme cyclone primitives)))
|
|
(gambit
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)
|
|
(only (gambit) c-declare c-lambda c-define define-macro)))
|
|
(gauche
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)
|
|
(gauche base)
|
|
(foreign c primitives gauche)))
|
|
#;(gerbil
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)))
|
|
(guile
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)
|
|
(system foreign)
|
|
(system foreign-library)
|
|
(only (guile) include-from-path)
|
|
(only (rnrs bytevectors)
|
|
bytevector-uint-set!
|
|
bytevector-uint-ref)))
|
|
(kawa
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)))
|
|
(mit-scheme
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)))
|
|
#;(larceny
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)
|
|
(rename (primitives r5rs:require) (r5rs:require require))
|
|
(primitives std-ffi)
|
|
(primitives foreign-procedure)
|
|
(primitives foreign-file)
|
|
(primitives foreign-stdlib)
|
|
(primitives system-interface)))
|
|
(mosh
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme inexact)
|
|
(scheme process-context)
|
|
(mosh ffi)))
|
|
(racket
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)
|
|
(only (racket base) system-type)
|
|
(ffi winapi)
|
|
(compatibility mlist)
|
|
(ffi unsafe)
|
|
(ffi vector)))
|
|
(sagittarius
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)
|
|
(except (sagittarius ffi) c-free c-malloc)
|
|
(sagittarius)))
|
|
#;(skint
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)))
|
|
(stklos
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)
|
|
(only (stklos)
|
|
%make-callback
|
|
make-external-function
|
|
allocate-bytes
|
|
free-bytes
|
|
cpointer?
|
|
cpointer-null?
|
|
cpointer-data
|
|
cpointer-data-set!
|
|
cpointer-set!
|
|
cpointer-ref
|
|
void?))
|
|
(export ; calculate-struct-size-and-offsets
|
|
;struct-make
|
|
get-environment-variable
|
|
file-exists?
|
|
make-external-function
|
|
foreign-c:string-split
|
|
c-bytevector-pointer-set!
|
|
c-bytevector-pointer-ref))
|
|
#;(tr7
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
;(scheme inexact)
|
|
(scheme process-context)))
|
|
(ypsilon
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme char)
|
|
(scheme file)
|
|
(scheme inexact)
|
|
(scheme process-context)
|
|
(ypsilon c-ffi)
|
|
(ypsilon c-types)
|
|
(only (core) define-macro syntax-case))))
|
|
(export ;;;; Primitives 1
|
|
c-type-size
|
|
define-c-library
|
|
define-c-procedure
|
|
c-bytevector?
|
|
c-bytevector-u8-set!
|
|
c-bytevector-u8-ref
|
|
c-bytevector-pointer-set!
|
|
c-bytevector-pointer-ref
|
|
|
|
;;;; Primitives 2
|
|
define-c-callback
|
|
|
|
;;;; c-bytevector
|
|
make-c-null
|
|
c-null?
|
|
c-free
|
|
call-with-address-of
|
|
|
|
bytevector->c-bytevector
|
|
c-bytevector->bytevector
|
|
|
|
;;;; Utilities
|
|
libc-name
|
|
|
|
;; TODO endianness
|
|
native-endianness
|
|
make-c-bytevector
|
|
;; TODO c-bytevector=?
|
|
;; TODO c-bytevector-fill!
|
|
;; TODO c-bytevector-copy!
|
|
;; TODO c-bytevector-copy
|
|
c-bytevector-s8-set!
|
|
c-bytevector-s8-ref
|
|
;; TODO c-bytevector->u8-list
|
|
;; TODO u8-list->c-bytevector
|
|
|
|
c-bytevector-uchar-ref
|
|
c-bytevector-char-ref
|
|
c-bytevector-char-set!
|
|
c-bytevector-uchar-set!
|
|
|
|
c-bytevector-uint-ref
|
|
c-bytevector-sint-ref
|
|
c-bytevector-sint-set!
|
|
c-bytevector-uint-set!
|
|
;; TODO bytevector->uint-list
|
|
;; TODO bytevector->sint-list
|
|
;; TODO uint-list->bytevector
|
|
;; TODO sint-list->bytevector
|
|
|
|
c-bytevector-u16-ref
|
|
c-bytevector-s16-ref
|
|
c-bytevector-u16-native-ref
|
|
c-bytevector-s16-native-ref
|
|
c-bytevector-u16-set!
|
|
c-bytevector-s16-set!
|
|
c-bytevector-u16-native-set!
|
|
c-bytevector-s16-native-set!
|
|
|
|
c-bytevector-u32-ref
|
|
c-bytevector-s32-ref
|
|
c-bytevector-u32-native-ref
|
|
c-bytevector-s32-native-ref
|
|
c-bytevector-u32-set!
|
|
c-bytevector-s32-set!
|
|
c-bytevector-u32-native-set!
|
|
c-bytevector-s32-native-set!
|
|
|
|
c-bytevector-u64-ref
|
|
c-bytevector-s64-ref
|
|
c-bytevector-s64-native-ref
|
|
c-bytevector-u64-native-ref
|
|
c-bytevector-u64-set!
|
|
c-bytevector-s64-set!
|
|
c-bytevector-u64-native-set!
|
|
c-bytevector-s64-native-set!
|
|
|
|
c-bytevector-ieee-single-native-ref
|
|
c-bytevector-ieee-single-ref
|
|
|
|
c-bytevector-ieee-double-native-ref
|
|
c-bytevector-ieee-double-ref
|
|
|
|
c-bytevector-ieee-single-native-set!
|
|
c-bytevector-ieee-single-set!
|
|
|
|
c-bytevector-ieee-double-native-set!
|
|
c-bytevector-ieee-double-set!
|
|
|
|
string->c-utf8
|
|
;; TODO string->c-utf16
|
|
;; TODO string->c-utf32
|
|
|
|
c-utf8->string
|
|
;; TODO c-utf16->string
|
|
;; TODO c-utf32->string
|
|
|
|
|
|
;c-string-length ;; TODO Documentation, Testing
|
|
|
|
;; c-struct
|
|
;pffi-define-struct;define-c-struct
|
|
;pffi-struct-pointer;c-struct-bytevector
|
|
;pffi-struct-offset-get;c-struct-offset
|
|
;pffi-struct-set!;c-struct-set!
|
|
;pffi-struct-get;c-struct-get
|
|
|
|
;; c-array
|
|
;define-c-array (?)
|
|
;pffi-array-allocate;make-c-array
|
|
;pffi-array-pointer;c-array-pointer
|
|
;pffi-array?;c-array?
|
|
;pffi-pointer->array;c-bytevector->array
|
|
;pffi-array-get;c-array-get
|
|
;pffi-array-set!;c-array-set!
|
|
;pffi-list->array;list->c-array
|
|
;pffi-array->list;c-array->list
|
|
|
|
;; c-variable
|
|
;define-c-variable (?)
|
|
)
|
|
(begin
|
|
(define type->libffi-type-number
|
|
(lambda (type)
|
|
(cond ((equal? type 'int8) 1)
|
|
((equal? type 'uint8) 2)
|
|
((equal? type 'int16) 3)
|
|
((equal? type 'uint16) 4)
|
|
((equal? type 'int32) 5)
|
|
((equal? type 'uint32) 6)
|
|
((equal? type 'int64) 7)
|
|
((equal? type 'uint64) 8)
|
|
((equal? type 'char) 9)
|
|
((equal? type 'unsigned-char) 10)
|
|
((equal? type 'short) 11)
|
|
((equal? type 'unsigned-short) 12)
|
|
((equal? type 'int) 13)
|
|
((equal? type 'unsigned-int) 14)
|
|
((equal? type 'long) 15)
|
|
((equal? type 'unsigned-long) 16)
|
|
((equal? type 'float) 17)
|
|
((equal? type 'double) 18)
|
|
((equal? type 'void) 19)
|
|
((equal? type 'pointer) 20)
|
|
((equal? type 'pointer-address) 21)
|
|
((equal? type 'callback) 22)
|
|
(else (error "Undefined type" type)))))
|
|
(define c-bytevector-get
|
|
(lambda (pointer type offset)
|
|
(cond ((equal? type 'int8) (c-bytevector-s8-ref pointer offset))
|
|
((equal? type 'uint8) (c-bytevector-u8-ref pointer offset))
|
|
((equal? type 'int16) (c-bytevector-s16-ref pointer offset))
|
|
((equal? type 'uint16) (c-bytevector-u16-ref pointer offset))
|
|
((equal? type 'int32) (c-bytevector-s32-ref pointer offset))
|
|
((equal? type 'uint32) (c-bytevector-u32-ref pointer offset))
|
|
((equal? type 'int64) (c-bytevector-s64-ref pointer offset))
|
|
((equal? type 'uint64) (c-bytevector-u64-ref pointer offset))
|
|
((equal? type 'char) (integer->char (c-bytevector-s8-ref pointer offset)))
|
|
((equal? type 'unsigned-char) (integer->char (c-bytevector-u8-ref pointer offset)))
|
|
((equal? type 'short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'short)))
|
|
((equal? type 'unsigned-short) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-short)))
|
|
((equal? type 'int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'int)))
|
|
((equal? type 'unsigned-int) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-int)))
|
|
((equal? type 'long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'long)))
|
|
((equal? type 'unsigned-long) (c-bytevector-sint-ref pointer offset (native-endianness) (c-type-size 'unsigned-long)))
|
|
((equal? type 'float) (c-bytevector-ieee-single-native-ref pointer offset))
|
|
((equal? type 'double) (c-bytevector-ieee-double-native-ref pointer offset))
|
|
((equal? type 'pointer) (c-bytevector-pointer-ref pointer offset))
|
|
((not (equal? type 'void)) (error "No such foreign type" type))
|
|
;; Return unspecified on purpose if type is void
|
|
))))
|
|
#;(cond-expand
|
|
(chicken-6 (include-relative "c/internal.scm"))
|
|
(else (include "c/internal.scm")))
|
|
(cond-expand
|
|
(chibi (include "c/primitives/chibi.scm"))
|
|
(chicken-5 (export foreign-declare
|
|
foreign-safe-lambda
|
|
void)
|
|
(include "c/primitives/chicken.scm"))
|
|
(chicken-6 (include-relative "c/primitives/chicken.scm"))
|
|
;(cyclone (include "c/primitives/cyclone.scm"))
|
|
(gambit (include "c/primitives/gambit.scm"))
|
|
(gauche (include "c/primitives/gauche/define-c-procedure.scm"))
|
|
;(gerbil (include "c/primitives/gerbil.scm"))
|
|
(guile (include "./c/primitives/guile.scm"))
|
|
(kawa (include "c/primitives/kawa.scm"))
|
|
(mit-scheme (include "c/primitives/mit-scheme.scm"))
|
|
;(larceny (include "c/primitives/larceny.scm"))
|
|
(mosh (include "c/primitives/mosh.scm"))
|
|
(racket (include "c/primitives/racket.scm"))
|
|
(sagittarius (include "c/primitives/sagittarius.scm"))
|
|
;(skint (include "c/primitives/skint.scm"))
|
|
(stklos (include "c/primitives/stklos.scm"))
|
|
;(tr7 (include "c/primitives/tr7.scm"))
|
|
(ypsilon (export c-function c-callback)
|
|
(include "c/primitives/ypsilon.scm")))
|
|
(cond-expand
|
|
(chicken-6 (include-relative "c/main.scm")
|
|
(include-relative "c/libc.scm")
|
|
(include-relative "c/c-bytevectors.scm")
|
|
(include-relative "c/pointer.scm")
|
|
;(include-relative "c/array.scm")
|
|
;(include-relative "c/struct.scm")
|
|
)
|
|
(else (include "c/main.scm")
|
|
(include "c/libc.scm")
|
|
;(include "c/struct.scm")
|
|
(include "c/c-bytevectors.scm")
|
|
(include "c/pointer.scm")
|
|
;(include "c/array.scm")
|
|
)))
|