diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 0ba9590300..2310ff29eb 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -15,6 +15,7 @@ "private/honu2.rkt")) (provide (for-meta meta-level (rename-out [parse:honu-expression expression] + [parse:honu-expression-list expression_list] [parse:honu-identifier identifier] [racket:else else] [racket:void void] diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 19635d8dd8..79c1654158 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -9,6 +9,8 @@ "parse2.rkt" "debug.rkt" "compile.rkt" + "util.rkt" + (prefix-in syntax: syntax/parse/private/residual-ct) racket/base) (for-meta 2 syntax/parse racket/base @@ -28,7 +30,7 @@ #:literal-sets (cruft) [pattern (~seq name colon class) #:with (result ...) - (with-syntax ([new-name (hash-ref new-names (syntax-e #'name))]) + (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)]) @@ -36,13 +38,22 @@ [(thing:pattern-type ...) #'(thing.result ... ...)])) +(begin-for-syntax + (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 (... ...)))))) + ;; 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 ;; ... foo %colon bar ;; output would be ;; ((bar ...) (foo_result ...) -#; (define-for-syntax (find-pattern-variables original-pattern) (define (reverse-syntax input) (syntax-parse input @@ -54,6 +65,12 @@ (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 () @@ -68,7 +85,7 @@ [pattern (~seq class:id colon name:id) #:attr result (with-syntax ([name.result (format-id #'name "~a_result" #'name)]) - (set #'(name name.result)))] + (set (pattern-variable #'name 0 #'class)))] [pattern (~seq ellipses thing:maybe rest ...) #:attr result (merge (wrap-ellipses (attribute thing.result)) @@ -89,6 +106,7 @@ (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 #:literal-sets (cruft) @@ -128,15 +146,25 @@ ;; only need a 1-to-1 mapping here (define mapping (make-hash)) (for ([variable pattern-variables]) - (debug "Update mapping for ~a\n" (syntax-e variable)) - (hash-set! mapping (syntax-e variable) variable)) + (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]) - (with-syntax ([name name] - [name.result (format-id name "~a_result" name)]) + (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") (racket-syntax (define-honu-syntax name (lambda (stx context-name) @@ -220,30 +248,88 @@ (define mapping (make-hash)) (for ([old variables] [new use]) - (hash-set! mapping (syntax-e old) new)) + (debug "Update mapping ~a to ~a\n" (syntax-e (pattern-variable-name old)) new) + (hash-set! mapping + (syntax-e (pattern-variable-name old)) + (pattern-variable new + (pattern-variable-depth old) + (pattern-variable-class old)))) + + ;; variable is the original pattern variable, like 'foo' + ;; and new-name is the new generated name, 'temp1' + ;; we want to bind all the attributes from temp1 to foo, so if temp1 has + ;; temp1_a + ;; temp1_b ... + ;; + ;; we want to bind + ;; foo_a temp_a + ;; (foo_b ...) (temp_b ...) + (define (bind-attributes variable new-name) + (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-phase-level)) + (define attributes + (let ([syntax-class (syntax-local-value (pattern-variable-class variable))]) + (for/list ([attribute (syntax:stxclass-attrs syntax-class)]) + (pattern-variable (syntax:attr-name attribute) + (+ (pattern-variable-depth variable) + (syntax:attr-depth attribute)) + #f)))) + (for/set ([attribute attributes]) + (with-syntax ([bind-attribute + (let ([name (pattern-variable-name attribute)]) + (pattern-variable->syntax + (pattern-variable (format-id (pattern-variable-name variable) "~a_~a" + (syntax-e (pattern-variable-name variable)) + name) + (pattern-variable-depth attribute) + (pattern-variable-class attribute))))] + [new-attribute (pattern-variable->syntax + (pattern-variable + (format-id new-name "~a_~a" new-name (pattern-variable-name attribute)) + (pattern-variable-depth attribute) + #f))]) + #'(#:with bind-attribute #'new-attribute)))) + (define withs - (for/list ([old variables] + (for/union ([old variables] [new use]) - (with-syntax ([old old] - [new.result (format-id new "~a_result" new)]) - #'(#:with old #'new.result)))) + (with-syntax ([old-syntax (pattern-variable->syntax old)] + [new.result (pattern-variable->syntax + (pattern-variable (format-id new "~a_result" new) + (pattern-variable-depth old) + (pattern-variable-class old)))]) + (set-union (set #'(#:with old-syntax #'new.result)) + (bind-attributes old new))))) + (debug "With bindings ~a\n" withs) (with-syntax ([name name] [(literal ...) literals] [(new-pattern ...) (convert-pattern original-pattern mapping)] - [((withs ...) ...) withs] + [((withs ...) ...) (set->list withs)] [(result-with ...) (if maybe-out (with-syntax ([(out ...) maybe-out]) #'(#:with result (syntax out ...))) - #'())]) - #'(%racket (begin-for-syntax + #'(#:with result #'()))]) + #'(%racket (begin + ;; define at phase1 so we can use it + (begin-for-syntax + (define-literal-set local-literals (literal ...)) + (define-splicing-syntax-class name + #:literal-sets ([cruft #:at name] + [local-literals #:at name]) + [pattern (~seq new-pattern ...) + withs ... ... + result-with ... + ])) + ;; and define at phase 0 so we can inspect it (define-literal-set local-literals (literal ...)) (define-splicing-syntax-class name - #:literal-sets ([cruft #:at name] - [local-literals #:at name]) - [pattern (~seq new-pattern ...) - withs ... ... - result-with ... - ]))))) + #:literal-sets ([cruft #:at name] + [local-literals #:at name]) + [pattern (~seq new-pattern ...) + withs ... ... + result-with ... + ]))))) (syntax-parse code #:literal-sets (cruft) [(_ name (#%parens literal ...) (#%braces pattern ...) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index ff83ad91b4..c72d3ebc45 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -8,6 +8,7 @@ "literals.rkt" "debug.rkt" "compile.rkt" + racket/list (prefix-in transformer: "transformer.rkt") (prefix-in fixture: "fixture.rkt") "operator.rkt" @@ -159,7 +160,7 @@ #; (honu->racket parsed) #'(void))) - (debug "Output ~a\n" output) + (debug "Output ~a\n" (syntax->datum output)) (with-syntax ([output output] [(unparsed-out ...) unparsed] [parse-more parse-more]) @@ -572,14 +573,26 @@ #:description "expression" (lambda (stx fail) (debug "honu expression syntax class\n") - (define-values (parsed unparsed) - (parse stx)) - (debug "parsed ~a\n" (if parsed (syntax->datum parsed) parsed)) - (list (parsed-things stx unparsed) - (parsed-syntax parsed) - #; - (with-syntax ([parsed parsed]) - #'(%racket parsed))))) + (if (stx-null? stx) + (fail) + (let () + (define-values (parsed unparsed) + (parse stx)) + (debug "parsed ~a\n" (if parsed (syntax->datum parsed) parsed)) + (list (parsed-things stx unparsed) + (parsed-syntax parsed) + #; + (with-syntax ([parsed parsed]) + #'(%racket parsed))))))) + +(provide honu-expression-list) +(define-splicing-syntax-class (honu-expression-list) + #:literal-sets (cruft) + [pattern (~seq (~seq each:honu-expression (~optional honu-comma)) ...) + #:with (each_result ...) + (with-syntax ([(each ...) (add-between (syntax->list #'(each.result ...)) #'honu-comma)]) + #'(each ...)) + ]) (provide honu-identifier) (define-splicing-syntax-class honu-identifier diff --git a/collects/honu/core/private/util.rkt b/collects/honu/core/private/util.rkt index fadd73c82c..2044c27d06 100644 --- a/collects/honu/core/private/util.rkt +++ b/collects/honu/core/private/util.rkt @@ -5,7 +5,9 @@ racket/match syntax/parse syntax/parse/experimental/reflect + racket/set (for-syntax racket/base + racket/set syntax/parse "debug.rkt" ) @@ -134,3 +136,10 @@ #:literal-sets ([set #:at literal]) [pattern literal]) (reify-syntax-class class))) + +(define-syntax (for/union stx) + (syntax-case stx () + [(_ clauses . body) + #'(for/fold/derived stx ([accum-set (set)]) + clauses + (set-union accum-set (let () . body)))])) diff --git a/collects/tests/honu/match.honu b/collects/tests/honu/match.honu index 6451953cdd..f4fc2ce53c 100644 --- a/collects/tests/honu/match.honu +++ b/collects/tests/honu/match.honu @@ -2,7 +2,7 @@ var => = 0 -pattern match_pattern (){ [element:expression] } { [element] } +pattern match_pattern (){ [element:expression_list]} { [element_each_result ...]} pattern match_clause (| =>){ | pattern:match_pattern => out:expression , } @@ -14,18 +14,16 @@ macro mymatch(with){ cond $ clause_pattern == thing: clause_out, $ ... else: -2 - - /* - if (clause_pattern == thing){ - clause_out - } else { - -2 - } - */) + ) } mymatch [1] with | [1] => 5, | [2] => 6, +mymatch [1, 2, 3] with +| [4] => 12, +| [1, 2] => 7, +| [1, 2, 3] => 8, + // mymatch [1] with | [2] => 5