From 6b6ca7a7c36816baf5fdaa2d2322c491e661431b Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 10 Nov 2011 11:57:45 -0700 Subject: [PATCH] [honu] allow %racket expressions to remain inside honu syntax and remove them after parsing --- collects/honu/core/private/class.rkt | 2 +- .../honu/core/private/honu-typed-scheme.rkt | 14 +++++++- collects/honu/core/private/honu2.rkt | 32 ++++++++----------- collects/honu/core/private/literals.rkt | 7 ++-- collects/honu/core/private/parse2.rkt | 23 +++++++++---- collects/honu/private/common.rkt | 12 ++----- 6 files changed, 49 insertions(+), 41 deletions(-) diff --git a/collects/honu/core/private/class.rkt b/collects/honu/core/private/class.rkt index 968d005e8f..5e36c603b5 100644 --- a/collects/honu/core/private/class.rkt +++ b/collects/honu/core/private/class.rkt @@ -34,7 +34,7 @@ (lambda (code context) (syntax-parse code #:literal-sets (cruft) [(_ name (#%parens arg:honu-expression ...) . rest) - (define new #'(%racket (make-object name arg.result ...))) + (define new #'(make-object name arg.result ...)) (values new #'rest diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-scheme.rkt index e252b70e72..d811d30dfd 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -452,6 +452,17 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt (define-for-syntax (honu-compile forms) #'(void)) +(define-for-syntax (honu->racket forms) + (define-literal-set literals (%racket)) + ;; (debug "honu to racket ~a\n" (pretty-format (syntax->datum forms))) + (syntax-parse forms #:literal-sets (literals) + [(%racket x) (honu->racket #'x)] + [(form ...) + (with-syntax ([(form* ...) (map honu->racket (syntax->list #'(form ...)))]) + #'(form* ...))] + [x #'x] + [() forms])) + (define-syntax (honu-unparsed-begin stx) (emit-remark "Honu unparsed begin!" stx) (debug "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level)) @@ -465,8 +476,9 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt ;; if parsed is #f then we don't want to expand to anything that will print ;; so use an empty form, begin, `parsed' could be #f becuase there was no expression ;; in the input such as parsing just ";". - (with-syntax ([parsed (if (not parsed) #'(begin) parsed)] + (with-syntax ([parsed (if (not parsed) #'(begin) (honu->racket parsed))] [(unparsed ...) unparsed]) + (debug "Final parsed syntax ~a\n" (syntax->datum #'parsed)) (if (null? (syntax->datum #'(unparsed ...))) #'parsed #'(begin parsed (honu-unparsed-begin unparsed ...))))])) diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index b691e570ab..a0fbc56aef 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -11,9 +11,9 @@ honu-in honu-prefix semicolon - %racket - %racket-expression) + %racket) (for-syntax syntax/parse + "debug.rkt" "literals.rkt" "parse2.rkt" racket/base)) @@ -28,7 +28,7 @@ (#%braces code ...) . rest) (values - #'(%racket-expression (lambda (arg ...) + #'(%racket (lambda (arg ...) (let-syntax ([do-parse (lambda (stx) (parse-all #'(code ...)))]) (do-parse)))) @@ -41,8 +41,7 @@ (syntax-parse code #:literal-sets (cruft) #:literals (honu-=) [(_ name:id honu-= one:honu-expression . rest) - (values (with-syntax ([one-parsed (parse-all #'one.result)]) - #'(%racket (define name one-parsed))) + (values #'(%racket (define name one.result)) #'rest #t)]))) @@ -54,12 +53,9 @@ [(_ iterator:id honu-= start:honu-expression honu-to end:honu-expression honu-do body:honu-expression . rest) (values - (with-syntax ([start-parsed (parse-all #'start.result)] - [end-parsed (parse-all #'end.result)] - [body-parsed (parse-all #'body.result)]) - #'(%racket (for ([iterator (in-range start-parsed - end-parsed)]) - body-parsed))) + #'(%racket (for ([iterator (in-range start.result + end.result)]) + body.result)) #'rest #t)] [(_ iterator:id honu-in stuff:honu-expression @@ -76,10 +72,7 @@ #:literals (else honu-then) [(_ condition:honu-expression honu-then true:honu-expression else false:honu-expression . rest) (values - (with-syntax ([condition-parsed (parse-all #'condition.result)] - [true-parsed (parse-all #'true.result)] - [false-parsed (parse-all #'false.result)]) - #'(%racket-expression (if condition-parsed true-parsed false-parsed))) + #'(%racket (if condition.result true.result false.result)) #'rest #f)]))) @@ -97,14 +90,14 @@ (lambda (code context) (syntax-parse code [(_ expression rest ...) - (values #'(%racket-expression (quote expression)) #'(rest ...) #f)]))) + (values #'(%racket (quote expression)) #'(rest ...) #f)]))) (provide honu-quasiquote) (define-honu-syntax honu-quasiquote (lambda (code context) (syntax-parse code [(_ expression rest ...) - (values #'(%racket-expression (quasiquote expression)) + (values #'(%racket (quasiquote expression)) #'(rest ...) #f)]))) @@ -135,9 +128,10 @@ (provide honu-dot) (define-honu-operator/syntax honu-dot 10000 'left (lambda (left right) + (debug "dot left ~a right ~a\n" left right) (with-syntax ([left left] [right right]) - #'(%racket-expression + #'(%racket (let ([left* left]) (cond [(honu-struct? left*) (let ([use (honu-struct-get left*)]) @@ -218,7 +212,7 @@ (lambda (code context) (syntax-parse code #:literal-sets (cruft) [(_ (#%parens name:id) something:honu-expression . rest) - (define with #'(%racket-expression (with-input-from-file name (lambda () something.result)))) + (define with #'(%racket (with-input-from-file name (lambda () something.result)))) (values with #'rest diff --git a/collects/honu/core/private/literals.rkt b/collects/honu/core/private/literals.rkt index 932bff8226..04acac5cbb 100644 --- a/collects/honu/core/private/literals.rkt +++ b/collects/honu/core/private/literals.rkt @@ -10,7 +10,7 @@ (begin (define-syntax name (lambda (stx) (raise-syntax-error 'name - "this is a literal and cannot be used outside a macro"))) + "this is a literal and cannot be used outside a macro" (syntax->datum stx)))) ...)) (define-literal honu-return) @@ -30,8 +30,7 @@ honu-for-syntax honu-for-template honu-prefix - %racket - %racket-expression) + %racket) (define-syntax-rule (define-literal+set set literal ...) (begin @@ -40,5 +39,5 @@ (define-literal-set set (literal ...))))) (define-literal-set cruft (#%parens #%brackets #%braces - %racket %racket-expression + %racket semicolon colon honu-comma honu-<-)) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 284d544de5..22c373eb55 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -18,10 +18,10 @@ ;; phase -1 (require (for-template racket/base racket/splicing - (only-in "literals.rkt" %racket-expression) + (only-in "literals.rkt" %racket) "extra.rkt")) -(provide parse parse-all parse-all) +(provide parse parse-all) #; (define-literal-set literals @@ -194,12 +194,12 @@ [(rest ...) rest]) #'(head rest ...)) #f)]) - (with-syntax ([(parsed ...) parsed] - [(rest ...) unparsed]) - (debug "Output from macro ~a\n" (pretty-format (syntax->datum #'(parsed ...)))) + (with-syntax ([parsed parsed] + [rest unparsed]) + (debug "Output from macro ~a\n" (pretty-format (syntax->datum #'parsed))) + #; (do-parse #'(parsed ... rest ...) precedence left current) - #; (if terminate? (values (left #'parsed) #'rest) @@ -214,20 +214,25 @@ (debug "parse ~a precedence ~a left ~a current ~a\n" (syntax->datum stream) precedence left current) (define final (if current current #f)) (syntax-parse stream #:literal-sets (cruft) + #; + [x:id (values #'x #'())] [() (values (left final) #'())] ;; dont reparse pure racket code + #; [(%racket racket rest ...) (if current (values (left current) stream) (values (left #'racket) #'(rest ...)))] ;; for expressions that can keep parsing + #; [((%racket-expression racket) rest ...) (if current (values (left current) stream) (do-parse #'(rest ...) precedence left #'racket))] + #; [(%racket-expression racket rest ...) (if current (values (left current) stream) @@ -295,6 +300,10 @@ #'rest)] [else (syntax-parse #'head #:literal-sets (cruft) + [(%racket rest ...) + (if current + (values (left current) stream) + (do-parse #'(rest ...) precedence left #'head))] [x:atom (debug "atom ~a current ~a\n" #'x current) (if current @@ -418,7 +427,7 @@ (parse stx)) (debug "parsed ~a\n" (if parsed (syntax->datum parsed) parsed)) (list (parsed-things stx unparsed) (with-syntax ([parsed parsed]) - #'(%racket-expression parsed))))) + #'(%racket parsed))))) (provide identifier-comma-list) (define-splicing-syntax-class identifier-comma-list diff --git a/collects/honu/private/common.rkt b/collects/honu/private/common.rkt index 88a2752b6b..4d95647a0c 100644 --- a/collects/honu/private/common.rkt +++ b/collects/honu/private/common.rkt @@ -17,14 +17,8 @@ [(_ (~seq clause:honu-expression colon body:honu-expression (~optional honu-comma)) ... . rest) (values - (with-syntax ([(clause-parsed ...) (map (lambda (clause) - (parse-all clause)) - (syntax->list #'(clause.result ...)))] - [(body-parsed ...) (map (lambda (body) - (parse-all body)) - (syntax->list #'(body.result ...)))]) - #'(%racket-expression (cond - [clause-parsed body-parsed] - ...))) + #'(%racket (cond + [clause.result body.result] + ...)) #'rest #t)])))