1#lang racket/base 2(require (prefix-in pl- '#%place) 3 racket/match 4 racket/place/dynamic 5 (only-in "private/place.rkt" 6 start-place 7 start-place*) 8 (for-syntax racket/base 9 racket/syntax 10 syntax/parse 11 syntax/free-vars)) 12 13(provide (all-from-out racket/place/dynamic) 14 (protect-out place place*) 15 place/context) 16 17 18(define-for-syntax place-body-counter 0) 19 20(define-for-syntax (place-form _in _out _err _start-place-func stx orig-stx) 21 (syntax-case stx () 22 [(who ch body1 body ...) 23 (if (eq? (syntax-local-context) 'module-begin) 24 ;; when a `place' form is the only thing in a module body: 25 #`(begin #,stx) 26 ;; normal case: 27 (let () 28 (unless (syntax-transforming-module-expression?) 29 (raise-syntax-error #f "can only be used in a module" stx)) 30 (unless (identifier? #'ch) 31 (raise-syntax-error #f "expected an identifier" stx #'ch)) 32 (set! place-body-counter (add1 place-body-counter)) 33 (define module-name-stx 34 (datum->syntax stx 35 (string->symbol 36 (format "place-body-~a" place-body-counter)))) 37 (with-syntax ([internal-def-name 38 (syntax-local-lift-module 39 #`(module* #,module-name-stx #f 40 (provide main) 41 (define (main ch) 42 body1 body ...) 43 ;; The existence of this submodule makes the 44 ;; enclosing submodule preserved by `raco exe`: 45 (module declare-preserve-for-embedding '#%kernel)))] 46 [in _in] 47 [out _out] 48 [err _err] 49 [start-place-func _start-place-func]) 50 #`(place/proc (#%variable-reference) '#,module-name-stx 'who start-place-func in out err))))] 51 [(_ ch) 52 (raise-syntax-error #f "expected at least one body expression" orig-stx)])) 53 54(define-syntax (place stx) 55 (place-form #'#f #'(current-output-port) #'(current-error-port) #'start-place stx stx)) 56 57(define-syntax (place* stx) 58 (syntax-case stx () 59 [(pf #:in in #:out out #:err err ch body ...) (place-form #'in #'out #'err #'start-place* #'(pf ch body ...) stx)] 60 [(pf #:in in #:out out ch body ...) (place-form #'in #'out #'#f #'start-place* #'(pf ch body ...) stx)] 61 [(pf #:out out #:err err ch body ...) (place-form #'#f #'out #'err #'start-place* #'(pf ch body ...) stx)] 62 [(pf #:in in #:err err ch body ...) (place-form #'in #'#f #'err #'start-place* #'(pf ch body ...) stx)] 63 [(pf #:in in ch body ...) (place-form #'in #'#f #'#f #'start-place* #'(pf ch body ...) stx)] 64 [(pf #:out out ch body ...) (place-form #'#f #'out #'#f #'start-place* #'(pf ch body ...) stx)] 65 [(pf #:err err ch body ...) (place-form #'#f #'#f #'err #'start-place* #'(pf ch body ...) stx)] 66 [(pf ch body ...) (place-form #'#f #'#f #'#f #'start-place* #'(pf ch body ...) stx)])) 67 68(define (place/proc vr submod-name who start-place-func in out err) 69 (define name 70 (resolved-module-path-name 71 (variable-reference->resolved-module-path 72 vr))) 73 (when (and (symbol? name) 74 (not (module-predefined? `(quote ,name)))) 75 (error who "the enclosing module's resolved name is not a path or predefined")) 76 (define submod-ref 77 (match name 78 [(? symbol?) `(submod (quote ,name) ,submod-name)] 79 [(? path?) `(submod ,name ,submod-name)] 80 [`(,p ,s ...) `(submod ,(if (symbol? p) `(quote ,p) p) ,@s ,submod-name)])) 81 (start-place-func who submod-ref 'main in out err)) 82 83(define-syntax (place/context stx) 84 (syntax-parse stx 85 [(_ ch:id body:expr ...) 86 (define b #'(lambda (ch) body ...)) 87 (define/with-syntax b* (local-expand b 'expression null)) 88 (define/with-syntax (fvs ...) (free-vars #'b*)) 89 (define/with-syntax (i ...) (for/list ([(v i) (in-indexed (syntax->list #'(fvs ...)))]) i)) 90 (define/with-syntax (v p) (generate-temporaries '(v p))) 91 #'(let () 92 (define p (place ch (let* ([v (place-channel-get ch)] 93 [fvs (vector-ref v i)] ...) 94 (b* ch)))) 95 (define vec (vector fvs ...)) 96 (for ([e (in-vector vec)] 97 [n (in-list (syntax->list (quote-syntax (fvs ...))))]) 98 (unless (place-message-allowed? e) 99 (raise-arguments-error 'place/context 100 "free variable values must be allowable as place messages" 101 (symbol->string (syntax-e n)) e))) 102 (place-channel-put p vec) 103 p)])) 104