From 241f8e67b4f7c5b5cf478a9669449e13c1c682b5 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 9 May 2012 23:08:39 -0600 Subject: [PATCH] [honu] analyze macro parameters at phase 2. temporarily break patterns --- collects/honu/core/private/compile.rkt | 1 + collects/honu/core/private/macro2.rkt | 171 +++++++++++++++++++++++++ 2 files changed, 172 insertions(+) diff --git a/collects/honu/core/private/compile.rkt b/collects/honu/core/private/compile.rkt index 2e7cac189a..518bc7af59 100644 --- a/collects/honu/core/private/compile.rkt +++ b/collects/honu/core/private/compile.rkt @@ -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 diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 04f0ab2ca8..8b639a9aa0 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -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)