diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 4353030192..be4163e98b 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -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))])) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 664a17b4c8..d8003bbcbd 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -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 ::) diff --git a/collects/tests/mzscheme/foreign-test.ss b/collects/tests/mzscheme/foreign-test.ss index 1cce9a4ba2..9e8913921a 100644 --- a/collects/tests/mzscheme/foreign-test.ss +++ b/collects/tests/mzscheme/foreign-test.ss @@ -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) diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss index 812f58a684..6b29c7c6da 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/private/type-effect-printer.ss @@ -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? diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 2f49dba9f6..8e4124b37e 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -4,7 +4,6 @@ (require mzlib/struct mzlib/plt-match syntax/boundmap - (utils planet-requires) "free-variance.ss" "interning.ss" mzlib/etc diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 6e744cfa52..5536a84417 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -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)) diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss index e1d75c236c..bbae72978d 100644 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ b/collects/typed-scheme/typecheck/tc-if-unit.ss @@ -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) diff --git a/collects/typed-scheme/utils/planet-requires.ss b/collects/typed-scheme/utils/planet-requires.ss deleted file mode 100644 index eb6f7b26e7..0000000000 --- a/collects/typed-scheme/utils/planet-requires.ss +++ /dev/null @@ -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"))