92 lines
3.7 KiB
Racket
92 lines
3.7 KiB
Racket
#lang racket/base
|
|
(require (for-syntax scheme/base))
|
|
|
|
(define-syntax-rule (provide-except-unsafe (ulib ...) u! id ...)
|
|
(begin
|
|
(require ulib ...)
|
|
(provide (except-out (all-from-out ulib ...) id ...))
|
|
(define-syntax (u! stx)
|
|
(syntax-case stx ()
|
|
[(_) (with-syntax ([lib+ids (datum->syntax stx `((,#'combine-in ulib ...) id ...))])
|
|
#'(require (only-in . lib+ids)))]))))
|
|
|
|
(provide-except-unsafe (ffi/unsafe ffi/unsafe/cvector ffi/vector) unsafe!
|
|
|
|
free end-stubborn-change
|
|
ptr-ref ptr-set! cast
|
|
make-sized-byte-string
|
|
memcpy memmove memset
|
|
malloc-immobile-cell free-immobile-cell
|
|
malloc
|
|
ffi-lib
|
|
ffi-obj-ref
|
|
get-ffi-obj
|
|
set-ffi-obj!
|
|
make-c-parameter
|
|
define-c
|
|
define-fun-syntax
|
|
make-cvector*
|
|
cpointer-tag set-cpointer-tag!
|
|
cpointer-has-tag? cpointer-push-tag!
|
|
cblock->list
|
|
cblock->vector)
|
|
|
|
(provide provide* define-unsafer
|
|
unsafe!)
|
|
|
|
;; This module is full of unsafe bindings that are not provided to requiring
|
|
;; modules. Instead, an `unsafe!' binding is provided that makes these unsafe
|
|
;; bindings available. The following two syntaxes do that: `provide*' is like
|
|
;; `provide', but using `(unsafe id)' registers an unsafe binding. Then,
|
|
;; `define-unsafer' should be used with a binding that will expose the unsafe
|
|
;; bindings. This might move elsewhere at some point if it turns out to be
|
|
;; useful in other contexts.
|
|
(provide provide* define-unsafer)
|
|
(define-syntaxes (provide* define-unsafer)
|
|
(let ((unsafe-bindings '()))
|
|
(values
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ p ...)
|
|
(let loop ([provides '()]
|
|
[unsafes '()]
|
|
[ps (syntax->list #'(p ...))])
|
|
(if (null? ps)
|
|
(begin (set! unsafe-bindings
|
|
(append unsafe-bindings (reverse unsafes)))
|
|
(with-syntax ([(p ...) provides]) #'(provide p ...)))
|
|
(syntax-case (car ps) (unsafe)
|
|
[(unsafe u)
|
|
(syntax-case #'u (rename-out)
|
|
[(rename-out [from to])
|
|
(loop provides (cons (cons #'from #'to) unsafes) (cdr ps))]
|
|
[id (identifier? #'id)
|
|
(loop provides (cons (cons #'id #'id) unsafes) (cdr ps))]
|
|
[_
|
|
(raise-syntax-error 'provide* "bad unsafe usage"
|
|
(car ps) stx)])]
|
|
[_ (loop (cons (car ps) provides) unsafes (cdr ps))])))]))
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ unsafe)
|
|
(with-syntax ([(from ...) (map car unsafe-bindings)]
|
|
[(to ...) (map cdr unsafe-bindings)]
|
|
[(id ...) (generate-temporaries unsafe-bindings)])
|
|
(set! unsafe-bindings '())
|
|
#'(begin
|
|
(provide (protect-out unsafe))
|
|
(define-syntax (unsafe stx)
|
|
(syntax-case stx ()
|
|
[(_) (with-syntax ([(id ...) (list (datum->syntax
|
|
stx 'to stx)
|
|
...)])
|
|
#'(begin (define-syntax id
|
|
(make-rename-transformer (syntax-property
|
|
(syntax-property
|
|
#'from
|
|
'not-provide-all-defined
|
|
#t)
|
|
'nominal-id
|
|
'to)))
|
|
...))]))))])))))
|