0197902309
Macros and other tools that need syntax privilege used `(current-code-inspector)' at the module top-level to try to capture the right code inspector at load time. It's more consistent to instead use the enclosing module's declaration-time inspector, and `var-ref->mod-decl-insp' provides that. The new function works only on references to anonymous variables, which limits access to the inspector. The real function name is longer, of course.
1598 lines
69 KiB
Racket
1598 lines
69 KiB
Racket
#lang racket/base
|
|
|
|
;; Foreign Racket interface
|
|
(require '#%foreign setup/dirs racket/unsafe/ops
|
|
(for-syntax racket/base racket/list syntax/stx
|
|
racket/struct-info))
|
|
|
|
(provide ctype-sizeof ctype-alignof compiler-sizeof
|
|
malloc free end-stubborn-change
|
|
cpointer? ptr-equal? ptr-add ptr-ref ptr-set! (protect-out cast)
|
|
ptr-offset ptr-add! offset-ptr? set-ptr-offset!
|
|
vector->cpointer flvector->cpointer saved-errno lookup-errno
|
|
ctype? make-ctype make-cstruct-type make-array-type make-union-type
|
|
make-sized-byte-string ctype->layout
|
|
_void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
|
|
_fixint _ufixint _fixnum _ufixnum
|
|
_float _double _double*
|
|
_bool _pointer _gcpointer _scheme (rename-out [_scheme _racket]) _fpointer function-ptr
|
|
memcpy memmove memset
|
|
malloc-immobile-cell free-immobile-cell
|
|
make-late-weak-box make-late-weak-hasheq)
|
|
|
|
(define-syntax define*
|
|
(syntax-rules ()
|
|
[(_ (name . args) body ...)
|
|
(begin (provide name) (define (name . args) body ...))]
|
|
[(_ name expr)
|
|
(begin (provide name) (define name expr))]))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; C integer types
|
|
|
|
(define* _sint8 _int8)
|
|
(define* _sint16 _int16)
|
|
(define* _sint32 _int32)
|
|
(define* _sint64 _int64)
|
|
|
|
;; _byte etc is a convenient name for _uint8 & _sint8
|
|
;; (_byte is unsigned)
|
|
(define* _byte _uint8)
|
|
(define* _ubyte _uint8)
|
|
(define* _sbyte _int8)
|
|
|
|
;; _word etc is a convenient name for _uint16 & _sint16
|
|
;; (_word is unsigned)
|
|
(define* _word _uint16)
|
|
(define* _uword _uint16)
|
|
(define* _sword _int16)
|
|
|
|
;; utility for the next few definitions
|
|
(define (sizeof->3ints c-type)
|
|
(case (compiler-sizeof c-type)
|
|
[(2) (values _int16 _uint16 _int16)]
|
|
[(4) (values _int32 _uint32 _int32)]
|
|
[(8) (values _int64 _uint64 _int64)]
|
|
[else (error 'foreign "internal error: bad compiler size for `~s'"
|
|
c-type)]))
|
|
|
|
;; _short etc is a convenient name for whatever is the compiler's `short'
|
|
;; (_short is signed)
|
|
(provide _short _ushort _sshort)
|
|
(define-values (_short _ushort _sshort) (sizeof->3ints 'short))
|
|
|
|
;; _int etc is a convenient name for whatever is the compiler's `int'
|
|
;; (_int is signed)
|
|
(provide _int _uint _sint)
|
|
(define-values (_int _uint _sint) (sizeof->3ints 'int))
|
|
|
|
;; _long etc is a convenient name for whatever is the compiler's `long'
|
|
;; (_long is signed)
|
|
(provide _long _ulong _slong)
|
|
(define-values (_long _ulong _slong) (sizeof->3ints 'long))
|
|
|
|
;; _llong etc is a convenient name for whatever is the compiler's `long long'
|
|
;; (_llong is signed)
|
|
(provide _llong _ullong _sllong)
|
|
(define-values (_llong _ullong _sllong) (sizeof->3ints '(long long)))
|
|
|
|
;; _intptr etc is a convenient name for whatever is the integer
|
|
;; equivalent of the compiler's pointer (see `intptr_t') (_intptr is
|
|
;; signed)
|
|
(provide _intptr _uintptr _sintptr)
|
|
(define-values (_intptr _uintptr _sintptr) (sizeof->3ints '(void *)))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Getting and setting library objects
|
|
|
|
(define lib-suffix (bytes->string/latin-1 (subbytes (system-type 'so-suffix) 1)))
|
|
(define lib-suffix-re (regexp (string-append "\\." lib-suffix "$")))
|
|
(define suffix-before-version? (not (equal? lib-suffix "dylib")))
|
|
|
|
(provide (protect-out (rename-out [get-ffi-lib ffi-lib]))
|
|
ffi-lib? ffi-lib-name)
|
|
(define get-ffi-lib
|
|
(case-lambda
|
|
[(name) (get-ffi-lib name "")]
|
|
[(name version/s)
|
|
(cond
|
|
[(not name) (ffi-lib name)] ; #f => NULL => open this executable
|
|
[(not (or (string? name) (path? name)))
|
|
(raise-type-error 'ffi-lib "library-name" name)]
|
|
[else
|
|
;; A possible way that this might be misleading: say that there is a
|
|
;; "foo.so" file in the current directory, which refers to some
|
|
;; undefined symbol, trying to use this function with "foo.so" will try
|
|
;; a dlopen with "foo.so" which isn't found, then it tries a dlopen with
|
|
;; "/<curpath>/foo.so" which fails because of the undefined symbol, and
|
|
;; since all fails, it will use (ffi-lib "foo.so") to raise the original
|
|
;; file-not-found error. This is because the dlopen doesn't provide a
|
|
;; way to distinguish different errors (only dlerror, but that's
|
|
;; unreliable).
|
|
(let* ([versions (if (list? version/s) version/s (list version/s))]
|
|
[versions (map (lambda (v)
|
|
(if (or (not v) (zero? (string-length v)))
|
|
"" (string-append "." v)))
|
|
versions)]
|
|
[fullpath (lambda (p) (path->complete-path (cleanse-path p)))]
|
|
[absolute? (absolute-path? name)]
|
|
[name0 (path->string (cleanse-path name))] ; orig name
|
|
[names (map (if (regexp-match lib-suffix-re name0) ; name+suffix
|
|
(lambda (v) (string-append name0 v))
|
|
(lambda (v)
|
|
(if suffix-before-version?
|
|
(string-append name0 "." lib-suffix v)
|
|
(string-append name0 v "." lib-suffix))))
|
|
versions)]
|
|
[ffi-lib* (lambda (name) (ffi-lib name #t))])
|
|
(or ;; try to look in our library paths first
|
|
(and (not absolute?)
|
|
(ormap (lambda (dir)
|
|
;; try good names first, then original
|
|
(or (ormap (lambda (name)
|
|
(ffi-lib* (build-path dir name)))
|
|
names)
|
|
(ffi-lib* (build-path dir name0))))
|
|
(get-lib-search-dirs)))
|
|
;; try a system search
|
|
(ormap ffi-lib* names) ; try good names first
|
|
(ffi-lib* name0) ; try original
|
|
(ormap (lambda (name) ; try relative paths
|
|
(and (file-exists? name) (ffi-lib* (fullpath name))))
|
|
names)
|
|
(and (file-exists? name0) ; relative with original
|
|
(ffi-lib* (fullpath name0)))
|
|
;; give up: call ffi-lib so it will raise an error
|
|
(if (pair? names)
|
|
(ffi-lib (car names))
|
|
(ffi-lib name0))))])]))
|
|
|
|
(define (get-ffi-lib-internal x)
|
|
(if (ffi-lib? x) x (get-ffi-lib x)))
|
|
|
|
;; These internal functions provide the functionality to be used by
|
|
;; get-ffi-obj, set-ffi-obj! and define-c below
|
|
(define (ffi-get ffi-obj type)
|
|
(ptr-ref ffi-obj type))
|
|
(define (ffi-set! ffi-obj type new)
|
|
(let-values ([(new type) (get-lowlevel-object new type)])
|
|
(hash-set! ffi-objects-ref-table ffi-obj new)
|
|
(ptr-set! ffi-obj type new)))
|
|
|
|
;; This is better handled with `make-c-parameter'
|
|
(provide (protect-out ffi-obj-ref))
|
|
(define ffi-obj-ref
|
|
(case-lambda
|
|
[(name lib) (ffi-obj-ref name lib #f)]
|
|
[(name lib failure)
|
|
(let ([name (get-ffi-obj-name 'ffi-obj-ref name)]
|
|
[lib (get-ffi-lib-internal lib)])
|
|
(with-handlers ([exn:fail:filesystem?
|
|
(lambda (e) (if failure (failure) (raise e)))])
|
|
(ffi-obj name lib)))]))
|
|
|
|
;; get-ffi-obj is implemented as a syntax only to be able to propagate the
|
|
;; foreign name into the type syntax, which allows generated wrappers to have a
|
|
;; proper name.
|
|
(provide (protect-out get-ffi-obj))
|
|
(define get-ffi-obj*
|
|
(case-lambda
|
|
[(name lib type) (get-ffi-obj* name lib type #f)]
|
|
[(name lib type failure)
|
|
(let ([name (get-ffi-obj-name 'get-ffi-obj name)]
|
|
[lib (get-ffi-lib-internal lib)])
|
|
(let-values ([(obj error?)
|
|
(with-handlers
|
|
([exn:fail:filesystem?
|
|
(lambda (e)
|
|
(if failure (values (failure) #t) (raise e)))])
|
|
(values (ffi-obj name lib) #f))])
|
|
(if error? obj (ffi-get obj type))))]))
|
|
(define-syntax (get-ffi-obj stx)
|
|
(syntax-case stx ()
|
|
[(_ name lib type)
|
|
#`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name))]
|
|
[(_ name lib type failure)
|
|
#`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name)
|
|
failure)]
|
|
[x (identifier? #'x) #'get-ffi-obj*]))
|
|
|
|
;; It is important to use the set-ffi-obj! wrapper because it takes care of
|
|
;; keeping a handle on the object -- otherwise, setting a callback hook will
|
|
;; crash when the Scheme function is gone.
|
|
(provide (protect-out set-ffi-obj!))
|
|
(define (set-ffi-obj! name lib type new)
|
|
(ffi-set! (ffi-obj (get-ffi-obj-name 'set-ffi-obj! name)
|
|
(get-ffi-lib-internal lib))
|
|
type new))
|
|
|
|
;; Combining the above two in a `define-c' special form which makes a Scheme
|
|
;; `binding', first a `parameter'-like constructor:
|
|
(provide (protect-out make-c-parameter))
|
|
(define (make-c-parameter name lib type)
|
|
(let ([obj (ffi-obj (get-ffi-obj-name 'make-c-parameter name)
|
|
(get-ffi-lib-internal lib))])
|
|
(case-lambda [() (ffi-get obj type)]
|
|
[(new) (ffi-set! obj type new)])))
|
|
;; Then the fake binding syntax, uses the defined identifier to name the
|
|
;; object:
|
|
(provide (protect-out define-c))
|
|
(define-syntax (define-c stx)
|
|
(syntax-case stx ()
|
|
[(_ var-name lib-name type-expr)
|
|
(with-syntax ([(p) (generate-temporaries (list #'var-name))])
|
|
(namespace-syntax-introduce
|
|
#'(begin (define p (make-c-parameter 'var-name lib-name type-expr))
|
|
(define-syntax var-name
|
|
(syntax-id-rules (set!)
|
|
[(set! var val) (p val)]
|
|
[(var . xs) ((p) . xs)]
|
|
[var (p)])))))]))
|
|
|
|
;; Used to convert strings and symbols to a byte-string that names an object
|
|
(define (get-ffi-obj-name who objname)
|
|
(cond [(bytes? objname) objname]
|
|
[(symbol? objname) (get-ffi-obj-name who (symbol->string objname))]
|
|
[(string? objname) (string->bytes/utf-8 objname)]
|
|
[else (raise-type-error who "object-name" objname)]))
|
|
|
|
;; This table keeps references to values that are set in foreign libraries, to
|
|
;; avoid them being GCed. See set-ffi-obj! above.
|
|
(define ffi-objects-ref-table (make-hasheq))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Compile-time support for fun-expanders
|
|
|
|
(begin-for-syntax
|
|
|
|
;; The `_fun' macro tears its input apart and reassemble it using pieces from
|
|
;; custom function types (macros). This whole deal needs some work to make
|
|
;; it play nicely with taints and code inspectors, so Matthew wrote the
|
|
;; following code. The idea is to create a define-fun-syntax which makes the
|
|
;; new syntax transformer be an object that carries extra information, later
|
|
;; used by `expand-fun-syntax/fun'.
|
|
|
|
(define orig-inspector (variable-reference->module-declaration-inspector
|
|
(#%variable-reference)))
|
|
|
|
(define (disarm stx)
|
|
(syntax-disarm stx orig-inspector))
|
|
|
|
;; This is used to expand a fun-syntax in a _fun type context.
|
|
(define (expand-fun-syntax/fun stx)
|
|
(let loop ([stx stx])
|
|
(define (do-expand id id?) ; id? == are we expanding an identifier?
|
|
(define v (syntax-local-value id (lambda () #f)))
|
|
(define set!-trans? (set!-transformer? v))
|
|
(define proc (if set!-trans? (set!-transformer-procedure v) v))
|
|
(if (and (fun-syntax? proc) (or (not id?) set!-trans?))
|
|
;; Do essentially the same thing that `local-expand' does.
|
|
;; First, create an "introducer" to mark introduced identifiers:
|
|
(let* ([introduce (make-syntax-introducer)]
|
|
[expanded
|
|
;; Re-introduce mark related to expansion of `_fun':
|
|
(syntax-local-introduce
|
|
;; Re-add mark specific to this expansion, cancelling
|
|
;; some marks applied before expanding (leaving only
|
|
;; introuced syntax marked)
|
|
(introduce
|
|
;; Actually expand:
|
|
((fun-syntax-proc proc)
|
|
;; Disarm taints:
|
|
(disarm
|
|
;; Add mark specific to this expansion:
|
|
(introduce
|
|
;; Remove mark related to expansion of `_fun':
|
|
(syntax-local-introduce stx))))))])
|
|
;; Restore die packs from original, then loop
|
|
;; to continue expanding:
|
|
(loop (syntax-rearm expanded stx)))
|
|
stx))
|
|
(syntax-case (disarm stx) ()
|
|
[(id . rest) (identifier? #'id) (do-expand #'id #f)]
|
|
[id (identifier? #'id) (do-expand #'id #t)]
|
|
[_else stx])))
|
|
|
|
;; Use module-or-top-identifier=? because we use keywords like `=' and want
|
|
;; to make it possible to play with it at the toplevel.
|
|
(define id=? module-or-top-identifier=?)
|
|
|
|
(define (split-by key args)
|
|
(let loop ([args args] [r (list '())])
|
|
(cond [(null? args) (reverse (map reverse r))]
|
|
[(eq? key (car args)) (loop (cdr args) (cons '() r))]
|
|
[else (loop (cdr args)
|
|
(cons (cons (car args) (car r)) (cdr r)))])))
|
|
|
|
(define (add-renamer body from to)
|
|
(with-syntax ([body body] [from from] [to to])
|
|
#'(let-syntax ([to (syntax-id-rules ()
|
|
[(_?_ . _rest_) (from . _rest_)] [_?_ from])])
|
|
body)))
|
|
|
|
(define (custom-type->keys type err)
|
|
(define stops (map (lambda (s) (datum->syntax type s #f))
|
|
'(#%app #%top #%datum)))
|
|
;; Expand `type' using expand-fun-syntax/fun
|
|
(define orig (expand-fun-syntax/fun type))
|
|
(define (with-arg x rearm)
|
|
(syntax-case* x (=>) id=?
|
|
[(id => body) (identifier? #'id)
|
|
;; Extract #'body from its context
|
|
(list (rearm #'id) (rearm #'body))]
|
|
[_else (rearm x)]))
|
|
(let ([keys '()])
|
|
(define (setkey! key val . id?)
|
|
(cond
|
|
[(assq key keys)
|
|
(err "bad expansion of custom type (two `~a:'s)" key type)]
|
|
[(and (pair? id?) (car id?) (not (identifier? val)))
|
|
(err "bad expansion of custom type (`~a:' expects an identifier)"
|
|
key type)]
|
|
[else (set! keys (cons (cons key val) keys))]))
|
|
(let loop ([t (disarm orig)])
|
|
(define (next rest . args) (apply setkey! args) (loop rest))
|
|
(define (rearm e) (syntax-rearm e orig))
|
|
(syntax-case* t
|
|
(type: expr: bind: 1st-arg: prev-arg: pre: post: keywords: =>)
|
|
id=?
|
|
[(type: t x ...) (next #'(x ...) 'type (rearm #'t))]
|
|
[(expr: e x ...) (next #'(x ...) 'expr (rearm #'e))]
|
|
[(bind: id x ...) (next #'(x ...) 'bind (rearm #'id) #t)]
|
|
[(1st-arg: id x ...) (next #'(x ...) '1st (rearm #'id) #t)]
|
|
[(prev-arg: id x ...) (next #'(x ...) 'prev (rearm #'id) #t)]
|
|
[(pre: p => expr x ...) (err "bad form for `pre:'. Expected either `pre: (id => expression)' or `pre: expression'" #'(pre: p => expr))]
|
|
[(pre: p x ...) (next #'(x ...) 'pre (with-arg #'p rearm))]
|
|
[(post: p => expr x ...) (err "bad form for `post:' Expected either `post: (id => expression)' or `post: expression'" #'(post: p => expr))]
|
|
[(post: p x ...) (next #'(x ...) 'post (with-arg #'p rearm))]
|
|
[(keywords: x ...)
|
|
(let kloop ([ks '()] [xs #'(x ...)])
|
|
(syntax-case xs ()
|
|
[(k v x ...) (syntax-e #'k)
|
|
(kloop (cons (cons (syntax-e (rearm #'k)) (rearm #'v)) ks) #'(x ...))]
|
|
[_ (next xs 'keywords (reverse ks))]))]
|
|
[() (and (pair? keys) keys)]
|
|
[_else #f]))))
|
|
|
|
;; This is used for a normal expansion of fun-syntax, when not in a _fun type
|
|
;; context.
|
|
(define (expand-fun-syntax/normal fun-stx stx)
|
|
(define (err msg . sub)
|
|
(apply raise-syntax-error (fun-syntax-name fun-stx) msg stx sub))
|
|
(let ([keys (custom-type->keys stx err)])
|
|
(define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
|
|
(define (notkey key)
|
|
(when (getkey key)
|
|
(err (format "this type must be used in a _fun expression (uses ~s)"
|
|
key))))
|
|
(if keys
|
|
(let ([type (getkey 'type)] [pre (getkey 'pre)] [post (getkey 'post)])
|
|
(unless type
|
|
(err "this type must be used in a _fun expression (#f type)"))
|
|
(for-each notkey '(expr bind 1st prev keywords))
|
|
(if (or pre post)
|
|
;; a type with pre/post blocks
|
|
(let ([make-> (lambda (x what)
|
|
(cond [(not x) #'#f]
|
|
[(and (list? x) (= 2 (length x))
|
|
(identifier? (car x)))
|
|
#`(lambda (#,(car x)) #,(cadr x))]
|
|
[else #`(lambda (_)
|
|
(error '#,(fun-syntax-name fun-stx)
|
|
"cannot be used to ~a"
|
|
#,what))]))])
|
|
(with-syntax ([type type]
|
|
[scheme->c (make-> pre "send values to C")]
|
|
[c->scheme (make-> post "get values from C")])
|
|
#'(make-ctype type scheme->c c->scheme)))
|
|
;; simple type
|
|
type))
|
|
;; no keys => normal expansion
|
|
((fun-syntax-proc fun-stx) stx))))
|
|
|
|
(define-values (make-fun-syntax fun-syntax?
|
|
fun-syntax-proc fun-syntax-name)
|
|
(let-values ([(desc make pred? get set!)
|
|
(make-struct-type
|
|
'fun-syntax #f 2 0 #f '() (current-inspector)
|
|
expand-fun-syntax/normal)])
|
|
(values make pred?
|
|
(make-struct-field-accessor get 0 'proc)
|
|
(make-struct-field-accessor get 1 'name)))))
|
|
|
|
;; Use define-fun-syntax instead of define-syntax for forms that
|
|
;; are to be expanded by `_fun':
|
|
(provide define-fun-syntax)
|
|
(define-syntax define-fun-syntax
|
|
(syntax-rules ()
|
|
[(_ id trans)
|
|
(define-syntax id
|
|
(let* ([xformer trans]
|
|
[set!-trans? (set!-transformer? xformer)])
|
|
(unless (or (and (procedure? xformer)
|
|
(procedure-arity-includes? xformer 1))
|
|
set!-trans?)
|
|
(raise-type-error 'define-fun-syntax
|
|
"procedure (arity 1) or set!-transformer"
|
|
xformer))
|
|
(let ([f (make-fun-syntax (if set!-trans?
|
|
(set!-transformer-procedure xformer)
|
|
xformer)
|
|
'id)])
|
|
(if set!-trans? (make-set!-transformer f) f))))]))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Function type
|
|
|
|
;; Creates a simple function type that can be used for callouts and callbacks,
|
|
;; optionally applying a wrapper function to modify the result primitive
|
|
;; (callouts) or the input procedure (callbacks).
|
|
(define* (_cprocedure itypes otype
|
|
#:abi [abi #f]
|
|
#:wrapper [wrapper #f]
|
|
#:keep [keep #t]
|
|
#:atomic? [atomic? #f]
|
|
#:in-original-place? [orig-place? #f]
|
|
#:async-apply [async-apply #f]
|
|
#:save-errno [errno #f])
|
|
(_cprocedure* itypes otype abi wrapper keep atomic? orig-place? async-apply errno))
|
|
|
|
;; for internal use
|
|
(define held-callbacks (make-weak-hasheq))
|
|
(define (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? async-apply errno)
|
|
(define-syntax-rule (make-it wrap)
|
|
(make-ctype _fpointer
|
|
(lambda (x)
|
|
(and x
|
|
(let ([cb (ffi-callback (wrap x) itypes otype abi atomic? async-apply)])
|
|
(cond [(eq? keep #t) (hash-set! held-callbacks x cb)]
|
|
[(box? keep)
|
|
(let ([x (unbox keep)])
|
|
(set-box! keep
|
|
(if (or (null? x) (pair? x)) (cons cb x) cb)))]
|
|
[(procedure? keep) (keep cb)])
|
|
cb)))
|
|
(lambda (x) (and x (wrap (ffi-call x itypes otype abi errno orig-place?))))))
|
|
(if wrapper (make-it wrapper) (make-it begin)))
|
|
|
|
;; Syntax for the special _fun type:
|
|
;; (_fun [{(name ... [. name]) | name} [-> expr] ::]
|
|
;; {type | (name : type [= expr]) | ([name :] type = expr)} ...
|
|
;; -> {type | (name : type)}
|
|
;; [-> expr])
|
|
;; Usage:
|
|
;; `{(name ...) | ...} ::' specify explicit wrapper function formal arguments
|
|
;; `-> expr' can be used instead of the last expr
|
|
;; `type' input type (implies input, but see type macros next)
|
|
;; `(name : type = expr)' specify name and type, `= expr' means computed input
|
|
;; `-> type' output type (possibly with name)
|
|
;; `-> expr' specify different output, can use previous names
|
|
;; Also, see below for custom function types.
|
|
|
|
(provide ->) ; to signal better errors when trying to use this with contracts
|
|
(define-syntax (-> stx)
|
|
(raise-syntax-error '-> "should be used only in a _fun context" stx))
|
|
|
|
(provide _fun)
|
|
(define-for-syntax _fun-keywords
|
|
`([#:abi ,#'#f] [#:keep ,#'#t] [#:atomic? ,#'#f] [#:in-original-place? ,#'#f]
|
|
[#:async-apply ,#'#f] [#:save-errno ,#'#f]))
|
|
(define-syntax (_fun stx)
|
|
(define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
|
|
(define xs #f)
|
|
(define inputs #f)
|
|
(define output #f)
|
|
(define bind '())
|
|
(define pre '())
|
|
(define post '())
|
|
(define input-names #f)
|
|
(define output-type #f)
|
|
(define output-expr #f)
|
|
(define 1st-arg #f)
|
|
(define prev-arg #f)
|
|
(define (bind! x) (set! bind (append bind (list x))))
|
|
(define (pre! x) (set! pre (append pre (list x))))
|
|
(define (post! x) (set! post (append post (list x))))
|
|
(define-values (kwd-ref kwd-set!)
|
|
(let ([ks '()])
|
|
(values
|
|
(lambda (k)
|
|
(cond [(assq k ks) => cdr]
|
|
[(assq k _fun-keywords) => cadr]
|
|
[else (error '_fun "internal error: unknown keyword: ~.s" k)]))
|
|
(lambda (k-stx v [sub k-stx])
|
|
(let ([k (if (syntax? k-stx) (syntax-e k-stx) k-stx)])
|
|
(cond [(assq k ks)
|
|
(err (if (keyword? k-stx)
|
|
(format "indirectly duplicate ~s keyword" k-stx)
|
|
"duplicate keyword")
|
|
sub)]
|
|
[(assq k _fun-keywords) (set! ks (cons (cons k v) ks))]
|
|
[else (err "unknown keyword" sub)]))))))
|
|
(define ((t-n-e clause) type name expr)
|
|
(let ([keys (custom-type->keys type err)])
|
|
(define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
|
|
(define (arg x . no-expr?)
|
|
(define use-expr?
|
|
(and (list? x) (= 2 (length x)) (identifier? (car x))))
|
|
;; when the current expr is not used with a (x => ...) form,
|
|
;; either check that no expression is given or just make it
|
|
;; disappear from the inputs.
|
|
(unless use-expr?
|
|
(if (and (pair? no-expr?) (car no-expr?) expr)
|
|
(err "got an expression for a custom type that do not use it"
|
|
clause)
|
|
(set! expr (void))))
|
|
(set! x (if use-expr? (add-renamer (cadr x) name (car x)) x))
|
|
(cond [(getkey '1st) =>
|
|
(lambda (v)
|
|
(if 1st-arg
|
|
(set! x (add-renamer x 1st-arg v))
|
|
(err "got a custom type that wants 1st arg too early"
|
|
clause)))])
|
|
(cond [(getkey 'prev) =>
|
|
(lambda (v)
|
|
(if prev-arg
|
|
(set! x (add-renamer x prev-arg v))
|
|
(err "got a custom type that wants prev arg too early"
|
|
clause)))])
|
|
x)
|
|
(when keys
|
|
(set! type (getkey 'type))
|
|
(cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))])
|
|
(cond [(getkey 'bind) => (lambda (x) (bind! #`[#,x #,name]))])
|
|
(cond [(getkey 'pre ) => (lambda (x) (pre! #`[#,name #,(arg x #t)]))])
|
|
(cond [(getkey 'post) => (lambda (x) (post! #`[#,name #,(arg x)]))])
|
|
(cond [(getkey 'keywords)
|
|
=> (lambda (ks)
|
|
(for ([k+v (in-list ks)])
|
|
(kwd-set! (car k+v) (cdr k+v) clause)))]))
|
|
;; turn a #f syntax to #f
|
|
(set! type (and type (syntax-case type () [#f #f] [_ type])))
|
|
(when type ; remember these for later usages
|
|
(unless 1st-arg (set! 1st-arg name))
|
|
(set! prev-arg name))
|
|
(list type name expr)))
|
|
(define (do-fun)
|
|
;; parse keywords
|
|
(let loop ()
|
|
(let ([k (and (pair? xs) (pair? (cdr xs)) (car xs))])
|
|
(when (and (syntax? k)
|
|
(keyword? (syntax-e k)))
|
|
(kwd-set! k (cadr xs))
|
|
(set! xs (cddr xs))
|
|
(loop))))
|
|
;; parse known punctuation
|
|
(set! xs (map (lambda (x)
|
|
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
|
|
xs))
|
|
;; parse "::"
|
|
(let ([s (split-by ':: xs)])
|
|
(case (length s)
|
|
[(0) (err "something bad happened (::)")]
|
|
[(1) (void)]
|
|
[(2) (if (and (= 1 (length (car s))) (not (eq? '-> (caar s))))
|
|
(begin (set! xs (cadr s)) (set! input-names (caar s)))
|
|
(err "bad wrapper formals"))]
|
|
[else (err "saw two or more instances of `::'")]))
|
|
;; parse "->"
|
|
(let ([s (split-by '-> xs)])
|
|
(case (length s)
|
|
[(0) (err "something bad happened (->)")]
|
|
[(1) (err "missing output type")]
|
|
[(2 3) (set! inputs (car s))
|
|
(case (length (cadr s))
|
|
[(1) (set! output-type (caadr s))]
|
|
[(0) (err "missing output type after `->'")]
|
|
[else (err "extraneous output type" (cadadr s))])
|
|
(unless (null? (cddr s))
|
|
(case (length (caddr s))
|
|
[(1) (set! output-expr (caaddr s))]
|
|
[(0) (err "missing output expression after `->'")]
|
|
[else (err "extraneous output expression"
|
|
(cadr (caddr s)))]))]
|
|
[else (err "saw three or more instances of `->'")]))
|
|
(set! inputs
|
|
(map (lambda (sub temp)
|
|
(let ([t-n-e (t-n-e sub)])
|
|
(syntax-case* sub (: =) id=?
|
|
[(name : type) (t-n-e #'type #'name #f)]
|
|
[(type = expr) (t-n-e #'type temp #'expr)]
|
|
[(name : type = expr) (t-n-e #'type #'name #'expr)]
|
|
[type (t-n-e #'type temp #f)])))
|
|
inputs
|
|
(generate-temporaries (map (lambda (x) 'tmp) inputs))))
|
|
;; when processing the output type, only the post code matters
|
|
(set! pre! (lambda (x) #f))
|
|
(set! output
|
|
(let ([temp (car (generate-temporaries #'(ret)))]
|
|
[t-n-e (t-n-e output-type)])
|
|
(syntax-case* output-type (: =) id=?
|
|
[(name : type) (t-n-e #'type #'name output-expr)]
|
|
[(type = expr) (if output-expr
|
|
(err "extraneous output expression" #'expr)
|
|
(t-n-e #'type temp #'expr))]
|
|
[(name : type = expr)
|
|
(if output-expr
|
|
(err "extraneous output expression" #'expr)
|
|
(t-n-e #'type #'name #'expr))]
|
|
[type (t-n-e #'type temp output-expr)])))
|
|
(let ([make-cprocedure
|
|
(lambda (wrapper)
|
|
#`(_cprocedure* (list #,@(filter-map car inputs))
|
|
#,(car output)
|
|
#,(kwd-ref '#:abi)
|
|
#,wrapper
|
|
#,(kwd-ref '#:keep)
|
|
#,(kwd-ref '#:atomic?)
|
|
#,(kwd-ref '#:in-original-place?)
|
|
#,(kwd-ref '#:async-apply)
|
|
#,(kwd-ref '#:save-errno)))])
|
|
(if (or (caddr output) input-names (ormap caddr inputs)
|
|
(ormap (lambda (x) (not (car x))) inputs)
|
|
(pair? bind) (pair? pre) (pair? post))
|
|
(let* ([input-names
|
|
(or input-names
|
|
(filter-map (lambda (i) (and (not (caddr i)) (cadr i)))
|
|
inputs))]
|
|
[output-expr
|
|
(let ([o (caddr output)])
|
|
(or (and (not (void? o)) o) (cadr output)))]
|
|
[args
|
|
(filter-map (lambda (i)
|
|
(and (caddr i)
|
|
(not (void? (caddr i)))
|
|
#`[#,(cadr i) #,(caddr i)]))
|
|
inputs)]
|
|
[ffi-args
|
|
(filter-map (lambda (x) (and (car x) (cadr x))) inputs)]
|
|
;; the actual wrapper body
|
|
[body (quasisyntax/loc stx
|
|
(lambda #,input-names
|
|
(let* (#,@args
|
|
#,@bind
|
|
#,@pre
|
|
[#,(cadr output) (ffi #,@ffi-args)]
|
|
#,@post)
|
|
#,output-expr)))]
|
|
;; if there is a string 'ffi-name property, use it as a name
|
|
[body (let ([n (cond [(syntax-property stx 'ffi-name)
|
|
=> syntax->datum]
|
|
[else #f])])
|
|
(if (string? n)
|
|
(syntax-property
|
|
body 'inferred-name
|
|
(string->symbol (string-append "ffi-wrapper:" n)))
|
|
body))])
|
|
(make-cprocedure #`(lambda (ffi) #,body)))
|
|
(make-cprocedure #'#f))))
|
|
(syntax-case stx ()
|
|
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))
|
|
|
|
(define (function-ptr p fun-ctype)
|
|
(if (or (cpointer? p) (procedure? p))
|
|
(if (eq? (ctype->layout fun-ctype) 'fpointer)
|
|
(if (procedure? p)
|
|
((ctype-scheme->c fun-ctype) p)
|
|
((ctype-c->scheme fun-ctype) p))
|
|
(raise-type-error 'function-ptr "function ctype" fun-ctype))
|
|
(raise-type-error 'function-ptr "cpointer" p)))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; String types
|
|
|
|
;; The internal _string type uses the native ucs-4 encoding, also providing a
|
|
;; utf-16 type
|
|
(provide _string/ucs-4 _string/utf-16)
|
|
|
|
;; 8-bit string encodings, #f is NULL
|
|
(define ((false-or-op op) x) (and x (op x)))
|
|
(define* _string/utf-8
|
|
(make-ctype _bytes
|
|
(false-or-op string->bytes/utf-8) (false-or-op bytes->string/utf-8)))
|
|
(define* _string/locale
|
|
(make-ctype _bytes
|
|
(false-or-op string->bytes/locale) (false-or-op bytes->string/locale)))
|
|
(define* _string/latin-1
|
|
(make-ctype _bytes
|
|
(false-or-op string->bytes/latin-1) (false-or-op bytes->string/latin-1)))
|
|
|
|
;; 8-bit string encodings, #f is NULL, can also use bytes and paths
|
|
(define ((any-string-op op) x)
|
|
(cond [(not x) x]
|
|
[(bytes? x) x]
|
|
[(path? x) (path->bytes x)]
|
|
[else (op x)]))
|
|
(define* _string*/utf-8
|
|
(make-ctype _bytes
|
|
(any-string-op string->bytes/utf-8) (false-or-op bytes->string/utf-8)))
|
|
(define* _string*/locale
|
|
(make-ctype _bytes
|
|
(any-string-op string->bytes/locale) (false-or-op bytes->string/locale)))
|
|
(define* _string*/latin-1
|
|
(make-ctype _bytes
|
|
(any-string-op string->bytes/latin-1) (false-or-op bytes->string/latin-1)))
|
|
|
|
;; A generic _string type that usually does the right thing via a parameter
|
|
(define* default-_string-type
|
|
(make-parameter _string*/utf-8
|
|
(lambda (x)
|
|
(if (ctype? x)
|
|
x (error 'default-_string-type "expecting a C type, got ~e" x)))))
|
|
;; The type looks like an identifier, but it's actually using the parameter
|
|
(provide _string)
|
|
(define-syntax _string
|
|
(syntax-id-rules ()
|
|
[(_ . xs) ((default-_string-type) . xs)]
|
|
[_ (default-_string-type)]))
|
|
|
|
;; _symbol is defined in C, since it uses simple C strings
|
|
(provide _symbol)
|
|
|
|
(provide _path)
|
|
;; `file' type: path-expands a path string, provide _path too.
|
|
(define* _file (make-ctype _path cleanse-path #f))
|
|
|
|
;; `string/eof' type: converts an output #f (NULL) to an eof-object.
|
|
(define string-type->string/eof-type
|
|
(let ([table (make-hasheq)])
|
|
(lambda (string-type)
|
|
(hash-ref table string-type
|
|
(lambda ()
|
|
(let ([new-type (make-ctype string-type
|
|
(lambda (x) (and (not (eof-object? x)) x))
|
|
(lambda (x) (or x eof)))])
|
|
(hash-set! table string-type new-type)
|
|
new-type))))))
|
|
(provide _string/eof _bytes/eof)
|
|
(define _bytes/eof
|
|
(make-ctype _bytes
|
|
(lambda (x) (and (not (eof-object? x)) x))
|
|
(lambda (x) (or x eof))))
|
|
(define-syntax _string/eof ; make it a syntax so it depends on the _string type
|
|
(syntax-id-rules ()
|
|
[(_ . xs) ((string-type->string/eof-type _string) . xs)]
|
|
[_ (string-type->string/eof-type _string)]))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Utility types
|
|
|
|
;; Call this with a name (symbol) and a list of symbols, where a symbol can be
|
|
;; followed by a '= and an integer to have a similar effect of C's enum.
|
|
(define (_enum name symbols [basetype _ufixint] #:unknown [unknown _enum])
|
|
(define sym->int '())
|
|
(define int->sym '())
|
|
(define s->c
|
|
(if name (string->symbol (format "enum:~a->int" name)) 'enum->int))
|
|
(define c->s
|
|
(if name (string->symbol (format "enum:int->~a" name)) 'int->enum))
|
|
(let loop ([i 0] [symbols symbols])
|
|
(unless (null? symbols)
|
|
(let-values ([(i rest) (if (and (pair? (cdr symbols))
|
|
(eq? '= (cadr symbols))
|
|
(pair? (cddr symbols)))
|
|
(values (caddr symbols) (cdddr symbols))
|
|
(values i (cdr symbols)))])
|
|
(set! sym->int (cons (cons (car symbols) i) sym->int))
|
|
(set! int->sym (cons (cons i (car symbols)) int->sym))
|
|
(loop (add1 i) rest))))
|
|
(make-ctype basetype
|
|
(lambda (x)
|
|
(let ([a (assq x sym->int)])
|
|
(if a
|
|
(cdr a)
|
|
(raise-type-error s->c (format "~a" (or name "enum")) x))))
|
|
(lambda (x)
|
|
(cond [(assq x int->sym) => cdr]
|
|
[(eq? unknown _enum)
|
|
(error c->s "expected a known ~a, got: ~s" basetype x)]
|
|
[(procedure? unknown) (unknown x)]
|
|
[else unknown]))))
|
|
|
|
;; Macro wrapper -- no need for a name
|
|
(provide (rename-out [_enum* _enum]))
|
|
(define-syntax (_enum* stx)
|
|
(syntax-case stx ()
|
|
[(_ x ...)
|
|
(with-syntax ([name (syntax-local-name)]) #'(_enum 'name x ...))]
|
|
[id (identifier? #'id) #'_enum]))
|
|
|
|
;; Call this with a name (symbol) and a list of (symbol int) or symbols like
|
|
;; the above with '= -- but the numbers have to be specified in some way. The
|
|
;; generated type will convert a list of these symbols into the logical-or of
|
|
;; their values and back.
|
|
(define (_bitmask name orig-symbols->integers . base?)
|
|
(define basetype (if (pair? base?) (car base?) _uint))
|
|
(define s->c
|
|
(if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int))
|
|
(define symbols->integers
|
|
(let loop ([s->i orig-symbols->integers])
|
|
(cond
|
|
[(null? s->i)
|
|
null]
|
|
[(and (pair? (cdr s->i)) (eq? '= (cadr s->i)) (pair? (cddr s->i)))
|
|
(cons (list (car s->i) (caddr s->i))
|
|
(loop (cdddr s->i)))]
|
|
[(and (pair? (car s->i)) (pair? (cdar s->i)) (null? (cddar s->i))
|
|
(symbol? (caar s->i)) (integer? (cadar s->i)))
|
|
(cons (car s->i) (loop (cdr s->i)))]
|
|
[else
|
|
(error '_bitmask "bad spec in ~e" orig-symbols->integers)])))
|
|
(make-ctype basetype
|
|
(lambda (symbols)
|
|
(if (null? symbols) ; probably common
|
|
0
|
|
(let loop ([xs (if (pair? symbols) symbols (list symbols))] [n 0])
|
|
(cond [(null? xs) n]
|
|
[(assq (car xs) symbols->integers) =>
|
|
(lambda (x) (loop (cdr xs) (bitwise-ior (cadr x) n)))]
|
|
[else (raise-type-error s->c (format "~a" (or name "bitmask"))
|
|
symbols)]))))
|
|
(lambda (n)
|
|
(if (zero? n) ; probably common
|
|
'()
|
|
(let loop ([s->i symbols->integers] [l '()])
|
|
(if (null? s->i)
|
|
(reverse l)
|
|
(loop (cdr s->i)
|
|
(let ([i (cadar s->i)])
|
|
(if (and (not (= i 0)) (= i (bitwise-and i n)))
|
|
(cons (caar s->i) l)
|
|
l)))))))))
|
|
|
|
;; Macro wrapper -- no need for a name
|
|
(provide (rename-out [_bitmask* _bitmask]))
|
|
(define-syntax (_bitmask* stx)
|
|
(syntax-case stx ()
|
|
[(_ x ...)
|
|
(with-syntax ([name (syntax-local-name)]) #'(_bitmask 'name x ...))]
|
|
[id (identifier? #'id) #'_bitmask]))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Custom function type macros
|
|
|
|
;; These macros get expanded by the _fun type. They can expand to a form that
|
|
;; looks like (keyword: value ...), where the keyword is one of:
|
|
;; * `type:' for the type that will be used,
|
|
;; * `expr:' an expression that will always be used for these arguments, as
|
|
;; if `= expr' is always given, when an expression is actually
|
|
;; given in an argument specification, it supersedes this.
|
|
;; * `bind:' for an additional binding that holds the initial value,
|
|
;; * `1st-arg:' is used to name an identifier that will be bound to the value
|
|
;; of the 1st foreign argument in pre/post chunks (good for
|
|
;; common cases where the first argument has a special meaning,
|
|
;; eg, for method calls),
|
|
;; * `prev-arg:' similar to 1st-arg: but for the previous argument,
|
|
;; * `pre:' for a binding that will be inserted before the ffi call,
|
|
;; * `post:' for a binding after the ffi call,
|
|
;; * `keywords:' specifying keywords to be used in the surrounding _fun
|
|
;; (the keywords and values follow).
|
|
;; The pre: and post: bindings can be of the form (id => expr) to use the
|
|
;; existing value. Note that if the pre: expression is not (id => expr), then
|
|
;; it means that there is no input for this argument. Also note that if a
|
|
;; custom type is used as an output type of a function, then only the post:
|
|
;; code is used -- for example, this is useful for foreign functions that
|
|
;; allocate a memory block and return it to the user. The resulting wrapper
|
|
;; looks like:
|
|
;; (let* (...bindings for arguments...
|
|
;; ...bindings for bind: identifiers...
|
|
;; ...bindings for pre-code...
|
|
;; (ret-name ffi-call)
|
|
;; ...bindings for post-code...)
|
|
;; return-expression)
|
|
;;
|
|
;; Finally, the code in a custom-function macro needs special treatment when it
|
|
;; comes to dealing with code certificates, so instead of using
|
|
;; `define-syntax', you should use `define-fun-syntax' (used in the same way).
|
|
|
|
;; _?
|
|
;; This is not a normal ffi type -- it is a marker for expressions that should
|
|
;; not be sent to the ffi function. Use this to bind local values in a
|
|
;; computation that is part of an ffi wrapper interface.
|
|
(provide _?)
|
|
(define-fun-syntax _?
|
|
(syntax-id-rules () [(_ . xs) ((type: #f) . xs)] [_ (type: #f)]))
|
|
|
|
;; (_ptr <mode> <type>)
|
|
;; This is for pointers, where mode indicates input or output pointers (or
|
|
;; both). If the mode is `o' (output), then the wrapper will not get an
|
|
;; argument for it, instead it generates the matching argument.
|
|
(provide _ptr)
|
|
(define-fun-syntax _ptr
|
|
(syntax-rules (i o io)
|
|
[(_ i t) (type: _pointer
|
|
pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)))]
|
|
[(_ o t) (type: _pointer
|
|
pre: (malloc t)
|
|
post: (x => (ptr-ref x t)))]
|
|
[(_ io t) (type: _pointer
|
|
pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p))
|
|
post: (x => (ptr-ref x t)))]))
|
|
|
|
;; (_box <type>)
|
|
;; This is similar to a (_ptr io <type>) argument, where the input is expected
|
|
;; to be a box, which is unboxed on entry and modified on exit.
|
|
(provide _box)
|
|
(define-fun-syntax _box
|
|
(syntax-rules ()
|
|
[(_ t) (type: _pointer
|
|
bind: tmp ; need to save the box so we can get back to it
|
|
pre: (x => (let ([p (malloc t)]) (ptr-set! p t (unbox x)) p))
|
|
post: (x => (begin (set-box! tmp (ptr-ref x t)) tmp)))]))
|
|
|
|
;; (_list <mode> <type> [<len>])
|
|
;; Similar to _ptr, except that it is used for converting lists to/from C
|
|
;; vectors. The length is needed for output values where it is used in the
|
|
;; post code, and in the pre code of an output mode to allocate the block. In
|
|
;; any case it can refer to a previous binding for the length of the list which
|
|
;; the C function will most likely require.
|
|
(provide _list)
|
|
(define-fun-syntax _list
|
|
(syntax-rules (i o io)
|
|
[(_ i t ) (type: _pointer
|
|
pre: (x => (list->cblock x t)))]
|
|
[(_ o t n) (type: _pointer
|
|
pre: (malloc n t)
|
|
post: (x => (cblock->list x t n)))]
|
|
[(_ io t n) (type: _pointer
|
|
pre: (x => (list->cblock x t))
|
|
post: (x => (cblock->list x t n)))]))
|
|
|
|
;; (_vector <mode> <type> [<len>])
|
|
;; Same as _list, except that it uses Scheme vectors.
|
|
(provide _vector)
|
|
(define-fun-syntax _vector
|
|
(syntax-rules (i o io)
|
|
[(_ i t ) (type: _pointer
|
|
pre: (x => (vector->cblock x t)))]
|
|
[(_ o t n) (type: _pointer
|
|
pre: (malloc n t)
|
|
post: (x => (cblock->vector x t n)))]
|
|
[(_ io t n) (type: _pointer
|
|
pre: (x => (vector->cblock x t))
|
|
post: (x => (cblock->vector x t n)))]))
|
|
|
|
;; _bytes or (_bytes o n) is for a memory block represented as a Scheme byte
|
|
;; string. _bytes is just like a byte-string, and (_bytes o n) is for
|
|
;; pre-malloc of the string. There is no need for other modes: i or io would
|
|
;; be just like _bytes since the string carries its size information (so there
|
|
;; is no real need for the `o', but it's there for consistency with the above
|
|
;; macros).
|
|
(provide (rename-out [_bytes* _bytes]))
|
|
(define-fun-syntax _bytes*
|
|
(syntax-id-rules (o)
|
|
[(_ o n) (type: _pointer
|
|
pre: (make-sized-byte-string (malloc n) n)
|
|
;; post is needed when this is used as a function output type
|
|
post: (x => (make-sized-byte-string x n)))]
|
|
[(_ . xs) (_bytes . xs)]
|
|
[_ _bytes]))
|
|
|
|
;; (_array <type> <len> ...+)
|
|
(provide _array
|
|
array? array-ptr
|
|
(protect-out array-ref array-set!))
|
|
|
|
(define _array
|
|
(case-lambda
|
|
[(t n)
|
|
(make-ctype (make-array-type t n)
|
|
(lambda (v) (array-ptr v))
|
|
(lambda (v) (make-array v t n)))]
|
|
[(t n . ns)
|
|
(_array (apply _array t ns) n)]))
|
|
|
|
(define-struct array (ptr type len))
|
|
(define array-ref
|
|
(case-lambda
|
|
[(a i)
|
|
(let ([len (array-len a)])
|
|
(if (< -1 i len)
|
|
(ptr-ref (array-ptr a) (array-type a) i)
|
|
(raise-mismatch-error 'array-ref "index out of bounds: " i)))]
|
|
[(a . is)
|
|
(let loop ([a a] [is is])
|
|
(if (null? is)
|
|
a
|
|
(loop (array-ref a (car is)) (cdr is))))]))
|
|
(define array-set!
|
|
(case-lambda
|
|
[(a i v)
|
|
(let ([len (array-len a)])
|
|
(if (< -1 i len)
|
|
(ptr-set! (array-ptr a) (array-type a) i v)
|
|
(raise-mismatch-error 'array-ref "index out of bounds: " i)))]
|
|
[(a i i1 . is+v)
|
|
(let ([is+v (reverse (list* i i1 is+v))])
|
|
(define v (car is+v))
|
|
(define i (cadr is+v))
|
|
(let loop ([a a] [is (cddr is+v)])
|
|
(if (null? is)
|
|
(array-set! a i v)
|
|
(loop (array-ref a (car is)) (cdr is)))))]))
|
|
|
|
;; (_array/list <type> <len> ...+)
|
|
;; Like _list, but for arrays instead of pointers at the C level.
|
|
(provide _array/list)
|
|
(define _array/list
|
|
(case-lambda
|
|
[(t n)
|
|
(make-ctype (make-array-type t n)
|
|
(lambda (v) (list->cblock v t n))
|
|
(lambda (v) (cblock->list v t n)))]
|
|
[(t n . ns)
|
|
(_array/list (apply _array/list t ns) n)]))
|
|
|
|
;; (_array/vector <type> <len> ...+)
|
|
;; Like _vector, but for arrays instead of pointers at the C level.
|
|
(provide _array/vector)
|
|
(define _array/vector
|
|
(case-lambda
|
|
[(t n)
|
|
(make-ctype (make-array-type t n)
|
|
(lambda (v) (vector->cblock v t n))
|
|
(lambda (v) (cblock->vector v t n)))]
|
|
[(t n . ns)
|
|
(_array/vector (apply _array/vector t ns) n)]))
|
|
|
|
;; (_union <type> ...+)
|
|
(provide _union
|
|
union? union-ptr
|
|
(protect-out union-ref union-set!))
|
|
|
|
(define (_union t . ts)
|
|
(let ([ts (cons t ts)])
|
|
(make-ctype (apply make-union-type ts)
|
|
(lambda (v) (union-ptr v))
|
|
(lambda (v) (make-union v ts)))))
|
|
|
|
(define-struct union (ptr types))
|
|
(define (union-ref u i)
|
|
(ptr-ref (union-ptr u) (list-ref (union-types u) i)))
|
|
(define (union-set! u i v)
|
|
(ptr-set! (union-ptr u) (list-ref (union-types u) i) v))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Tagged pointers
|
|
|
|
;; Make these operations available for unsafe interfaces (they can be used to
|
|
;; grab a hidden tag value and break code).
|
|
(provide cpointer-tag set-cpointer-tag!
|
|
cpointer-has-tag? cpointer-push-tag!)
|
|
|
|
;; Defined as syntax for efficiency, but can be used as procedures too.
|
|
(define-syntax (cpointer-has-tag? stx)
|
|
(syntax-case stx ()
|
|
[(_ cptr tag)
|
|
#'(let ([ptag (cpointer-tag cptr)])
|
|
(if (pair? ptag) (memq tag ptag) (eq? tag ptag)))]
|
|
[id (identifier? #'id)
|
|
#'(lambda (cptr tag) (cpointer-has-tag? cptr tag))]))
|
|
(define-syntax (cpointer-push-tag! stx)
|
|
(syntax-case stx ()
|
|
[(_ cptr tag)
|
|
#'(let ([ptag (cpointer-tag cptr)])
|
|
(set-cpointer-tag! cptr
|
|
(cond [(not ptag) tag]
|
|
[(pair? ptag) (cons tag ptag)]
|
|
[else (list tag ptag)])))]
|
|
[id (identifier? #'id)
|
|
#'(lambda (cptr tag) (cpointer-push-tag! cptr tag))]))
|
|
|
|
(define (cpointer-maker nullable?)
|
|
(case-lambda
|
|
[(tag) ((cpointer-maker nullable?) tag #f #f #f)]
|
|
[(tag ptr-type) ((cpointer-maker nullable?) tag ptr-type #f #f)]
|
|
[(tag ptr-type scheme->c c->scheme)
|
|
(let* ([tag->C (string->symbol (format "~a->C" tag))]
|
|
[error-str (format "~a`~a' pointer"
|
|
(if nullable? "" "non-null ") tag)]
|
|
[error* (lambda (p) (raise-type-error tag->C error-str p))])
|
|
(define-syntax-rule (tag-or-error ptr t)
|
|
(let ([p ptr])
|
|
(if (cpointer? p)
|
|
(if (cpointer-has-tag? p t) p (error* p))
|
|
(error* p))))
|
|
(define-syntax-rule (tag-or-error/null ptr t)
|
|
(let ([p ptr])
|
|
(if (cpointer? p)
|
|
(and p (if (cpointer-has-tag? p t) p (error* p)))
|
|
(error* p))))
|
|
(make-ctype (or ptr-type _pointer)
|
|
;; bad hack: `if's outside the lambda for efficiency
|
|
(if nullable?
|
|
(if scheme->c
|
|
(lambda (p) (tag-or-error/null (scheme->c p) tag))
|
|
(lambda (p) (tag-or-error/null p tag)))
|
|
(if scheme->c
|
|
(lambda (p) (tag-or-error (scheme->c p) tag))
|
|
(lambda (p) (tag-or-error p tag))))
|
|
(if nullable?
|
|
(if c->scheme
|
|
(lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p))
|
|
(lambda (p) (when p (cpointer-push-tag! p tag)) p))
|
|
(if c->scheme
|
|
(lambda (p)
|
|
(if p (cpointer-push-tag! p tag) (error* p))
|
|
(c->scheme p))
|
|
(lambda (p)
|
|
(if p (cpointer-push-tag! p tag) (error* p))
|
|
p)))))]))
|
|
|
|
;; This is a kind of a pointer that gets a specific tag when converted to
|
|
;; Scheme, and accepts only such tagged pointers when going to C. An optional
|
|
;; `ptr-type' can be given to be used as the base pointer type, instead of
|
|
;; _pointer, `scheme->c' and `c->scheme' can be used for adding conversion
|
|
;; hooks.
|
|
(define* _cpointer (cpointer-maker #f))
|
|
|
|
;; Similar to the above, but can tolerate null pointers (#f).
|
|
(define* _cpointer/null (cpointer-maker #t))
|
|
|
|
(define (cast p from-type to-type)
|
|
(unless (ctype? from-type)
|
|
(raise-type-error 'cast "ctype" from-type))
|
|
(unless (ctype? to-type)
|
|
(raise-type-error 'cast "ctype" to-type))
|
|
(unless (= (ctype-sizeof to-type)
|
|
(ctype-sizeof from-type))
|
|
(raise-mismatch-error 'cast
|
|
(format "representation sizes of from and to types differ: ~e and "
|
|
(ctype-sizeof from-type))
|
|
(ctype-sizeof to-type)))
|
|
(let ([p2 (malloc from-type)])
|
|
(ptr-set! p2 from-type p)
|
|
(ptr-ref p2 to-type)))
|
|
|
|
(define* (_or-null ctype)
|
|
(let ([coretype (ctype-coretype ctype)])
|
|
(unless (memq coretype '(pointer gcpointer fpointer))
|
|
(raise-type-error '_or-null "ctype buit on pointer, gcpointer, or fpointer" ctype))
|
|
(make-ctype
|
|
(case coretype
|
|
[(pointer) _pointer]
|
|
[(gcpointer) _gcpointer]
|
|
[(fpointer) _fpointer])
|
|
(lambda (v) (and v (cast v _pointer _pointer)))
|
|
(lambda (v) (and v (cast v _pointer ctype))))))
|
|
|
|
(define* (_gcable ctype)
|
|
(unless (memq (ctype-coretype ctype) '(pointer gcpointer))
|
|
(raise-type-error '_or-null "pointer ctype" ctype))
|
|
(let loop ([ctype ctype])
|
|
(if (eq? ctype 'pointer)
|
|
_gcpointer
|
|
(make-ctype
|
|
(loop (ctype-basetype ctype))
|
|
(ctype-scheme->c ctype)
|
|
(ctype-c->scheme ctype)))))
|
|
|
|
(define (ctype-coretype c)
|
|
(let loop ([c (ctype-basetype c)])
|
|
(if (symbol? c)
|
|
c
|
|
(loop (ctype-basetype c)))))
|
|
|
|
;; A macro version of the above two functions, using the defined name for a tag
|
|
;; string, and defining a predicate too. The name should look like `_foo', the
|
|
;; predicate will be `foo?', and the tag will be "foo". In addition, `foo-tag'
|
|
;; is bound to the tag. The optional `ptr-type', `scheme->c', and `c->scheme'
|
|
;; arguments are the same as those of `_cpointer'. `_foo' will be bound to the
|
|
;; _cpointer type, and `_foo/null' to the _cpointer/null type.
|
|
(provide define-cpointer-type)
|
|
(define-syntax (define-cpointer-type stx)
|
|
(syntax-case stx ()
|
|
[(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f)]
|
|
[(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f)]
|
|
[(_ _TYPE ptr-type scheme->c c->scheme)
|
|
(and (identifier? #'_TYPE)
|
|
(regexp-match #rx"^_.+" (symbol->string (syntax-e #'_TYPE))))
|
|
(let ([name (cadr (regexp-match #rx"^_(.+)$"
|
|
(symbol->string (syntax-e #'_TYPE))))])
|
|
(define (id . strings)
|
|
(datum->syntax
|
|
#'_TYPE (string->symbol (apply string-append strings)) #'_TYPE))
|
|
(with-syntax ([TYPE (id name)]
|
|
[TYPE? (id name "?")]
|
|
[TYPE-tag (id name "-tag")]
|
|
[_TYPE/null (id "_" name "/null")])
|
|
#'(define-values (_TYPE _TYPE/null TYPE? TYPE-tag)
|
|
(let ([TYPE-tag 'TYPE])
|
|
(values (_cpointer TYPE-tag ptr-type scheme->c c->scheme)
|
|
(_cpointer/null TYPE-tag ptr-type scheme->c c->scheme)
|
|
(lambda (x)
|
|
(and (cpointer? x) (cpointer-has-tag? x TYPE-tag)))
|
|
TYPE-tag)))))]))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Struct wrappers
|
|
|
|
(define (compute-offsets types alignment)
|
|
(let ([alignment (if (memq alignment '(#f 1 2 4 8 16))
|
|
alignment
|
|
#f)])
|
|
(let loop ([ts types] [cur 0] [r '()])
|
|
(if (null? ts)
|
|
(reverse r)
|
|
(let* ([algn (if alignment
|
|
(min alignment (ctype-alignof (car ts)))
|
|
(ctype-alignof (car ts)))]
|
|
[pos (+ cur (modulo (- (modulo cur algn)) algn))])
|
|
(loop (cdr ts)
|
|
(+ pos (ctype-sizeof (car ts)))
|
|
(cons pos r)))))))
|
|
|
|
;; Simple structs: call this with a list of types, and get a type that marshals
|
|
;; C structs to/from Scheme lists.
|
|
(define* (_list-struct #:alignment [alignment #f] . types)
|
|
(let ([stype (make-cstruct-type types #f alignment)]
|
|
[offsets (compute-offsets types alignment)]
|
|
[len (length types)])
|
|
(make-ctype stype
|
|
(lambda (vals)
|
|
(unless (and (list vals) (= len (length vals)))
|
|
(raise-type-error 'list-struct (format "list of ~a items" len) vals))
|
|
(let ([block (malloc stype)])
|
|
(for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val))
|
|
types offsets vals)
|
|
block))
|
|
(lambda (block)
|
|
(map (lambda (type ofs) (ptr-ref block type 'abs ofs))
|
|
types offsets)))))
|
|
|
|
;; (define-cstruct _foo ([slot type] ...))
|
|
;; or
|
|
;; (define-cstruct (_foo _super) ([slot type] ...))
|
|
;; defines a type called _foo for a C struct, with user-procedues: make-foo,
|
|
;; foo? foo-slot... and set-foo-slot!.... The `_' prefix is required. Objects
|
|
;; of this new type are actually cpointers, with a type tag that is "foo" and
|
|
;; (possibly more if the first type is itself a cstruct type or if a super type
|
|
;; is given,) provided as foo-tag, and tags of pointers are checked before
|
|
;; attempting to use them (see define-cpointer-type above). Note that since
|
|
;; structs are implemented as pointers, they can be used for a _pointer input
|
|
;; to a foreign function: their address will be used, to make this possible,
|
|
;; the corresponding cpointer type is defined as _foo-pointer. If a super
|
|
;; cstruct type is given, the constructor function expects values for every
|
|
;; field of the super type as well as other fields that are specified, and a
|
|
;; slot named `super' can be used to extract this initial struct -- although
|
|
;; pointers to the new struct type can be used as pointers to the super struct
|
|
;; type.
|
|
(provide define-cstruct)
|
|
(define-syntax (define-cstruct stx)
|
|
(define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx alignment-stx)
|
|
(define name
|
|
(cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
|
|
(define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
|
|
(syntax->list slot-names-stx)))
|
|
(define 1st-type
|
|
(let ([xs (syntax->list slot-types-stx)]) (and (pair? xs) (car xs))))
|
|
(define (id . strings)
|
|
(datum->syntax
|
|
_TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx))
|
|
(define (ids name-func)
|
|
(map (lambda (s)
|
|
(datum->syntax
|
|
_TYPE-stx
|
|
(string->symbol (apply string-append (name-func s)))
|
|
_TYPE-stx))
|
|
slot-names))
|
|
(define (safe-id=? x y)
|
|
(and (identifier? x) (identifier? y) (free-identifier=? x y)))
|
|
(with-syntax
|
|
([has-super? has-super?]
|
|
[struct-string (format "struct:~a" name)]
|
|
[(slot ...) slot-names-stx]
|
|
[(slot-type ...) slot-types-stx]
|
|
[TYPE (id name)]
|
|
[_TYPE _TYPE-stx]
|
|
[_TYPE-pointer (id "_"name"-pointer")]
|
|
[_TYPE-pointer/null (id "_"name"-pointer/null")]
|
|
[_TYPE/null (id "_"name"/null")]
|
|
[_TYPE* (id "_"name"*")]
|
|
[TYPE? (id name"?")]
|
|
[make-TYPE (id "make-"name)]
|
|
[list->TYPE (id "list->"name)]
|
|
[list*->TYPE (id "list*->"name)]
|
|
[TYPE->list (id name"->list")]
|
|
[TYPE->list* (id name"->list*")]
|
|
[TYPE-tag (id name"-tag")]
|
|
[(stype ...) (ids (lambda (s) `(,name"-",s"-type")))]
|
|
[(TYPE-SLOT ...) (ids (lambda (s) `(,name"-",s)))]
|
|
[(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))]
|
|
[(offset ...) (generate-temporaries
|
|
(ids (lambda (s) `(,s"-offset"))))]
|
|
[alignment alignment-stx])
|
|
(with-syntax ([get-super-info
|
|
;; the 1st-type might be a pointer to this type
|
|
(if (or (safe-id=? 1st-type #'_TYPE-pointer/null)
|
|
(safe-id=? 1st-type #'_TYPE-pointer))
|
|
#'(values #f '() #f #f #f #f)
|
|
#`(cstruct-info #,1st-type
|
|
(lambda () (values #f '() #f #f #f #f))))])
|
|
#'(begin
|
|
(define-syntax TYPE
|
|
(make-struct-info
|
|
(lambda ()
|
|
(list #f ; no struct:
|
|
(quote-syntax make-TYPE)
|
|
(quote-syntax TYPE?)
|
|
(reverse (list (quote-syntax TYPE-SLOT) ...))
|
|
(reverse (list (quote-syntax set-TYPE-SLOT!) ...))
|
|
#t))))
|
|
(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
|
|
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
|
|
list->TYPE list*->TYPE TYPE->list TYPE->list*)
|
|
(let-values ([(super-pointer super-tags super-types super-offsets
|
|
super->list* list*->super)
|
|
get-super-info])
|
|
(define-cpointer-type _TYPE super-pointer)
|
|
;; these makes it possible to use recursive pointer definitions
|
|
(define _TYPE-pointer _TYPE)
|
|
(define _TYPE-pointer/null _TYPE/null)
|
|
(let*-values ([(stype ...) (values slot-type ...)]
|
|
[(types) (list stype ...)]
|
|
[(alignment-v) alignment]
|
|
[(offsets) (compute-offsets types alignment-v)]
|
|
[(offset ...) (apply values offsets)])
|
|
(define all-tags (cons TYPE-tag super-tags))
|
|
(define _TYPE*
|
|
;; c->scheme adjusts all tags
|
|
(let* ([cst (make-cstruct-type types #f alignment-v)]
|
|
[t (_cpointer TYPE-tag cst)]
|
|
[c->s (ctype-c->scheme t)])
|
|
(make-ctype cst (ctype-scheme->c t)
|
|
;; hack: modify & reuse the procedure made by _cpointer
|
|
(lambda (p)
|
|
(if p (set-cpointer-tag! p all-tags) (c->s p))
|
|
p))))
|
|
(define-values (all-types all-offsets)
|
|
(if (and has-super? super-types super-offsets)
|
|
(values (append super-types (cdr types))
|
|
(append super-offsets (cdr offsets)))
|
|
(values types offsets)))
|
|
(define (TYPE-SLOT x)
|
|
(unless (TYPE? x)
|
|
(raise-type-error 'TYPE-SLOT struct-string x))
|
|
(ptr-ref x stype 'abs offset))
|
|
...
|
|
(define (set-TYPE-SLOT! x slot)
|
|
(unless (TYPE? x)
|
|
(raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
|
|
(ptr-set! x stype 'abs offset slot))
|
|
...
|
|
(define make-TYPE
|
|
(if (and has-super? super-types super-offsets)
|
|
;; init using all slots
|
|
(lambda vals
|
|
(if (= (length vals) (length all-types))
|
|
(let ([block (malloc _TYPE*)])
|
|
(set-cpointer-tag! block all-tags)
|
|
(for-each (lambda (type ofs value)
|
|
(ptr-set! block type 'abs ofs value))
|
|
all-types all-offsets vals)
|
|
block)
|
|
(error '_TYPE "expecting ~s values, got ~s: ~e"
|
|
(length all-types) (length vals) vals)))
|
|
;; normal initializer
|
|
(lambda (slot ...)
|
|
(let ([block (malloc _TYPE*)])
|
|
(set-cpointer-tag! block all-tags)
|
|
(ptr-set! block stype 'abs offset slot)
|
|
...
|
|
block))))
|
|
(define (list->TYPE vals) (apply make-TYPE vals))
|
|
(define (list*->TYPE vals)
|
|
(cond
|
|
[(TYPE? vals) vals]
|
|
[(= (length vals) (length all-types))
|
|
(let ([block (malloc _TYPE*)])
|
|
(set-cpointer-tag! block all-tags)
|
|
(for-each
|
|
(lambda (type ofs value)
|
|
(let-values
|
|
([(ptr tags types offsets T->list* list*->T)
|
|
(cstruct-info
|
|
type
|
|
(lambda () (values #f '() #f #f #f #f)))])
|
|
(ptr-set! block type 'abs ofs
|
|
(if list*->T (list*->T value) value))))
|
|
all-types all-offsets vals)
|
|
block)]
|
|
[else (error '_TYPE "expecting ~s values, got ~s: ~e"
|
|
(length all-types) (length vals) vals)]))
|
|
(define (TYPE->list x)
|
|
(unless (TYPE? x)
|
|
(raise-type-error 'TYPE-list struct-string x))
|
|
(map (lambda (type ofs) (ptr-ref x type 'abs ofs))
|
|
all-types all-offsets))
|
|
(define (TYPE->list* x)
|
|
(unless (TYPE? x)
|
|
(raise-type-error 'TYPE-list struct-string x))
|
|
(map (lambda (type ofs)
|
|
(let-values
|
|
([(v) (ptr-ref x type 'abs ofs)]
|
|
[(ptr tags types offsets T->list* list*->T)
|
|
(cstruct-info
|
|
type
|
|
(lambda () (values #f '() #f #f #f #f)))])
|
|
(if T->list* (T->list* v) v)))
|
|
all-types all-offsets))
|
|
(cstruct-info
|
|
_TYPE* 'set!
|
|
_TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE)
|
|
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
|
|
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
|
|
list->TYPE list*->TYPE TYPE->list TYPE->list*))))))))
|
|
(define (err what . xs)
|
|
(apply raise-syntax-error #f
|
|
(if (list? what) (apply string-append what) what)
|
|
stx xs))
|
|
(syntax-case stx ()
|
|
[(_ type ([slot slot-type] ...) . more)
|
|
(let-values ([(_TYPE _SUPER)
|
|
(syntax-case #'type ()
|
|
[(t s) (values #'t #'s)]
|
|
[_ (values #'type #f)])]
|
|
[(alignment)
|
|
(syntax-case #'more ()
|
|
[() #'#f]
|
|
[(#:alignment) (err "missing expression for #:alignment")]
|
|
[(#:alignment a) #'a]
|
|
[(#:alignment a x . _) (err "unexpected form" #'x)]
|
|
[(x . _) (err (if (keyword? (syntax-e #'x))
|
|
"unknown keyword" "unexpected form")
|
|
#'x)])])
|
|
(unless (identifier? _TYPE)
|
|
(err "bad type, expecting a _name identifier or (_name super-ctype)"
|
|
_TYPE))
|
|
(unless (regexp-match? #rx"^_." (symbol->string (syntax-e _TYPE)))
|
|
(err "cstruct name must begin with a `_'" _TYPE))
|
|
(for ([s (in-list (syntax->list #'(slot ...)))])
|
|
(unless (identifier? s)
|
|
(err "bad field name, expecting an identifier identifier" s)))
|
|
(if _SUPER
|
|
(make-syntax _TYPE #t
|
|
#`(#,(datum->syntax _TYPE 'super _TYPE) slot ...)
|
|
#`(#,_SUPER slot-type ...)
|
|
alignment)
|
|
(make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) alignment)))]
|
|
;; specific errors for bad slot specs, leave the rest for a generic error
|
|
[(_ type (bad ...) . more)
|
|
(err "bad slot specification, expecting [name ctype]"
|
|
(ormap (lambda (s) (syntax-case s () [[n ct] #t] [_ s]))
|
|
(syntax->list #'(bad ...))))]
|
|
[(_ type bad . more)
|
|
(err "bad slot specification, expecting a sequence of [name ctype]"
|
|
#'bad)]))
|
|
|
|
;; helper for the above: keep runtime information on structs
|
|
(define cstruct-info
|
|
(let ([table (make-weak-hasheq)])
|
|
(lambda (cstruct msg/fail-thunk . args)
|
|
(cond [(eq? 'set! msg/fail-thunk)
|
|
(hash-set! table cstruct (make-ephemeron cstruct args))]
|
|
[(and cstruct ; might get a #f if there were no slots
|
|
(hash-ref table cstruct (lambda () #f)))
|
|
=> (lambda (xs)
|
|
(let ([v (ephemeron-value xs)])
|
|
(if v (apply values v) (msg/fail-thunk))))]
|
|
[else (msg/fail-thunk)]))))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;;
|
|
|
|
(define prim-synonyms
|
|
#hasheq((double* . double)
|
|
(fixint . long)
|
|
(ufixint . ulong)
|
|
(fixnum . long)
|
|
(ufixnum . ulong)
|
|
(path . bytes)
|
|
(symbol . bytes)
|
|
(scheme . pointer)))
|
|
|
|
(define (ctype->layout c)
|
|
(let ([b (ctype-basetype c)])
|
|
(cond
|
|
[(ctype? b) (ctype->layout b)]
|
|
[(list? b) (map ctype->layout b)]
|
|
[(vector? b) (vector (ctype->layout (vector-ref b 0)) (vector-ref b 1))]
|
|
[else (hash-ref prim-synonyms b b)])))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Misc utilities
|
|
|
|
;; Used by set-ffi-obj! to get the actual value so it can be kept around
|
|
(define (get-lowlevel-object x type)
|
|
(let ([basetype (ctype-basetype type)])
|
|
(if (ctype? basetype)
|
|
(let ([s->c (ctype-scheme->c type)])
|
|
(get-lowlevel-object (if s->c (s->c x) x) basetype))
|
|
(values x type))))
|
|
|
|
;; Converting Scheme lists to/from C vectors (going back requires a length)
|
|
(define* (list->cblock l type [need-len #f])
|
|
(define len (length l))
|
|
(when need-len
|
|
(unless (= len need-len)
|
|
(error 'list->cblock "list does not have the expected length: ~e" l)))
|
|
(if (null? l)
|
|
#f ; null => NULL
|
|
(let ([cblock (malloc len type)])
|
|
(let loop ([l l] [i 0])
|
|
(unless (null? l)
|
|
(ptr-set! cblock type i (car l))
|
|
(loop (cdr l) (add1 i))))
|
|
cblock)))
|
|
(provide (protect-out cblock->list))
|
|
(define (cblock->list cblock type len)
|
|
(cond [(zero? len) '()]
|
|
[(cpointer? cblock)
|
|
(let loop ([i (sub1 len)] [r '()])
|
|
(if (< i 0)
|
|
r
|
|
(loop (sub1 i) (cons (ptr-ref cblock type i) r))))]
|
|
[else (error 'cblock->list
|
|
"expecting a non-void pointer, got ~s" cblock)]))
|
|
|
|
;; Converting Scheme vectors to/from C vectors
|
|
(define* (vector->cblock v type [need-len #f])
|
|
(let ([len (vector-length v)])
|
|
(when need-len
|
|
(unless (= need-len len)
|
|
(error 'vector->cblock "vector does not have the expected length: ~e" v)))
|
|
(if (zero? len)
|
|
#f ; #() => NULL
|
|
(let ([cblock (malloc len type)])
|
|
(let loop ([i 0])
|
|
(when (< i len)
|
|
(ptr-set! cblock type i (vector-ref v i))
|
|
(loop (add1 i))))
|
|
cblock))))
|
|
(provide (protect-out cblock->vector))
|
|
(define (cblock->vector cblock type len)
|
|
(cond [(zero? len) '#()]
|
|
[(cpointer? cblock)
|
|
(let ([v (make-vector len)])
|
|
(let loop ([i (sub1 len)])
|
|
(unless (< i 0)
|
|
(vector-set! v i (ptr-ref cblock type i))
|
|
(loop (sub1 i))))
|
|
v)]
|
|
[else (error 'cblock->vector
|
|
"expecting a non-void pointer, got ~s" cblock)]))
|
|
|
|
;; Useful for automatic definitions
|
|
;; If a provided regexp begins with a "^" or ends with a "$", then
|
|
;; `regexp-replace' is used, otherwise use `regexp-replace*'.
|
|
(define* (regexp-replaces x rs)
|
|
(let loop ([str (if (bytes? x) (bytes->string/utf-8 x) (format "~a" x))]
|
|
[rs rs])
|
|
(if (null? rs)
|
|
str
|
|
(loop ((if (regexp-match #rx"^\\^|\\$$"
|
|
(if (regexp? (caar rs))
|
|
(object-name (caar rs)) (caar rs)))
|
|
regexp-replace regexp-replace*)
|
|
(caar rs) str (cadar rs)) (cdr rs)))))
|
|
|
|
;; A facility for running finalizers using executors. The "stubborn" kind
|
|
;; of will executor is provided by '#%foreign, and it doesn't get GC'ed if
|
|
;; any finalizers are attached to it (while the normal kind can get GCed
|
|
;; even if a thread that is otherwise inaccessible is blocked on the executor).
|
|
;; Also it registers level-2 finalizers (which are run after non-late weak
|
|
;; boxes are cleared).
|
|
(define killer-executor (make-stubborn-will-executor))
|
|
(define killer-thread #f)
|
|
|
|
(define* (register-finalizer obj finalizer)
|
|
(unless killer-thread
|
|
(let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)])
|
|
(set! killer-thread
|
|
(parameterize ([current-custodian priviledged-custodian]
|
|
;; don't hold onto the namespace in the finalizer thread:
|
|
[current-namespace (make-base-empty-namespace)])
|
|
(thread (lambda ()
|
|
(let loop () (will-execute killer-executor) (loop))))))))
|
|
(will-register killer-executor obj finalizer))
|