suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

rename holder -> keep

Browse Source 
svn: r11932
This commit is contained in:
Eli Barzilay 2008-10-04 19:10:38 +00:00
parent 2886a95318
commit 8d06e0c707
8 changed files with 31 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/mzlib/foreign.ss
View File

@ -468,22 +468,22 @@
;; 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] #:holder [holder #f])
(_cprocedure* itypes otype abi wrapper holder))
#:abi [abi #f] #:wrapper [wrapper #f] #:keep [keep #f])
(_cprocedure* itypes otype abi wrapper keep))
;; for internal use
(define held-callbacks (make-weak-hasheq))
(define (_cprocedure* itypes otype abi wrapper holder)
(define (_cprocedure* itypes otype abi wrapper keep)
(define-syntax-rule (make-it wrap)
(make-ctype _fpointer
(lambda (x)
(let ([cb (ffi-callback (wrap x) itypes otype abi)])
(cond [(eq? holder #t) (hash-set! held-callbacks x cb)]
[(box? holder)
(let ([x (unbox holder)])
(set-box! holder
(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? holder) (holder cb)])
[(procedure? keep) (keep cb)])
cb))
(lambda (x) (wrap (ffi-call x itypes otype abi)))))
(if wrapper (make-it wrapper) (make-it begin)))
@ -512,7 +512,7 @@
(define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
(define xs #f)
(define abi #f)
(define holder #f)
(define keep #f)
(define inputs #f)
(define output #f)
(define bind '())
@ -577,9 +577,9 @@
(begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
...
[else (err "unknown keyword" (car xs))]))
(when (keyword? k) (kwds [#:abi abi] [#:holder holder]))))
(unless abi (set! abi #'#f))
(unless holder (set! holder #'#t))
(when (keyword? k) (kwds [#:abi abi] [#:keep keep]))))
(unless abi (set! abi #'#f))
(unless keep (set! keep #'#t))
;; parse known punctuation
(set! xs (map (lambda (x)
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
@ -670,9 +670,9 @@
(string->symbol (string-append "ffi-wrapper:" n)))
body))])
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
#,abi (lambda (ffi) #,body) #,holder))
#,abi (lambda (ffi) #,body) #,keep))
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
#,abi #f #,holder)))
#,abi #f #,keep)))
(syntax-case stx ()
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))

20
collects/scribblings/foreign/types.scrbl
View File

@ -271,9 +271,8 @@ Otherwise, @scheme[_cprocedure] should be used (it is based on
[#:wrapper wrapper (or/c false/c
(procedure? . -> . procedure?))
#f]
[#:holder holder (or/c boolean? box?
(any/c . -> . any/c))
#t])
[#:keep keep (or/c boolean? box? (any/c . -> . any/c))
#t])
any]{
A type constructor that creates a new function type, which is
@ -316,10 +315,9 @@ translating them to a foreign ``closure'', which foreign code can call
as plain C functions. Additional care must be taken in case the
foreign code might hold on to the callback function. In these cases
you must arrange for the callback value to not be garbage-collected,
or the held callback will become invalid. The optional
@scheme[holder] keyword argument is used to achieve this. It can have
the following values:
@itemize[
or the held callback will become invalid. The optional @scheme[keep]
keyword argument is used to achieve this. It can have the following
values: @itemize[
@item{@scheme[#t] makes the callback value stay in memory as long as
the converted function is. In order to use this, you need to hold
@ -355,8 +353,8 @@ the following values:
when a Scheme function is used in multiple callbacks (that is, sent
to foreign code to hold onto multiple times).}
@item{Finally, if a one-argument function is provided as the
@scheme[holder], it will be invoked with the callback value when it
@item{Finally, if a one-argument function is provided as
@scheme[keep], it will be invoked with the callback value when it
is generated. This allows you to grab the value directly and use it
in any way.}
@ -365,8 +363,8 @@ the following values:
@defform/subs[#:literals (-> :: :)
(_fun fun-option ... maybe-args type-spec ... -> type-spec
maybe-wrapper)
([fun-option (code:line #:abi abi-expr)
(code:line #:holder holder-expr)]
([fun-option (code:line #:abi abi-expr)
(code:line #:keep keep-expr)]
[maybe-args code:blank
(code:line (id ...) ::)
(code:line id ::)

10
collects/tests/mzscheme/foreign-test.ss
View File

@ -141,17 +141,17 @@
(t '(255 1) 'charint_swap (_fun _charint -> _charint) '(1 255)))
;; ---
;; test sending a callback for C to hold, preventing the callback from GCing
(let ([with-holder
(lambda (h)
(let ([with-keeper
(lambda (k)
(t (void) 'grab_callback
(_fun (_fun #:holder h _int -> _int) -> _void) sqr)
(_fun (_fun #:keep k _int -> _int) -> _void) sqr)
(t 9 'use_grabbed_callback (_fun _int -> _int) 3)
(collect-garbage) ; make sure it survives a GC
(t 25 'use_grabbed_callback (_fun _int -> _int) 5)
(collect-garbage)
(t 81 'use_grabbed_callback (_fun _int -> _int) 9))])
(with-holder #t)
(with-holder (box #f)))
(with-kepper #t)
(with-keeper (box #f)))
;; ---
;; test exposing internal mzscheme functionality
(test '(1 2)

2
collects/typed-scheme/private/type-effect-printer.ss
View File

@ -2,7 +2,7 @@
(require "../utils/utils.ss")
(require (rep type-rep effect-rep rep-utils)
(utils planet-requires tc-utils)
(utils tc-utils)
scheme/match)
;; do we attempt to find instantiations of polymorphic types to print?

1
collects/typed-scheme/rep/rep-utils.ss
View File

@ -4,7 +4,6 @@
(require mzlib/struct
mzlib/plt-match
syntax/boundmap
(utils planet-requires)
"free-variance.ss"
"interning.ss"
mzlib/etc

2
collects/typed-scheme/rep/type-rep.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (utils planet-requires tc-utils)
(require (utils tc-utils)
"rep-utils.ss" "effect-rep.ss" "free-variance.ss"
mzlib/trace scheme/match
(for-syntax scheme/base))

3
collects/typed-scheme/typecheck/tc-if-unit.ss
View File

@ -1,8 +1,7 @@
#lang scheme/unit
(require (rename-in "../utils/utils.ss" [infer r:infer]))
(require (utils planet-requires)
"signatures.ss"
(require "signatures.ss"
(rep type-rep effect-rep)
(private type-effect-convenience subtype union type-utils type-comparison mutated-vars)
(env lexical-env)

71
collects/typed-scheme/utils/planet-requires.ss
View File

@ -1,71 +0,0 @@
#lang scheme/base
(require (for-syntax scheme/base scheme/require-transform)
scheme/require-syntax)
(define-for-syntax (splice-requires specs)
(define subs (map (compose cons expand-import) specs))
(values (apply append (map car subs)) (apply append (map cdr subs))))
(define-syntax define-module
(syntax-rules ()
[(_ nm spec ...)
(define-syntax nm
(make-require-transformer
(lambda (stx)
(splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...)))))
#;
(define-require-syntax nm
(lambda (stx)
(syntax-case stx ()
[(_) (datum->syntax stx (syntax->datum #'(combine-in spec ...)))])))]))
#;
(define-syntax define-module
(lambda (stx)
(syntax-case stx ()
[(_ nm spec ...)
(syntax/loc stx
(define-syntax nm
(make-require-transformer
(lambda (stx)
(splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...))))))])))
(define-syntax planet/multiple
(make-require-transformer
(lambda (stx)
(syntax-case stx ()
[(_ plt files ...)
(let ([mk (lambda (spc)
(syntax-case spc (prefix-in)
[e
(string? (syntax-e #'e))
(datum->syntax spc `(planet ,#'e ,#'plt) spc)]
[(prefix-in p e)
(datum->syntax spc `(prefix-in ,#'p (planet ,#'e ,#'plt)) spc)]))])
(splice-requires (map mk (syntax->list #'(files ...)))))]))))
(provide galore schemeunit)
;; why is this neccessary?
(provide planet/multiple)
(define-module galore
(prefix-in table: "tables.ss"))
(require (galore))
(void (table:alist->eq '()))
(define-module schemeunit
(planet/multiple ("schematics" "schemeunit.plt" 2 3)
"test.ss"
;"graphical-ui.ss"
"text-ui.ss"
"util.ss")
;; disabled until Carl updates to v4
#;
(planet/multiple ("cce" "fasttest.plt" 1 2)
"random.ss"
"schemeunit.ss"))