From 48529040350e3d3ab97c33b23c20b7d021e759aa Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 21 Feb 2012 16:18:50 -0700 Subject: [PATCH] [honu] wrap expressions with let so local macro parsers can be defined. replace more usages of %racket with racket-syntax --- collects/honu/core/private/class.rkt | 7 +++-- collects/honu/core/private/honu2.rkt | 37 ++++++++++++------------- collects/honu/core/private/operator.rkt | 7 ++--- collects/honu/core/private/parse2.rkt | 16 ++++++----- 4 files changed, 34 insertions(+), 33 deletions(-) diff --git a/collects/honu/core/private/class.rkt b/collects/honu/core/private/class.rkt index 4d6fe7fca4..484ad224fb 100644 --- a/collects/honu/core/private/class.rkt +++ b/collects/honu/core/private/class.rkt @@ -5,6 +5,7 @@ (only-in "operator.rkt" honu-equal) (only-in "honu2.rkt" honu-declaration separate-ids) (for-syntax racket/base + "compile.rkt" "literals.rkt" "parse2.rkt" "util.rkt" @@ -15,7 +16,7 @@ (define (replace-with-public method) (syntax-parse method #:literals (define) [(define (name args ...) body ...) - #'(define/public (name args ...) body ...)])) + (racket-syntax (define/public (name args ...) body ...))])) (define-literal-set equals (honu-equal)) (define-splicing-syntax-class honu-class-thing #:literal-sets (equals) @@ -32,7 +33,7 @@ [(_ name (#%parens (~var constructor-argument (separate-ids (literal-syntax-class honu-comma) (literal-syntax-class honu-comma)))) (#%braces method:honu-class-thing ...) . rest) (define class - #'(%racket (define name (class* object% () + (racket-syntax (define name (class* object% () (super-new) (init-field constructor-argument.id ...) method.result ...)))) @@ -43,7 +44,7 @@ (lambda (code context) (syntax-parse code #:literal-sets (cruft) [(_ name (#%parens arg:honu-expression/comma) . rest) - (define new #'(%racket (make-object name arg.result ...))) + (define new (racket-syntax (make-object name (let () arg.result) ...))) (values new (local-binding rest) diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index 9e3af05265..4ee011bd68 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -14,8 +14,7 @@ honu-prefix semicolon honu-comma - define-literal - %racket) + define-literal) (for-syntax syntax/parse syntax/parse/experimental/reflect syntax/parse/experimental/splicing @@ -49,14 +48,14 @@ [(_ name:identifier (#%parens (~seq arg:identifier (~optional honu-comma)) ...) (#%braces code ...) . rest) (values - #'(%racket (define (name arg ...) (parse-body code ...))) + (racket-syntax (define (name arg ...) (parse-body code ...))) #'rest #f)] [(_ (#%parens (~seq arg:identifier (~optional honu-comma)) ...) (#%braces code ...) . rest) (values - #'(%racket (lambda (arg ...) + (racket-syntax (lambda (arg ...) (parse-body code ...))) #'rest #f)]))) @@ -69,7 +68,7 @@ [(_ (#%parens condition:honu-expression) true:honu-expression (~optional else) false:honu-expression . rest) (values - (racket-syntax (if condition.result true.result false.result)) + (racket-syntax (if (let () condition.result) (let () true.result) (let () false.result))) #'rest #f)]))) @@ -87,14 +86,14 @@ (lambda (code context) (syntax-parse code [(_ expression rest ...) - (values #'(%racket (quote expression)) #'(rest ...) #f)]))) + (values (racket-syntax (quote expression)) #'(rest ...) #f)]))) (provide honu-quasiquote) (define-honu-syntax honu-quasiquote (lambda (code context) (syntax-parse code [(_ expression rest ...) - (values #'(%racket (quasiquote expression)) + (values (racket-syntax (quasiquote expression)) #'(rest ...) #f)]))) @@ -130,7 +129,7 @@ (debug "Parsed ~a unparsed ~a\n" parsed unparsed) (list (parsed-things stx unparsed) (with-syntax ([parsed parsed]) - #'(%racket parsed))))) + (racket-syntax parsed))))) ) ;; begin-for-syntax @@ -140,7 +139,7 @@ (syntax-parse code [(_ name:id level:number association:honu-expression function:honu-expression/phase+1 . rest) (debug "Operator function ~a\n" (syntax->datum #'function.result)) - (define out #'(%racket (define-honu-operator/syntax name level association.result function.result))) + (define out (racket-syntax (define-honu-operator/syntax name level association.result function.result))) (values out #'rest #t)]))) (provide honu-dot) @@ -152,7 +151,7 @@ #:literals (honu-equal) [pattern (_ name:identifier honu-equal argument:honu-expression . more) #:with result (with-syntax ([left left]) - #'(%racket + (racket-syntax (let ([left* left]) (cond [(honu-struct? left*) @@ -165,7 +164,7 @@ #:literals (honu-equal) [pattern (_ name:identifier . more) #:with result (with-syntax ([left left]) - #'(%racket + (racket-syntax (let ([left* left]) (cond [(honu-struct? left*) (let ([use (honu-struct-get left*)]) @@ -184,7 +183,7 @@ (debug "dot left ~a right ~a\n" left right) (with-syntax ([left left] [right right]) - #'(%racket + (racket-syntax (let ([left* left]) (cond [(honu-struct? left*) (let ([use (honu-struct-get left*)]) @@ -217,7 +216,7 @@ (syntax-parse code [(_ form:require-form ... . rest) (values - #'(%racket (require (filtered-in (lambda (name) + (racket-syntax (require (filtered-in (lambda (name) (regexp-replace* #rx"-" (regexp-replace* #rx"->" name "_to_") "_")) @@ -240,7 +239,7 @@ (lambda (code context) (syntax-parse code #:literal-sets (cruft) [(_ file:honu-expression something:honu-expression . rest) - (define with #'(%racket (with-input-from-file file.result + (define with (racket-syntax (with-input-from-file file.result (lambda () something.result)))) (values with @@ -253,7 +252,7 @@ (syntax-parse code #:literal-sets (cruft) [(_ condition:honu-expression body:honu-body . rest) (values - #'(%racket (let loop () + (racket-syntax (let loop () body.result (when condition.result (loop)))) #'rest @@ -277,7 +276,7 @@ #:literals (honu-with) [(_ thing:honu-expression honu-with clause:match-clause ... . rest) (values - #'(%racket (match thing.result + (racket-syntax (match thing.result [clause.final clause.code] ...)) #'rest @@ -345,7 +344,7 @@ #:literals (honu-->) [(_ (~seq name:id honu--> data:honu-expression (~optional honu-comma)) ... (#%braces code ...) . rest) - (define out #'(%racket (with-syntax ([name data.result] ...) + (define out (racket-syntax (with-syntax ([name data.result] ...) (parse-body code ...)))) (values out #'rest #t)]))) @@ -362,7 +361,7 @@ honu-do body:honu-expression . rest) (values (with-syntax ([(stuff.result ...) (map honu->racket (syntax->list #'(stuff.result ...)))] [body.result (honu->racket #'body.result)]) - #'(%racket (for ([iterator stuff.result] ...) + (racket-syntax (for ([iterator stuff.result] ...) body.result))) #'rest #t)]))) @@ -383,7 +382,7 @@ [(_ (~seq init:id honu-equal init-expression:honu-expression (~optional honu-comma)) ... (~seq sequence:sequence-expression (~optional honu-comma)) ... honu-do body:honu-expression . rest) - (values #'(%racket (for/fold ([init init-expression.result] ...) + (values (racket-syntax (for/fold ([init init-expression.result] ...) ([sequence.variable sequence.expression] ...) body.result)) #'rest diff --git a/collects/honu/core/private/operator.rkt b/collects/honu/core/private/operator.rkt index 25be5ad196..a9d87cabb4 100644 --- a/collects/honu/core/private/operator.rkt +++ b/collects/honu/core/private/operator.rkt @@ -4,8 +4,7 @@ "transformer.rkt" "fixture.rkt" "compile.rkt" - syntax/parse) - (only-in "literals.rkt" %racket)) + syntax/parse)) (provide (all-defined-out)) @@ -45,14 +44,14 @@ (lambda (left right) (with-syntax ([left (honu->racket left)] [right (honu->racket right)]) - #'(%racket (right left))))) + (racket-syntax (right left))))) (begin-for-syntax (define-syntax-rule (mutator change) (lambda (left right) (with-syntax ([left (honu->racket left)] [right (change left (honu->racket right))]) - #'(%racket (set! left right)))))) + (racket-syntax (set! left right)))))) ;; Traditional assignment operator (define-honu-operator/syntax honu-equal 0.0001 'left diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 146cd8102b..ff83ad91b4 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -204,10 +204,12 @@ (define-syntax-class honu-body #:literal-sets (cruft) [pattern (#%braces code ...) - #:with result #'(let () + #:with result (racket-syntax (let () (define-syntax (parse-more stx) - (do-parse-rest stx #'parse-more)) - (parse-more code ...))]) + (syntax-case stx () + [(_ stuff (... ...)) + (do-parse-rest #'(stuff (... ...)) #'parse-more)])) + (parse-more code ...)))]) (provide honu-function) (define-splicing-syntax-class honu-function #:literal-sets (cruft) @@ -215,8 +217,8 @@ #:with result (with-syntax ([(parsed-arguments ...) (parse-arguments #'(args ...))]) - #'(define (function parsed-arguments ...) - body.result))]) + (racket-syntax (define (function parsed-arguments ...) + body.result)))]) ;; E = macro ;; | E operator E @@ -495,7 +497,7 @@ (define call (with-syntax ([current (left current)] [(parsed-args ...) (parse-comma-expression #'(args ...)) ]) - #'(current parsed-args ...))) + #'(current (let () parsed-args) ...))) (do-parse #'(rest ...) 9000 (lambda (x) x) call)) (let () (debug 2 "function call ~a\n" left) @@ -503,7 +505,7 @@ [(parsed-args ...) (parse-comma-expression #'(args ...)) ]) (debug "Parsed args ~a\n" #'(parsed-args ...)) - #'(current parsed-args ...))) + #'(current (let () parsed-args) ...))) (do-parse #'(rest ...) precedence left call))) (let () (debug "inner expression ~a\n" #'(args ...))