Add open-place
.
This commit is contained in:
parent
46ece20b09
commit
b601f52d4f
28
collects/unstable/open-place.rkt
Normal file
28
collects/unstable/open-place.rkt
Normal file
|
@ -0,0 +1,28 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(require (for-syntax syntax/parse racket/base syntax/free-vars racket/syntax)
|
||||||
|
racket/place)
|
||||||
|
|
||||||
|
(provide open-place)
|
||||||
|
|
||||||
|
(define-syntax (open-place stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ ch:id body:expr ...)
|
||||||
|
(define b #'(let () body ...))
|
||||||
|
(define/with-syntax b* (local-expand b 'expression null))
|
||||||
|
(define/with-syntax (fvs ...) (free-vars #'b*))
|
||||||
|
(define/with-syntax (i ...) (for/list ([(v i) (in-indexed (syntax->list #'(fvs ...)))]) i))
|
||||||
|
(define/with-syntax (v p) (generate-temporaries '(v p)))
|
||||||
|
#'(let ()
|
||||||
|
(define p (place ch (let* ([v (place-channel-get ch)]
|
||||||
|
[fvs (vector-ref v i)] ...)
|
||||||
|
b*)))
|
||||||
|
(define vec (vector fvs ...))
|
||||||
|
(for ([e (in-vector vec)]
|
||||||
|
[n (in-list (syntax->list (quote-syntax (fvs ...))))])
|
||||||
|
(unless (place-message-allowed? e)
|
||||||
|
(raise-arguments-error 'open-place
|
||||||
|
"free variable values must be allowable as place messages"
|
||||||
|
(symbol->string (syntax-e n)) e)))
|
||||||
|
(place-channel-put p vec)
|
||||||
|
p)]))
|
21
collects/unstable/scribblings/open-place.scrbl
Normal file
21
collects/unstable/scribblings/open-place.scrbl
Normal file
|
@ -0,0 +1,21 @@
|
||||||
|
#lang scribble/manual
|
||||||
|
@(require scribble/eval "utils.rkt"
|
||||||
|
(for-label unstable/open-place racket/place racket/contract racket/base))
|
||||||
|
|
||||||
|
@(define the-eval (make-base-eval))
|
||||||
|
@(the-eval '(require racket/class racket/place unstable/open-place))
|
||||||
|
|
||||||
|
@title[#:tag "open-place"]{Open @racket[place] expressions}
|
||||||
|
@unstable-header[]
|
||||||
|
|
||||||
|
@defmodule[unstable/open-place]
|
||||||
|
|
||||||
|
@addition[@author+email["Sam Tobin-Hochstadt" "samth@racket-lang.org"]]
|
||||||
|
|
||||||
|
@defform[(open-place id body ...+)]{
|
||||||
|
|
||||||
|
Like @racket[(place id body ...)], but @racket[body ...] may have free lexical
|
||||||
|
variables, which are automatically sent to the newly-created @tech{place}.
|
||||||
|
Note that these variables must have values accepted by
|
||||||
|
@racket[place-message-allowed?], otherwise an @[exn:fail:contract] is raised.
|
||||||
|
}
|
|
@ -93,6 +93,7 @@ Keep documentation and tests up to date.
|
||||||
@include-section["logging.scrbl"]
|
@include-section["logging.scrbl"]
|
||||||
@include-section["markparam.scrbl"]
|
@include-section["markparam.scrbl"]
|
||||||
@include-section["match.scrbl"]
|
@include-section["match.scrbl"]
|
||||||
|
@include-section["open-place.scrbl"]
|
||||||
@include-section["parameter-group.scrbl"]
|
@include-section["parameter-group.scrbl"]
|
||||||
@include-section["pretty.scrbl"]
|
@include-section["pretty.scrbl"]
|
||||||
@include-section["recontract.scrbl"]
|
@include-section["recontract.scrbl"]
|
||||||
|
|
Loading…
Reference in New Issue
Block a user