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

[honu] fix the pattern form and use quote-syntax to prevent syntaxes from being interpolated too early

Browse Source
This commit is contained in:
Jon Rafkind 2012-06-02 00:53:22 -06:00
parent 2b5e5c5b57
commit 244f1cccb7
3 changed files with 173 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/honu/core/private/compile.rkt
View File

@ -116,8 +116,9 @@
(define-syntax (racket-syntax stx) (define-syntax (racket-syntax stx)
(syntax-case stx () (syntax-case stx ()
[(_ form) [(_ form)
(debug 2 "Racket syntax ~a\n" #'form) (begin
#'(parsed-syntax #'form)])) (debug 2 "Racket syntax ~a\n" (syntax->datum #'form))
#'(parsed-syntax #'form))]))
(begin-for-syntax (begin-for-syntax
(provide compress-dollars) (provide compress-dollars)

267
collects/honu/core/private/macro2.rkt
View File

@ -17,6 +17,7 @@
macro-debugger/emit macro-debugger/emit
racket/syntax racket/syntax
racket/set racket/set
racket/pretty
"literals.rkt" "literals.rkt"
"debug.rkt" "debug.rkt"
(prefix-in phase2: "parse2.rkt") (prefix-in phase2: "parse2.rkt")
@ -41,14 +42,17 @@
syntax/parse)) syntax/parse))
(provide (all-defined-out)) (provide (all-defined-out))
(struct pattern-variable [name depth class] #:transparent) (struct pattern-variable [name original depth class] #:transparent)
;; makes a syntax object with the right number of nested ellipses patterns ;; makes a syntax object with the right number of nested ellipses patterns
(define (pattern-variable->syntax variable) (define (pattern-variable->syntax variable)
(debug 2 "Convert pattern variable to syntax ~a location ~a\n" variable (pattern-variable-original variable))
(define location (pattern-variable-original variable))
(for/fold ([out (pattern-variable-name variable)]) (for/fold ([out (pattern-variable-name variable)])
([depth (pattern-variable-depth variable)]) ([depth (pattern-variable-depth variable)])
(with-syntax ([out out]) (with-syntax ([out out]
#'(out (... ...))))) [ellipses (syntax/loc location (... ...))])
(syntax/loc location (out ellipses)))))
(define (convert-pattern original-pattern new-names) (define (convert-pattern original-pattern new-names)
(define-splicing-syntax-class pattern-type (define-splicing-syntax-class pattern-type
@ -72,17 +76,18 @@
(define (find-pattern-variables original-pattern) (define (find-pattern-variables original-pattern)
(define (reverse-syntax input) (define (reverse-syntax input)
(syntax-parse input (syntax-parse input
[(x ...) (datum->syntax #'(x ...) [(x ...) (datum->syntax input
(reverse (for/list ([x (syntax->list #'(x ...))]) (reverse (for/list ([x (syntax->list #'(x ...))])
(reverse-syntax x))) (reverse-syntax x)))
#'(x ...) #'(x ...))] input input)]
[x #'x])) [x #'x]))
(define (merge set1 set2) (define (merge set1 set2)
(debug "Merge ~a with ~a\n" set1 set2) (debug 2 "Merge ~a with ~a\n" set1 set2)
(set-union set1 set2)) (set-union set1 set2))
(define (wrap-ellipses stuff) (define (wrap-ellipses stuff)
(for/set ([variable stuff]) (for/set ([variable stuff])
(pattern-variable (pattern-variable-name variable) (pattern-variable (pattern-variable-name variable)
(pattern-variable-original variable)
(add1 (pattern-variable-depth variable)) (add1 (pattern-variable-depth variable))
(pattern-variable-class variable)))) (pattern-variable-class variable))))
#; #;
@ -93,32 +98,32 @@
#'((name (... ...)) #'((name (... ...))
(result (... ...)))]))) (result (... ...)))])))
(define (find the-pattern) (define (find the-pattern)
(debug "Find in ~a\n" (syntax->datum the-pattern)) (debug 2 "Find in ~a\n" (syntax->datum the-pattern))
(define-splicing-syntax-class maybe (define-splicing-syntax-class maybe
#:literal-sets (cruft) #:literal-sets (cruft)
#:literals ([ellipses ...]) #:literals ([ellipses ...])
[pattern (~seq class:id colon name:id) [pattern (~seq class:id colon name:id)
#:attr result #:attr result
(with-syntax ([name.result (format-id #'name "~a_result" #'name)]) (with-syntax ([name.result (format-id #'name "~a_result" #'name)])
(set (pattern-variable #'name 0 #'class)))] (set (pattern-variable #'name #'class 0 #'class)))]
[pattern (~seq ellipses thing:maybe rest ...) [pattern (~seq ellipses thing:maybe rest ...)
#:attr result #:attr result
(merge (wrap-ellipses (attribute thing.result)) (merge (wrap-ellipses (attribute thing.result))
(find #'(rest ...)))] (find #'(rest ...)))]
[pattern (x:maybe ...) #:attr result (apply set-union (attribute x.result))] [pattern (x:maybe ...) #:attr result (apply set-union (attribute x.result))]
[pattern x #:attr result (set)]) [pattern x #:attr result (set)])
(syntax-parse the-pattern (syntax-parse the-pattern
#:literals ([ellipses ...]) #:literals ([ellipses ...])
[(ellipses thing:maybe rest ...) [(ellipses thing:maybe rest ...)
(debug "Ellipses case\n") (debug 2 "Ellipses case\n")
(merge (wrap-ellipses (attribute thing.result)) (merge (wrap-ellipses (attribute thing.result))
(find #'(rest ...)))] (find #'(rest ...)))]
[(thing:maybe rest ...) [(thing:maybe rest ...)
(debug "Normal list case ~a\n" (attribute thing.result)) (debug 2 "Normal list case ~a\n" (attribute thing.result))
(merge (attribute thing.result) (find #'(rest ...)))] (merge (attribute thing.result) (find #'(rest ...)))]
[thing (set)])) [thing (set)]))
(define variables (find (reverse-syntax original-pattern))) (define variables (find (reverse-syntax original-pattern)))
(debug "Found variables ~a\n" variables) (debug 2 "Found variables ~a\n" variables)
(for/list ([x variables]) x)) (for/list ([x variables]) x))
) )
@ -137,56 +142,63 @@
(define-syntax (create-honu-macro stx) (define-syntax (create-honu-macro stx)
(syntax-parse stx (syntax-parse stx
[(_ name (literal ...) (pattern ...) (action ...)) [(_ name (literal ...) (pattern ...) (action ...))
(debug "Name is ~a\n" #'name) (debug 2 "Name is ~a\n" #'name)
(define pattern-variables (find-pattern-variables #'(pattern ...))) (define pattern-variables (find-pattern-variables #'(pattern ...)))
;; only need a 1-to-1 mapping here ;; only need a 1-to-1 mapping here
(define mapping (make-hash)) (define mapping (make-hash))
(for ([variable pattern-variables]) (for ([variable pattern-variables])
(debug "Update mapping for ~a\n" (pattern-variable-name variable)) (debug 2 "Update mapping for ~a\n" (pattern-variable-name variable))
(hash-set! mapping (syntax-e (pattern-variable-name variable)) (hash-set! mapping (syntax-e (pattern-variable-name variable))
variable)) variable))
(debug "Create pattern\n") (debug 2 "Create pattern\n")
(with-syntax ([(syntax-parse-pattern ...) (with-syntax ([(syntax-parse-pattern ...)
(convert-pattern #'(pattern ...) mapping)] (convert-pattern #'(pattern ...) mapping)]
[((pattern-variable.name pattern-variable.result) ...) [((pattern-variable.name pattern-variable.result) ...)
(for/list ([name pattern-variables]) (for/list ([name pattern-variables])
(debug "Create new pattern variable from ~a\n" name) (debug 2 "Create new pattern variable from ~a\n" name)
(with-syntax ([name (pattern-variable->syntax name)] (with-syntax ([name (pattern-variable->syntax name)]
[name.result (pattern-variable->syntax [name.result (pattern-variable->syntax
(pattern-variable (format-id (pattern-variable-name name) (pattern-variable (format-id (pattern-variable-name name)
"~a_result" "~a_result"
(pattern-variable-name name)) (pattern-variable-name name))
(pattern-variable-original name)
(pattern-variable-depth name) (pattern-variable-depth name)
(pattern-variable-class name) (pattern-variable-class name)
))]) ))])
#'(name name.result)))]) #'(name name.result)))])
(debug "Done with syntax\n")
(syntax (phase1:racket-syntax (define output
(lambda (stx context-name) (syntax (quote-syntax
(define-literal-set local-literals (literal ...)) (lambda (stx context-name)
(syntax-parse stx (define-literal-set local-literals (literal ...))
#:literal-sets ([cruft #:at name] (syntax-parse stx
[local-literals #:at name]) #:literal-sets ([cruft #:at name]
[(_ syntax-parse-pattern ... . more) [local-literals #:at name])
(values [(_ syntax-parse-pattern ... . more)
;; if the pattern is x:expression then x_result will (values
;; hold the parsed version of x, so we rebind x to ;; if the pattern is x:expression then x_result will
;; x_result so you can use just x in the template ;; hold the parsed version of x, so we rebind x to
;; instead of x_result. x_result is still there, too ;; x_result so you can use just x in the template
(with-syntax ([pattern-variable.name #'pattern-variable.result] ;; instead of x_result. x_result is still there, too
...) (with-syntax ([pattern-variable.name #'pattern-variable.result]
(debug "~a = ~a\n" 'pattern-variable.name (syntax->datum #'pattern-variable.name)) ... ...)
(parse-stuff action ...)) (debug "~a = ~a\n" 'pattern-variable.name (syntax->datum #'pattern-variable.name)) ...
#'more #t)] (parse-stuff action ...))
[else (raise-syntax-error #f "Could not match macro" stx)])))))])) #'more #t)]
[else (raise-syntax-error #f "Could not match macro" stx)])))))
(debug "Create macro: ~a\n" (pretty-format (syntax->datum output)))
output)]))
) )
(provide honu-macro) (provide honu-macro)
(define-honu-syntax honu-macro (define-honu-syntax honu-macro
(lambda (code context) (lambda (code context)
(syntax-parse code #:literal-sets (cruft) (syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens literal ...) (#%braces pattern ...) (#%braces action ...) . rest) [(_ name
(#%parens literal ...)
(#%braces pattern ...)
(#%braces action ...) . rest)
(values (phase1:racket-syntax (values (phase1:racket-syntax
;; trampoline to phase 1 ;; trampoline to phase 1
(splicing-let-syntax ([make (lambda (stx) (splicing-let-syntax ([make (lambda (stx)
@ -199,6 +211,7 @@
(action ...))) (action ...)))
(debug "Output from create macro ~a\n" output) (debug "Output from create macro ~a\n" output)
(with-syntax ([output output]) (with-syntax ([output output])
(debug "Output is ~a\n" #'output)
#'(define-honu-syntax new-name output))]))]) #'(define-honu-syntax new-name output))]))])
(make name))) (make name)))
#'rest #'rest
@ -268,17 +281,37 @@
[(syntax2* ...) #'something2]) [(syntax2* ...) #'something2])
#'(%racket (unexpand (syntax1* ... syntax2* ...))))])])) #'(%racket (unexpand (syntax1* ... syntax2* ...))))])]))
(begin-for-syntax
(define-for-syntax (pretty-syntax stx) (pretty-format (syntax->datum stx))))
;; honu-pattern should expand to ;; honu-pattern should expand to
;; (define-syntax honu-pattern ...) ;; (define-syntax honu-pattern ...)
(require (for-syntax (submod "." analysis)))
(require (for-meta 2 "util.rkt"
racket/match
(prefix-in syntax: syntax/parse/private/residual-ct))
(for-meta 3 racket/base syntax/parse racket/syntax)
)
;; creates a new syntax/parse pattern ;; creates a new syntax/parse pattern
(provide honu-pattern) (provide honu-pattern)
(define-honu-syntax honu-pattern (lambda (code context) #'f))
#; (begin-for-syntax
(define-honu-syntax honu-pattern (define-syntax (generate-pattern stx)
(lambda (code context)
(define (generate-pattern name literals original-pattern maybe-out) ;; given the name of an object and some fields this macro defines
(define variables (find-pattern-variables original-pattern)) ;; name.field for each of the fields
(define-syntax (define-struct-fields stx)
(syntax-parse stx
[(_ name type (field ...))
(with-syntax ([(field* ...)
(for/list ([field (syntax->list #'(field ...))])
(format-id field "~a.~a" (syntax-e #'name) (syntax-e field)))])
#'(match-define (struct type (field* ...)) name))]))
(syntax-parse stx
[(_ name literals original-pattern maybe-out)
(define variables (find-pattern-variables #'original-pattern))
(define use (generate-temporaries variables)) (define use (generate-temporaries variables))
(define mapping (make-hash)) (define mapping (make-hash))
(for ([old variables] (for ([old variables]
@ -287,6 +320,7 @@
(hash-set! mapping (hash-set! mapping
(syntax-e (pattern-variable-name old)) (syntax-e (pattern-variable-name old))
(pattern-variable new (pattern-variable new
(pattern-variable-original old)
(pattern-variable-depth old) (pattern-variable-depth old)
(pattern-variable-class old)))) (pattern-variable-class old))))
@ -300,78 +334,115 @@
;; foo_a temp_a ;; foo_a temp_a
;; (foo_b ...) (temp_b ...) ;; (foo_b ...) (temp_b ...)
(define (bind-attributes variable new-name) (define (bind-attributes variable new-name)
(debug "Syntax class of ~a is ~a at ~a\n" (pattern-variable-class variable) (debug "Syntax class of ~a is ~a at ~a\n"
(pattern-variable-class variable)
(syntax-local-value (pattern-variable-class variable) (lambda () #f)) (syntax-local-value (pattern-variable-class variable) (lambda () #f))
(syntax-local-phase-level)) (syntax-local-phase-level))
(define attributes (define attributes
(let ([syntax-class (syntax-local-value (pattern-variable-class variable))]) (let ([syntax-class (syntax-local-value (pattern-variable-class variable))])
(for/list ([attribute (syntax:stxclass-attrs syntax-class)]) (for/list ([attribute (syntax:stxclass-attrs syntax-class)])
(pattern-variable (syntax:attr-name attribute) (pattern-variable (syntax:attr-name attribute)
(pattern-variable-original variable)
(+ (pattern-variable-depth variable) (+ (pattern-variable-depth variable)
(syntax:attr-depth attribute)) (syntax:attr-depth attribute))
#f)))) #f))))
(for/set ([attribute attributes])
(define (mirror-attribute attribute)
(debug "Mirror attribute ~a\n" attribute)
;; create a new pattern variable with a syntax object that uses
;; the given lexical context and whose name is prefix_suffix
(define-struct-fields attribute pattern-variable
(name original depth class))
(define (create lexical prefix suffix)
(pattern-variable->syntax
(pattern-variable (format-id lexical "~a_~a" prefix suffix)
attribute.original attribute.depth attribute.class)))
(define-struct-fields variable pattern-variable
(name original depth class))
(debug "Bind attributes ~a ~a\n" variable.name attribute.name)
(with-syntax ([bind-attribute (with-syntax ([bind-attribute
(let ([name (pattern-variable-name attribute)]) #;
(pattern-variable->syntax (create name (syntax-e name) name)
(pattern-variable (format-id (pattern-variable-name variable) "~a_~a" (pattern-variable->syntax
(syntax-e (pattern-variable-name variable)) (pattern-variable (format-id variable.name "~a_~a"
name) (syntax-e variable.name)
(pattern-variable-depth attribute) attribute.name)
(pattern-variable-class attribute))))] attribute.original
[new-attribute (pattern-variable->syntax attribute.depth
attribute.class))]
[new-attribute
#;
(create new-name new-name name)
(pattern-variable->syntax
(pattern-variable (pattern-variable
(format-id new-name "~a_~a" new-name (pattern-variable-name attribute)) (format-id new-name "~a_~a"
(pattern-variable-depth attribute) new-name
#f))]) attribute.name)
#'(#:with bind-attribute #'new-attribute)))) attribute.original attribute.depth #f))])
(debug "Bind ~a to ~a\n" #'bind-attribute #'new-attribute)
#'(#:with bind-attribute #'new-attribute)))
(for/set ([attribute attributes])
(mirror-attribute attribute)))
(define withs (define withs
(for/union ([old variables] (for/union ([old variables]
[new use]) [new use])
(define-struct-fields old pattern-variable (name original depth class))
(with-syntax ([old-syntax (pattern-variable->syntax old)] (with-syntax ([old-syntax (pattern-variable->syntax old)]
[new.result (pattern-variable->syntax [new.result (pattern-variable->syntax
(pattern-variable (format-id new "~a_result" new) (pattern-variable (format-id new "~a_result" new)
(pattern-variable-depth old) old.original
(pattern-variable-class old)))]) old.depth
old.class))])
(set-union (set #'(#:with old-syntax #'new.result)) (set-union (set #'(#:with old-syntax #'new.result))
(bind-attributes old new))))) (bind-attributes old new)))))
(debug "With bindings ~a\n" withs) (debug "With bindings ~a\n" withs)
(with-syntax ([name name] (with-syntax ([(literal ...) #'literals]
[(literal ...) literals] [(new-pattern ...) (convert-pattern #'original-pattern mapping)]
[(new-pattern ...) (convert-pattern original-pattern mapping)]
[((withs ...) ...) (set->list withs)] [((withs ...) ...) (set->list withs)]
[(result-with ...) (if maybe-out [(result-with ...) (if (syntax-e #'maybe-out)
(with-syntax ([(out ...) maybe-out]) (with-syntax ([(out ...) #'maybe-out])
#'(#:with result (as-honu-syntax out ...))) #'(#:with result (out ...)))
#'(#:with result #'()))]) #'(#:with result #'()))])
(phase1:racket-syntax (begin (debug "Result with ~a\n" (syntax->datum #'(quote-syntax (result-with ...))))
;; define at phase1 so we can use it (define output
(begin-for-syntax #'(quote-syntax
(define-literal-set local-literals (literal ...)) (begin
(define-splicing-syntax-class name ;; define at phase1 so we can use it
#:literal-sets ([cruft #:at name] (begin-for-syntax
[local-literals #:at name]) (define-literal-set local-literals (literal ...))
[pattern (~seq new-pattern ...) (define-splicing-syntax-class name
withs ... ... #:literal-sets ([cruft #:at name]
result-with ... [local-literals #:at name])
])) [pattern (~seq new-pattern ...)
;; and define at phase 0 so we can inspect it withs ... ...
(define-literal-set local-literals (literal ...)) result-with ...
(define-splicing-syntax-class name ])))))
#:literal-sets ([cruft #:at name] (debug "Output is ~a\n" (pretty-syntax output))
[local-literals #:at name]) output)])))
[pattern (~seq new-pattern ...)
withs ... ... ;; generates a phase 1 binding for the pattern. analyzes its pattern so it
result-with ... ;; must execute in phase 2
]))))) (define-honu-syntax honu-pattern
(lambda (code context)
(syntax-parse code #:literal-sets (cruft) (syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens literal ...) [(_ name (#%parens literal ...)
(#%braces pattern ...) (#%braces pattern ...)
(~optional (#%braces out ...)) (~optional (#%braces out ...))
. rest) . rest)
(values (generate-pattern #'name #'(literal ...) (values (with-syntax ([out* (attribute out)])
#'(pattern ...) (phase1:racket-syntax
(attribute out)) (splicing-let-syntax
([make (lambda (stx)
(syntax-parse stx
[(_ new-name)
(syntax-local-introduce
(generate-pattern name
(literal ...)
(pattern ...)
out*))]))])
(make name))))
#'rest #'rest
#f)]))) #f)])))

2
collects/tests/honu/macros2.honu
View File

@ -11,7 +11,7 @@ foo h
h 5 h 5
h 8 * 9 h 8 * 9
test(z){ function test(z){
macro foo (){ x:identifier }{ macro foo (){ x:identifier }{
syntax(macro x (){ e:expression }{ syntax(macro x (){ e:expression }{
syntax(e + z) syntax(e + z)