From 7379684c5b0d76c9f0d23b3054c01515ec17bc0a Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 21 Feb 2012 14:15:39 -0700 Subject: [PATCH] [honu] use syntax properties to differentiate racket syntax from honu syntax instead of the %racket identifier --- collects/honu/core/private/compile.rkt | 46 ++++++++++++++++++--- collects/honu/core/private/honu2.rkt | 23 ++++++----- collects/honu/core/private/macro2.rkt | 28 ++++++++++--- collects/honu/core/private/operator.rkt | 6 +-- collects/honu/core/private/parse2.rkt | 53 ++++++++++++++++--------- 5 files changed, 112 insertions(+), 44 deletions(-) diff --git a/collects/honu/core/private/compile.rkt b/collects/honu/core/private/compile.rkt index 23b2f213f1..58d2c6e78a 100644 --- a/collects/honu/core/private/compile.rkt +++ b/collects/honu/core/private/compile.rkt @@ -1,7 +1,9 @@ #lang racket/base (require syntax/parse - (for-syntax racket/base "debug.rkt" syntax/parse) + "debug.rkt" + (for-syntax racket/base "debug.rkt" syntax/parse + macro-debugger/emit) "literals.rkt") ;; to get syntax as a literal @@ -11,9 +13,13 @@ (define (honu->racket forms) (define-literal-set literals (%racket)) + forms + #; (syntax-parse forms #:literal-sets (literals) #:literals ([literal-syntax syntax]) - [(%racket x) (honu->racket #'x)] + [(%racket x) #'x + #; + (honu->racket #'x)] [(literal-syntax form) #'#'form] [(form ...) (datum->syntax forms @@ -37,17 +43,20 @@ (define-syntax (unexpand-honu-syntax stx) (define (remove-repeats input) - (debug "Remove repeats from ~a\n" (syntax->datum input)) + (debug 2 "Remove repeats from ~a\n" (syntax->datum input)) + (debug 2 "Properties ~a\n" (syntax-property-symbol-keys input)) (define-literal-set locals (repeat$)) (syntax-parse input #:literal-sets (locals) [(out ... (repeat$ stuff ...) rest ...) - (debug " Found a repeat\n") + (debug 2 " Found a repeat\n") (with-syntax ([(out* ...) (map remove-repeats (syntax->list #'(out ...)))] [(rest* ...) (map remove-repeats (syntax->list #'(rest ...)))]) - (remove-repeats #'(out* ... stuff ... rest* ...)))] + (remove-repeats (datum->syntax input + (syntax->list #'(out* ... stuff ... rest* ...)) + input input)))] [(normal ...) (with-syntax ([(normal* ...) (map remove-repeats (syntax->list #'(normal ...)))]) (datum->syntax input - #'(normal* ...) + (syntax->list #'(normal* ...)) input input))] [x #'x] [else (raise-syntax-error 'repeats "unhandled case" input)])) @@ -56,7 +65,32 @@ [(_ expr) (begin (debug "Expand honu syntax at phase ~a\n" (syntax-local-phase-level)) + #; (debug " Is ~a expanded ~a\n" (syntax->datum #'expr) (syntax->datum #'#'expr)) + (emit-remark "Unexpand honu syntax" #'expr) + #; + (syntax-case #'expr () + [(_ what) (debug "Properties on ~a are ~a\n" #'what (syntax-property-symbol-keys #'what))]) (define removed (remove-repeats #'expr)) + (emit-local-step #'expr removed #:id #'unexpand-honu-syntax) (debug "Cleansed ~a\n" (syntax->datum removed)) + (debug "Syntax properties ~a\n" (syntax-property-symbol-keys removed)) removed)])) + +; (define parsed-property (gensym 'honu-parsed)) +(define parsed-property 'honu-parsed) + +(define (parsed-syntax syntax) + (debug "Add parsed syntax property to ~a\n" syntax) + (if syntax + (syntax-property syntax parsed-property #t) + syntax)) + +(define (parsed-syntax? syntax) + (syntax-property syntax parsed-property)) + +(define-syntax (racket-syntax stx) + (syntax-case stx () + [(_ form) + #'(parsed-syntax #'form)])) + diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index 609af1715b..9e3af05265 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -66,12 +66,10 @@ (lambda (code context) (syntax-parse code #:literal-sets (cruft) #:literals (else honu-then) - [(_ (#%parens condition:honu-expression) true:honu-expression (~optional else) false:honu-expression . rest) + [(_ (#%parens condition:honu-expression) true:honu-expression + (~optional else) false:honu-expression . rest) (values - (with-syntax ([condition.result (honu->racket #'condition.result)] - [true.result (honu->racket #'true.result)] - [false.result (honu->racket #'false.result)]) - #'(%racket (if condition.result true.result false.result))) + (racket-syntax (if condition.result true.result false.result)) #'rest #f)]))) @@ -233,9 +231,9 @@ (lambda (code context) (syntax-parse code [(_ name:id ...) - (values #'(%racket (provide name ...)) - #'() - #f)]))) + (define out (parsed-syntax #'(provide name ...))) + (debug "Provide properties ~a\n" (syntax-property-symbol-keys out)) + (values out #'() #f)]))) (provide honu-with-input-from-file) (define-honu-syntax honu-with-input-from-file @@ -336,7 +334,8 @@ [(var:honu-declaration . rest) (define result (with-syntax ([var.expression (honu->racket #'var.expression)]) - #'(%racket (define-values (var.name ...) var.expression)))) + ;; wrap the expression in a let so that we can insert new `define-syntax'es + (racket-syntax (define-values (var.name ...) (let () var.expression))))) (values result #'rest #t)]))) (provide (rename-out [honu-with-syntax withSyntax])) @@ -361,8 +360,10 @@ #:literals (honu-in) [(_ (~seq iterator:id honu-in stuff:honu-expression (~optional honu-comma)) ... honu-do body:honu-expression . rest) - (values #'(%racket (for ([iterator stuff.result] ...) - body.result)) + (values (with-syntax ([(stuff.result ...) (map honu->racket (syntax->list #'(stuff.result ...)))] + [body.result (honu->racket #'body.result)]) + #'(%racket (for ([iterator stuff.result] ...) + body.result))) #'rest #t)]))) diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 63d67de5a4..19635d8dd8 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -12,10 +12,12 @@ racket/base) (for-meta 2 syntax/parse racket/base + macro-debugger/emit "parse2.rkt" "compile.rkt") "literals.rkt" "syntax.rkt" + "debug.rkt" (for-meta -1 "literals.rkt" "compile.rkt" "parse2.rkt" "parse-helper.rkt") #; (for-syntax "honu-typed-scheme.rkt") @@ -106,6 +108,9 @@ (define-syntax (parse-stuff stx) (syntax-parse stx [(_ stuff ...) + (emit-remark "Parse stuff ~a\n" #'(stuff ...)) + (parse-all #'(stuff ...)) + #; (honu->racket (parse-all #'(stuff ...)))]))) (provide honu-macro) @@ -132,7 +137,8 @@ (with-syntax ([name name] [name.result (format-id name "~a_result" name)]) #'(name name.result)))]) - #'(%racket (define-honu-syntax name + (racket-syntax + (define-honu-syntax name (lambda (stx context-name) (define-literal-set local-literals (literal ...)) (syntax-parse stx @@ -162,11 +168,14 @@ (syntax-parse stx #:literal-sets (local-literals) [(honu-$ x ... honu-$ rest ...) (with-syntax ([(rest* ...) (compress-dollars #'(rest ...))]) - #'((repeat$ x ...) rest* ...))] + (datum->syntax stx (syntax->list #'((repeat$ x ...) rest* ...)) + stx stx))] [(x rest ...) (with-syntax ([x* (compress-dollars #'x)] [(rest* ...) (compress-dollars #'(rest ...))]) - #'(x* rest* ...))] + (datum->syntax stx + (syntax->list #'(x* rest* ...)) + stx stx))] [x #'x])) (syntax-parse code #:literal-sets (cruft) [(_ (#%parens stuff ...) . rest) @@ -179,7 +188,7 @@ ;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*)) ;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*)) (with-syntax ([(out ...) #'stuff*]) - #'(%racket #'(%racket (unexpand-honu-syntax (do-parse-rest-macro out ...)))))) + (racket-syntax #'stuff*))) #; #'(%racket-expression (parse-stuff stuff ...)) #'rest #f)]))) @@ -188,9 +197,18 @@ ;; #'(a b) + #'(c d) = #'(a b c d) (provide mergeSyntax) (define (mergeSyntax syntax1 syntax2) + (debug "Merge syntax ~a with ~a\n" (syntax->datum syntax1) (syntax->datum syntax2)) (with-syntax ([(syntax1* ...) syntax1] [(syntax2* ...) syntax2]) - #'(syntax1* ... syntax2* ...))) + #'(syntax1* ... syntax2* ...)) + #; + (syntax-parse syntax1 + [(r1 (unexpand something1)) + (syntax-parse syntax2 + [(r2 (unexpand2 something2)) + (with-syntax ([(syntax1* ...) #'something1] + [(syntax2* ...) #'something2]) + #'(%racket (unexpand (syntax1* ... syntax2* ...))))])])) ;; creates a new syntax/parse pattern (provide honu-pattern) diff --git a/collects/honu/core/private/operator.rkt b/collects/honu/core/private/operator.rkt index 9745be3fae..25be5ad196 100644 --- a/collects/honu/core/private/operator.rkt +++ b/collects/honu/core/private/operator.rkt @@ -27,11 +27,11 @@ (lambda (left right) (with-syntax ([left (honu->racket left)] [right (honu->racket right)]) - #'(%racket (operator left right)))) + (racket-syntax (operator (let () left) (let () right))))) ;; unary (lambda (argument) (with-syntax ([argument (honu->racket argument)]) - #'(%racket (operator argument)))))) + (racket-syntax (operator (let () argument))))))) (define-syntax-rule (define-unary-operator name precedence associativity operator) (define-honu-operator/syntax name precedence associativity @@ -39,7 +39,7 @@ ;; unary (lambda (argument) (with-syntax ([argument (honu->racket argument)]) - #'(%racket (operator argument)))))) + (racket-syntax (operator argument)))))) (define-honu-operator/syntax honu-flow 0.001 'left (lambda (left right) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 617df52bdf..146cd8102b 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -24,6 +24,7 @@ (require (for-template racket/base racket/splicing (only-in "literals.rkt" %racket) + "compile.rkt" "extra.rkt")) (provide parse parse-all) @@ -138,15 +139,6 @@ (loop (cons parsed used) unparsed)))))) -(define parsed-property (gensym 'honu-parsed)) -(define (parsed-syntax syntax) - (if syntax - (syntax-property syntax parsed-property #t) - syntax)) - -(define (parsed-syntax? syntax) - (syntax-property syntax parsed-property)) - (define (stopper? what) (define-literal-set check (honu-comma semicolon colon)) (define is (and (identifier? what) @@ -158,6 +150,7 @@ (define (do-parse-rest stx parse-more) (syntax-parse stx [(stuff ...) + (debug "Parse rest ~a\n" (syntax->datum #'(stuff ...))) (define-values (parsed unparsed) (parse (strip-stops #'(stuff ...)))) (debug "Parse more: ~a unparsed ~a\n" parsed unparsed) @@ -181,12 +174,23 @@ #'(define-syntax (name stx) (syntax-case stx () [(_ stuff (... ...)) + (debug "Properties on first element ~a\n" (syntax-property-symbol-keys (stx-car #'(stuff (... ...))))) (do-parse-rest #'(stuff (... ...)) #'name)])))) (with-syntax ([local local-parser] + #; [parsed (do-parse-rest stx name)]) - (with-syntax ([(stx ...) stx] + (with-syntax ([stx stx] [name name]) - #'(begin local (name stx ...))))) + (debug "Create local parser for ~a properties ~a\n" (syntax->datum #'stx) (syntax-property-symbol-keys #'stx)) + ;; sort of a hack, if the input is already parsed then don't deconstruct it + ;; otherwise the input is a honu expression so we need to splice it in + (define with-local + (if (parsed-syntax? #'stx) + #'(begin local (unexpand-honu-syntax (name stx))) + (with-syntax ([(inside ...) #'stx]) + #'(begin local (unexpand-honu-syntax (name inside ...)))))) + (emit-local-step #'stx with-local #:id #'do-parse-rest/local) + (parsed-syntax with-local)))) #| (provide do-parse-rest-macro) @@ -256,7 +260,8 @@ ((syntax-local-value head) (with-syntax ([head head] [(rest ...) rest]) - (datum->syntax #'head (syntax->list #'(head rest ...)) + (datum->syntax #'head + (syntax->list #'(head rest ...)) #'head #'head)) #f)]) #; @@ -271,7 +276,8 @@ precedence left current) (define re-parse (with-syntax ([(x ...) #'parsed]) - (do-parse-rest/local #'(x ...)))) + (debug "Properties on parsed ~a\n" (syntax-property-symbol-keys #'parsed)) + (do-parse-rest/local #'parsed))) (debug "Reparsed ~a\n" (pretty-format (syntax->datum re-parse))) #; (define re-parse (let-values ([(re-parse re-unparse) @@ -287,6 +293,7 @@ (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) @@ -299,9 +306,12 @@ [pattern x:str] [pattern x:number]) - (debug "parse ~a precedence ~a left ~a current ~a\n" - (syntax->datum stream) precedence left current) + (debug "parse ~a precedence ~a left ~a current ~a properties ~a\n" + (syntax->datum stream) precedence left current + (syntax-property-symbol-keys stream)) (define final (if current current #f)) + (if (parsed-syntax? stream) + (values (left stream) #'()) (syntax-parse stream #:literal-sets (cruft) #; [x:id (values #'x #'())] @@ -340,6 +350,7 @@ (do-macro #'head #'(rest ...) precedence left current stream)] [(parsed-syntax? #'head) (debug "Parsed syntax ~a\n" #'head) + (emit-local-step #'head #'head #:id #'do-parse) (do-parse #'(rest ...) precedence left #'head)] [(honu-fixture? #'head) (debug 2 "Fixture ~a\n" #'head) @@ -419,7 +430,7 @@ [(left:no-left function:honu-function . rest) (values #'function.result #'rest)] [else - (debug "Parse a single thing ~a\n" #'head) + (debug "Parse a single thing ~a\n" (syntax->datum #'head)) (syntax-parse #'head #:literal-sets (cruft) [(%racket x) @@ -513,7 +524,7 @@ #'(current parsed-args ...)))) #; (error 'parse "function call")] - [else (error 'what "dont know how to parse ~a" #'head)])])])])) + [else (error 'what "dont know how to parse ~a" #'head)])])])]))) (define-values (parsed unparsed) (do-parse input 0 (lambda (x) x) #f)) @@ -541,6 +552,7 @@ (with-syntax ([(use ...) (reverse (if parsed (cons parsed all) all))]) + (emit-remark "Parsed all" #'(begin use ...)) #'(begin use ...)) (loop (cons parsed all) unparsed)))) @@ -561,8 +573,11 @@ (define-values (parsed unparsed) (parse stx)) (debug "parsed ~a\n" (if parsed (syntax->datum parsed) parsed)) - (list (parsed-things stx unparsed) (with-syntax ([parsed parsed]) - #'(%racket parsed))))) + (list (parsed-things stx unparsed) + (parsed-syntax parsed) + #; + (with-syntax ([parsed parsed]) + #'(%racket parsed))))) (provide honu-identifier) (define-splicing-syntax-class honu-identifier