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