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

[honu] analyze macro parameters at phase 2. temporarily break patterns

Browse Source
This commit is contained in:
Jon Rafkind 2012-05-09 23:08:39 -06:00
parent d688621a18
commit 241f8e67b4
2 changed files with 172 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -116,6 +116,7 @@
(define-syntax (racket-syntax stx)
(syntax-case stx ()
[(_ form)
(debug 2 "Racket syntax ~a\n" #'form)
#'(parsed-syntax #'form)]))
(begin-for-syntax

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

@ -15,9 +15,14 @@
(for-meta 2 syntax/parse
racket/base
macro-debugger/emit
racket/syntax
racket/set
"literals.rkt"
"debug.rkt"
(prefix-in phase2: "parse2.rkt")
(prefix-in phase2: "compile.rkt"))
(prefix-in phase0: "compile.rkt")
racket/splicing
"literals.rkt"
"syntax.rkt"
"debug.rkt"
@ -26,6 +31,43 @@
(for-syntax "honu-typed-scheme.rkt")
syntax/parse)
(module analysis racket/base
(require syntax/parse
(for-syntax racket/base
"literals.rkt"
syntax/parse))
(provide (all-defined-out))
(begin-for-syntax
(provide (all-defined-out))
(struct pattern-variable [name depth class] #:transparent)
;; makes a syntax object with the right number of nested ellipses patterns
(define (pattern-variable->syntax variable)
(for/fold ([out (pattern-variable-name variable)])
([depth (pattern-variable-depth variable)])
(with-syntax ([out out])
#'(out (... ...))))))
(define-for-syntax (convert-pattern original-pattern new-names)
(define-splicing-syntax-class pattern-type
#:literal-sets (cruft)
[pattern (~seq name colon class)
#:with (result ...)
(with-syntax ([new-name (pattern-variable-name (hash-ref new-names (syntax-e #'name)))])
#'((~var new-name class #:attr-name-separator "_")))]
[pattern (x:pattern-type ...) #:with (result ...) #'((x.result ... ...))]
[pattern x #:with (result ...) #'(x)])
(syntax-parse original-pattern
[(thing:pattern-type ...)
#'(thing.result ... ...)]))
)
(require (for-syntax (submod "." analysis)))
#;
(define-for-syntax (convert-pattern original-pattern new-names)
(define-splicing-syntax-class pattern-type
#:literal-sets (cruft)
@ -49,6 +91,8 @@
(with-syntax ([out out])
#'(out (... ...))))))
;; reverse the syntax so that ellipses appear in front of the s-expr
;; then search for ellipses nodes and s-exprs of the form class:id %colon name:id
;; the output should match the ellipses depth, so for example
@ -107,6 +151,59 @@
(debug "Found variables ~a\n" variables)
(for/list ([x variables]) x))
(begin-for-syntax
(define-for-syntax (find-pattern-variables original-pattern)
(define (reverse-syntax input)
(syntax-parse input
[(x ...) (datum->syntax #'(x ...)
(reverse (for/list ([x (syntax->list #'(x ...))])
(reverse-syntax x)))
#'(x ...) #'(x ...))]
[x #'x]))
(define (merge set1 set2)
(debug "Merge ~a with ~a\n" set1 set2)
(set-union set1 set2))
(define (wrap-ellipses stuff)
(for/set ([variable stuff])
(pattern-variable (pattern-variable-name variable)
(add1 (pattern-variable-depth variable))
(pattern-variable-class variable))))
#;
(define (wrap-ellipses stuff)
(for/set ([name+result stuff])
(syntax-case name+result ()
[(name result)
#'((name (... ...))
(result (... ...)))])))
(define (find the-pattern)
(debug "Find in ~a\n" (syntax->datum the-pattern))
(define-splicing-syntax-class maybe
#:literal-sets (cruft)
#:literals ([ellipses ...])
[pattern (~seq class:id colon name:id)
#:attr result
(with-syntax ([name.result (format-id #'name "~a_result" #'name)])
(set (pattern-variable #'name 0 #'class)))]
[pattern (~seq ellipses thing:maybe rest ...)
#:attr result
(merge (wrap-ellipses (attribute thing.result))
(find #'(rest ...)))]
[pattern (x:maybe ...) #:attr result (apply set-union (attribute x.result))]
[pattern x #:attr result (set)])
(syntax-parse the-pattern
#:literals ([ellipses ...])
[(ellipses thing:maybe rest ...)
(debug "Ellipses case\n")
(merge (wrap-ellipses (attribute thing.result))
(find #'(rest ...)))]
[(thing:maybe rest ...)
(debug "Normal list case ~a\n" (attribute thing.result))
(merge (attribute thing.result) (find #'(rest ...)))]
[thing (set)]))
(define variables (find (reverse-syntax original-pattern)))
(debug "Found variables ~a\n" variables)
(for/list ([x variables]) x)))
#;
(define-for-syntax (find-pattern-variables original-pattern)
(define-splicing-syntax-class pattern-type
@ -132,7 +229,76 @@
#;
(honu->racket (parse-all #'(stuff ...)))])))
(begin-for-syntax
(define-syntax (create-honu-macro stx)
(syntax-parse stx
[(_ (literal ...) (pattern ...) (action ...))
(define pattern-variables (find-pattern-variables #'(pattern ...)))
;; only need a 1-to-1 mapping here
(define mapping (make-hash))
(for ([variable pattern-variables])
(debug "Update mapping for ~a\n" (pattern-variable-name variable))
(hash-set! mapping (syntax-e (pattern-variable-name variable))
variable))
(debug "Create pattern\n")
(with-syntax ([(syntax-parse-pattern ...)
(convert-pattern #'(pattern ...) mapping)]
[((pattern-variable.name pattern-variable.result) ...)
(for/list ([name pattern-variables])
(debug "Create new pattern variable from ~a\n" name)
(with-syntax ([name (pattern-variable->syntax name)]
[name.result (pattern-variable->syntax
(pattern-variable (format-id (pattern-variable-name name)
"~a_result"
(pattern-variable-name name))
(pattern-variable-depth name)
(pattern-variable-class name)
))])
#'(name name.result)))])
(debug "Done with syntax\n")
(syntax (phase1:racket-syntax
(lambda (stx context-name)
(define-literal-set local-literals (literal ...))
(syntax-parse stx
#:literal-sets ([cruft #:at name]
[local-literals #:at name])
[(_ syntax-parse-pattern ... . more)
(values
;; if the pattern is x:expression then x_result will
;; hold the parsed version of x, so we rebind x to
;; x_result so you can use just x in the template
;; 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 ...))
#'more #t)]
[else (raise-syntax-error #f "Could not match macro" stx)])))))]))
)
(provide honu-macro)
(define-honu-syntax honu-macro
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens literal ...) (#%braces pattern ...) (#%braces action ...) . rest)
(values (phase1:racket-syntax
;; trampoline to phase 1
(splicing-let-syntax ([make (lambda (stx)
(syntax-parse stx
[(_ name)
(define output
(create-honu-macro (literal ...)
(pattern ...)
(action ...)))
(debug "Output from create macro ~a\n" output)
(with-syntax ([output output])
#'(define-honu-syntax name output))]))])
(make name)))
#'rest
#t)])))
#;
(define-honu-syntax honu-macro
(lambda (code context)
(debug "Macroize ~a\n" code)
@ -253,8 +419,13 @@
[(syntax2* ...) #'something2])
#'(%racket (unexpand (syntax1* ... syntax2* ...))))])]))
;; honu-pattern should expand to
;; (define-syntax honu-pattern ...)
;; creates a new syntax/parse pattern
(provide honu-pattern)
(define-honu-syntax honu-pattern (lambda (code context) #'f))
#;
(define-honu-syntax honu-pattern
(lambda (code context)
(define (generate-pattern name literals original-pattern maybe-out)