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

Fix 'place's handling of the result of resolved-module-path-name

Browse Source 
Plus minor cleanups:
 - fixed indentation
 - removed useless gen-create-place function
 - avoid using the guard position of syntax-case
 - drop useless datum->syntax call (it returns syntax
      objects unmodified and generate-temporary
      returns a syntax object)
 - "interal" => "internal"
 - minimized the generated code (move into a function call)
 - check to make sure constructed lambda expression is well-formed
 - check to make sure 'place' is used inside a module (or else
   several other things it use will fail)
This commit is contained in:
Robby Findler 2011-08-30 14:31:46 -05:00
parent b706fc1ebc
commit 0fbed43a26
1 changed files with 23 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
collects/racket/place.rkt
View File

@ -143,19 +143,27 @@
(syntax-case stx ()
[(_ a ...) b ...])))
(define-for-syntax (gen-create-place stx)
(syntax-case stx ()
[(_ ch body ...)
(unless (identifier? #'ch)
(raise-syntax-error #f "expected an indentifier" stx #'ch))
(with-syntax ([interal-def-name
(syntax-local-lift-expression #'(lambda (ch) body ...))]
[funcname (datum->syntax stx (generate-temporary #'place/anon))])
(syntax-local-lift-provide #'(rename interal-def-name funcname))
#'(let ([module-path (resolved-module-path-name
(variable-reference->resolved-module-path
(#%variable-reference)))])
(dynamic-place module-path (quote funcname))))]))
(define-syntax (place stx)
(gen-create-place stx))
(syntax-case stx ()
[(_ ch body1 body ...)
(begin
(unless (eq? 'module (syntax-local-context))
(raise-syntax-error #f "can only be used in a module" stx))
(unless (identifier? #'ch)
(raise-syntax-error #f "expected an indentifier" stx #'ch))
(with-syntax ([internal-def-name
(syntax-local-lift-expression #'(lambda (ch) body1 body ...))]
[func-name (generate-temporary #'place/anon)])
(syntax-local-lift-provide #'(rename internal-def-name func-name))
#'(place/proc (#%variable-reference) 'func-name)))]
[(_ ch)
(raise-syntax-error #f "expected at least one body expression" stx)]))
(define (place/proc vr func-name)
(define name
(resolved-module-path-name
(variable-reference->resolved-module-path
vr)))
(dynamic-place (if (symbol? name) `',name name)
func-name))