From 549a7522e3953592074f9dc9b0aff24c2e5bf455 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 9 Feb 2012 17:21:20 -0700 Subject: [PATCH] [honu] add syntactic patterns. parse the output of macros using a local define-syntax (kind of hackish) --- collects/honu/core/main.rkt | 2 + collects/honu/core/private/debug.rkt | 9 +- collects/honu/core/private/macro2.rkt | 173 +++++++++++++++++++++----- collects/honu/core/private/parse2.rkt | 45 ++++++- collects/honu/core/private/struct.rkt | 4 +- 5 files changed, 196 insertions(+), 37 deletions(-) diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 9f3a3e1561..88a6e33928 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -30,6 +30,7 @@ [honu-new new] [honu-while while] [honu-macro macro] + [honu-pattern pattern] [racket:read-line readLine] [honu-with-input-from-file withInputFromFile] [define-make-honu-operator operator] @@ -87,6 +88,7 @@ this #%top #%datum + (... ...) )))) (require "private/honu-typed-scheme.rkt") diff --git a/collects/honu/core/private/debug.rkt b/collects/honu/core/private/debug.rkt index ae5c0f3d17..84a087f49b 100644 --- a/collects/honu/core/private/debug.rkt +++ b/collects/honu/core/private/debug.rkt @@ -6,9 +6,12 @@ (provide debug) (define-for-syntax (filename path) - (define-values (base name dir?) - (split-path (build-path path))) - name) + (if path + (let () + (define-values (base name dir?) + (split-path (build-path path))) + name) + "no source")) (define (colorize string color) (define colors (hash 'none "0" diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index a4e9ce98a0..ec799ce440 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -3,6 +3,7 @@ (require (for-syntax "transformer.rkt" syntax/parse syntax/stx + racket/set racket/syntax "literals.rkt" "parse2.rkt" @@ -18,24 +19,81 @@ (for-syntax "honu-typed-scheme.rkt") syntax/parse) -(define-for-syntax (convert-pattern original-pattern) +(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 ...) #'((~var name class #:attr-name-separator "_"))] + #:with (result ...) + (with-syntax ([new-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 ... ...)])) +;; 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 + [(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 ([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 #'(name name.result)))] + [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 #:literal-sets (cruft) [pattern (~seq name colon class) ;; we know the output of syntactic classes will end with _result - #:with (result ...) (with-syntax ([name.result (format-id #'name "~a_result" #'name)]) - #'((name name.result)))] + #:with (result ...) + ;; FIXME: dont need name.result anymore here + (with-syntax ([name.result (format-id #'name "~a_result" #'name)]) + #'(name))] [pattern (x:pattern-type ...) #:with (result ...) #'(x.result ... ...)] [pattern x #:with (result ...) #'()]) (syntax-parse original-pattern @@ -57,30 +115,39 @@ (debug "Pattern is ~a\n" #'(pattern ...)) (debug 2 "Pattern variables ~a\n" (find-pattern-variables #'(pattern ...))) (values - (with-syntax ([(syntax-parse-pattern ...) - (convert-pattern #'(pattern ...))] - [((pattern-variable.name pattern-variable.result) ...) - (find-pattern-variables #'(pattern ...))]) - #'(%racket (define-honu-syntax name - (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] - ...) - (parse-stuff action ...) - #; - (let-syntax ([parse-more (lambda (stx) - (parse-all #'(action ...)))]) - (parse-more))) - #'more #t)]))))) + (let () + (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" (syntax-e variable)) + (hash-set! mapping (syntax-e variable) variable)) + (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)]) + #'(name name.result)))]) + #'(%racket (define-honu-syntax name + (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] + ...) + (parse-stuff action ...)) + #'more #t)] + [else (raise-syntax-error #f "Could not match macro" stx)] + )))))) #'rest #t)]))) @@ -107,3 +174,53 @@ (with-syntax ([(syntax1* ...) syntax1] [(syntax2* ...) syntax2]) #'(syntax1* ... syntax2* ...))) + +;; creates a new syntax/parse pattern +(provide honu-pattern) +(define-honu-syntax honu-pattern + (lambda (code context) + (define (bind-to-results pattern) + (with-syntax ([((pattern-variable.name pattern-variable.result) ...) + (find-pattern-variables pattern)]) + (with-syntax ([(each ...) + (for/list ([name (syntax->list #'(pattern-variable.name ...))] + [result (syntax->list #'(pattern-variable.result ...))]) + (with-syntax ([name name] + [result result]) + #'(#:with result result)))]) + #'(each ...)))) + (define (generate-pattern name literals original-pattern) + (define variables (find-pattern-variables original-pattern)) + (define use (generate-temporaries variables)) + (define mapping (make-hash)) + (for ([old variables] + [new use]) + (hash-set! mapping (syntax-e old) new)) + (define withs + (for/list ([old variables] + [new use]) + (with-syntax ([old old] + [new.result (format-id new "~a_result" new)]) + #'(#:with old #'new.result)))) + (with-syntax ([name name] + [(literal ...) literals] + [(new-pattern ...) (convert-pattern original-pattern mapping)] + [((withs ...) ...) withs] + #; + [((bindings ...) ...) (bind-to-results original-pattern)]) + #'(%racket (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 ... ... + ; bindings ... ... + ]))))) + (syntax-parse code #:literal-sets (cruft) + [(_ name (#%parens literal ...) + (#%braces pattern ...) + . rest) + (values (generate-pattern #'name #'(literal ...) #'(pattern ...)) + #'rest + #f)]))) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 6c45f14a6b..49e220aba6 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -154,7 +154,7 @@ (debug 2 "Comma? ~a ~a\n" what is) is) -(define (do-parse stx parse-more) +(define (do-parse-rest stx parse-more) (syntax-parse stx [(_ stuff ...) (define-values (parsed unparsed) @@ -171,13 +171,26 @@ #'output #'(begin output (parse-more unparsed-out ...))))])) +(define (do-parse-rest/local stx) + (define name (gensym 'local-parser)) + (define local-parser (with-syntax ([name name]) + #'(define-syntax (name stx) + (do-parse-rest stx #'name)))) + (with-syntax ([local local-parser] + [parsed (do-parse-rest stx name)]) + #'(begin local parsed))) + +(define-syntax (do-parse-rest-macro stx) + (with-syntax ([stx stx]) + #'(do-parse-rest stx #'do-parse-rest-macro))) + (provide honu-body) (define-syntax-class honu-body #:literal-sets (cruft) [pattern (#%braces code ...) #:with result #'(let () (define-syntax (parse-more stx) - (do-parse stx #'parse-more)) + (do-parse-rest stx #'parse-more)) (parse-more code ...))]) (provide honu-function) @@ -234,6 +247,7 @@ (datum->syntax #'head (syntax->list #'(head rest ...)) #'head #'head)) #f)]) + #; (emit-remark parsed) #; (emit-local-step stream parsed #:id #'do-macro) @@ -243,13 +257,25 @@ #; (do-parse #'(parsed ... rest ...) precedence left current) + (define re-parse + (with-syntax ([(x ...) #'parsed]) + (do-parse-rest/local #'(nothing x ...)))) + (debug "Reparsed ~a\n" (pretty-format (syntax->datum re-parse))) + #; (define re-parse (let-values ([(re-parse re-unparse) (parse #'parsed)]) (with-syntax ([(re-parse* ...) re-parse] [(re-unparse* ...) re-unparse]) (datum->syntax re-parse - (syntax->list #'(re-parse* ... re-unparse* ...)) + (syntax->list + #'(%racket + (begin (re-parse* ...) + (let () + (define-syntax (parse-more stx) + (do-parse-rest stx #'parse-more)) + (parse-more re-unparse* ...))))) re-parse re-parse)))) + (debug "Reparsed output ~a\n" (pretty-format (syntax->datum re-parse))) (if terminate? (values (left re-parse) #'rest) @@ -270,6 +296,7 @@ (values (left final) #'())] ;; dont reparse pure racket code [(%racket racket) + (debug "Native racket expression ~a\n" #'racket) (if current (values (left current) stream) (values (left stream) #'())) @@ -293,10 +320,14 @@ precedence left #'racket))] [(head rest ...) + (debug "Not a special expression..\n") (cond [(honu-macro? #'head) + (debug "Macro ~a\n" #'head) (do-macro #'head #'(rest ...) precedence left current stream)] + #; [(parsed-syntax? #'head) + (debug "Parsed syntax ~a\n" #'head) (do-parse #'(rest ...) precedence left #'head)] [(honu-fixture? #'head) (debug 2 "Fixture ~a\n" #'head) @@ -354,6 +385,7 @@ (left final)))] [(stopper? #'head) + (debug "Parse a stopper ~a\n" #'head) (values (left final) stream)] [else @@ -374,9 +406,12 @@ #; [(left:no-left function:honu-function . rest) (values #'function.result #'rest)] - [else (syntax-parse #'head + [else + (debug "Parse a single thing ~a\n" #'head) + (syntax-parse #'head #:literal-sets (cruft) [(%racket x) + (debug 2 "Native racket expression ~a\n" #'x) (if current (values (left current) stream) (do-parse #'(rest ...) precedence left #'head))] @@ -424,6 +459,7 @@ (do-parse #'(rest ...) precedence left #'body.result))] ;; expression or function application [(#%parens args ...) + (debug "Maybe function call with ~a\n" #'(args ...)) (if current ;; FIXME: 9000 is an arbitrary precedence level for ;; function calls @@ -440,6 +476,7 @@ (define call (with-syntax ([current current] [(parsed-args ...) (parse-comma-expression #'(args ...)) ]) + (debug "Parsed args ~a\n" #'(parsed-args ...)) #'(current parsed-args ...))) (do-parse #'(rest ...) precedence left call))) (let () diff --git a/collects/honu/core/private/struct.rkt b/collects/honu/core/private/struct.rkt index d213c5f383..2baf774f15 100644 --- a/collects/honu/core/private/struct.rkt +++ b/collects/honu/core/private/struct.rkt @@ -17,11 +17,11 @@ (define-for-syntax (make-accessors name fields) (for/list ([field fields]) - (format-unique-id name "~a-~a" name field))) + (format-unique-id field "~a-~a" name field))) (define-for-syntax (make-mutators name fields) (for/list ([field fields]) - (format-unique-id name "set-~a-~a!" name field))) + (format-unique-id field "set-~a-~a!" name field))) (provide honu-struct-set!) (define (honu-struct-set! instance name value)