diff --git a/collects/honu/core/private/class.rkt b/collects/honu/core/private/class.rkt index be03516a69..968d005e8f 100644 --- a/collects/honu/core/private/class.rkt +++ b/collects/honu/core/private/class.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "macro2.rkt" + "literals.rkt" (for-syntax racket/base "literals.rkt" "parse2.rkt" @@ -22,21 +23,18 @@ (syntax-parse code #:literal-sets (cruft) [(_ name (#%parens constructor-argument ...) (#%braces method:honu-class-method ...) . rest) (define class - #'(define name (class* object% () - (super-new) - (init-field constructor-argument ...) - method.result ...))) - (values - class - #'rest - #t)]))) + #'(%racket (define name (class* object% () + (super-new) + (init-field constructor-argument ...) + method.result ...)))) + (values class #'rest #t)]))) (provide honu-new) (define-honu-syntax honu-new (lambda (code context) (syntax-parse code #:literal-sets (cruft) [(_ name (#%parens arg:honu-expression ...) . rest) - (define new #'(make-object name arg.result ...)) + (define new #'(%racket (make-object name arg.result ...))) (values new #'rest diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index 284db1ac5e..cb2c4f9e41 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -10,7 +10,9 @@ honu-then honu-in honu-prefix - semicolon) + semicolon + %racket + %racket-expression) (for-syntax syntax/parse "literals.rkt" "parse2.rkt" @@ -26,10 +28,10 @@ (#%braces code ...) . rest) (values - #'(lambda (arg ...) - (let-syntax ([do-parse (lambda (stx) - (parse-all #'(code ...)))]) - (do-parse))) + #'(%racket-expression (lambda (arg ...) + (let-syntax ([do-parse (lambda (stx) + (parse-all #'(code ...)))]) + (do-parse)))) #'rest #f)]))) @@ -39,20 +41,9 @@ (syntax-parse code #:literal-sets (cruft) #:literals (honu-=) [(_ name:id honu-= one:honu-expression . rest) - (values #'(define name one.result) + (values #'(%racket (define name one.result)) #'rest - #t) - ;; parse one expression - #; - (define-values (parsed unparsed) - (parse #'rest)) - #; - (values - (with-syntax ([parsed parsed]) - #'(define name parsed)) - (with-syntax ([unparsed unparsed]) - #'unparsed) - #t)]))) + #t)]))) (provide honu-for) (define-honu-syntax honu-for @@ -62,14 +53,14 @@ [(_ iterator:id honu-= start:honu-expression honu-to end:honu-expression honu-do body:honu-expression . rest) (values - #'(for ([iterator (in-range start.result end.result)]) - body.result) + #'(%racket (for ([iterator (in-range start.result end.result)]) + body.result)) #'rest #t)] [(_ iterator:id honu-in stuff:honu-expression honu-do body:honu-expression . rest) - (values #'(for ([iterator stuff.result]) - body.result) + (values #'(%racket (for ([iterator stuff.result]) + body.result)) #'rest #t)]))) @@ -80,7 +71,7 @@ #:literals (else honu-then) [(_ condition:honu-expression honu-then true:honu-expression else false:honu-expression . rest) (values - #'(if condition.result true.result false.result) + #'(%racket-expression (if condition.result true.result false.result)) #'rest #f)]))) @@ -98,14 +89,14 @@ (lambda (code context) (syntax-parse code [(_ expression rest ...) - (values #'(quote expression) #'(rest ...) #f)]))) + (values #'(%racket-expression (quote expression)) #'(rest ...) #f)]))) (provide honu-quasiquote) (define-honu-syntax honu-quasiquote (lambda (code context) (syntax-parse code [(_ expression rest ...) - (values #'(quasiquote expression) + (values #'(%racket-expression (quasiquote expression)) #'(rest ...) #f)]))) @@ -138,14 +129,15 @@ (lambda (left right) (with-syntax ([left left] [right right]) - #'(let ([left* left]) - (cond - [(honu-struct? left*) (let ([use (honu-struct-get left*)]) - (use left* 'right))] - [(object? left*) (lambda args - (send/apply left* right args))] - ;; possibly handle other types of data - [else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)]))))) + #'(%racket-expression + (let ([left* left]) + (cond + [(honu-struct? left*) (let ([use (honu-struct-get left*)]) + (use left* 'right))] + [(object? left*) (lambda args + (send/apply left* right args))] + ;; possibly handle other types of data + [else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)])))))) (provide honu-flow) (define-honu-operator/syntax honu-flow 0.001 'left @@ -204,11 +196,11 @@ (syntax-parse code [(_ form:require-form ... . rest) (values - #'(require (filtered-in (lambda (name) + #'(%racket (require (filtered-in (lambda (name) (regexp-replace* #rx"-" (regexp-replace* #rx"->" name "_to_") "_")) - (combine-in form.result ...))) + (combine-in form.result ...)))) #'rest #f)]))) @@ -218,7 +210,7 @@ (lambda (code context) (syntax-parse code #:literal-sets (cruft) [(_ (#%parens name:id) something:honu-expression . rest) - (define with #'(with-input-from-file name (lambda () something.result))) + (define with #'(%racket-expression (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 8753038112..932bff8226 100644 --- a/collects/honu/core/private/literals.rkt +++ b/collects/honu/core/private/literals.rkt @@ -29,7 +29,9 @@ honu-in honu-for-syntax honu-for-template - honu-prefix) + honu-prefix + %racket + %racket-expression) (define-syntax-rule (define-literal+set set literal ...) (begin @@ -37,4 +39,6 @@ (begin-for-syntax (define-literal-set set (literal ...))))) -(define-literal-set cruft (#%parens #%brackets #%braces semicolon colon honu-comma honu-<-)) +(define-literal-set cruft (#%parens #%brackets #%braces + %racket %racket-expression + semicolon colon honu-comma honu-<-)) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index a720ad27c7..75a9c1b337 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -174,33 +174,55 @@ ;; parse one form ;; return the parsed stuff and the unparsed stuff (define (parse input) + (define (do-macro head rest precedence left current stream) + (if current + (values (left current) stream) + (begin + (debug "Honu macro ~a\n" head) + (let-values ([(parsed unparsed terminate?) + ((syntax-local-value head) + (with-syntax ([head head] + [(rest ...) rest]) + #'(head rest ...)) + #f)]) + (with-syntax ([(parsed ...) parsed] + [(rest ...) unparsed]) + (debug "Output from macro ~a\n" #'(parsed ...)) + (do-parse #'(parsed ... rest ...) + precedence left current) + #; + (if terminate? + (values (left #'parsed) + #'rest) + (do-parse #'rest precedence + left #'parsed))))))) (define (do-parse stream precedence left current) (define-syntax-class atom [pattern x:identifier] [pattern x:str] [pattern x:number]) - (debug "parse ~a precedence ~a left ~a current ~a\n" stream precedence left current) + (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) [() (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))] [(head rest ...) (cond [(honu-macro? #'head) - (if current - (values (left current) stream) - (begin - (debug "Honu macro ~a\n" #'head) - (let-values ([(parsed unparsed terminate?) - ((syntax-local-value #'head) #'(head rest ...) #f)]) - (with-syntax ([parsed parsed] - [rest unparsed]) - (if terminate? - (values (left #'parsed) - #'rest) - (do-parse #'rest precedence - left #'parsed))))))] + (do-macro #'head #'(rest ...) precedence left current stream)] [(parsed-syntax? #'head) (do-parse #'(rest ...) precedence left #'head)] [(honu-operator? #'head) diff --git a/collects/honu/core/private/struct.rkt b/collects/honu/core/private/struct.rkt index f472d94f24..311faa0833 100644 --- a/collects/honu/core/private/struct.rkt +++ b/collects/honu/core/private/struct.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "macro2.rkt" + "literals.rkt" (for-syntax racket/base "parse2.rkt" "literals.rkt" @@ -23,12 +24,12 @@ (define out (with-syntax ([(fields.name/accessor ...) (make-accessors #'name (syntax->list #'(fields.name ...)))]) - #'(struct name (fields.name ...) - #:transparent - #:property honu-struct (lambda (instance name) - (case name - [(fields.name) (fields.name/accessor instance)] - ... - [else (error 'dot "no such field name ~a" name)]))))) + #'(%racket (struct name (fields.name ...) + #:transparent + #:property honu-struct (lambda (instance name) + (case name + [(fields.name) (fields.name/accessor instance)] + ... + [else (error 'dot "no such field name ~a" name)])))))) (values out #'rest #t)]))) diff --git a/collects/honu/private/common.rkt b/collects/honu/private/common.rkt index 5940d9393f..ef4c116d07 100644 --- a/collects/honu/private/common.rkt +++ b/collects/honu/private/common.rkt @@ -1,6 +1,7 @@ #lang racket/base (require honu/core/private/macro2 + honu/core/private/literals (for-syntax syntax/parse racket/base honu/core/private/literals @@ -16,7 +17,8 @@ [(_ (~seq clause:honu-expression colon body:honu-expression (~optional honu-comma)) ... . rest) (values - #'(cond - [clause.result body.result] ...) + #'(%racket-expression (cond + [clause.result body.result] + ...)) #'rest #t)]))) diff --git a/collects/tests/honu/linq.rkt b/collects/tests/honu/linq.rkt index d073a913a5..f88fda685e 100644 --- a/collects/tests/honu/linq.rkt +++ b/collects/tests/honu/linq.rkt @@ -36,9 +36,9 @@ #'(sort store.result string