diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 74c6f94f58..625f4a7a92 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -2,13 +2,18 @@ (require "private/honu-typed-scheme.rkt" "private/honu2.rkt" + "private/macro2.rkt" + (for-syntax (only-in "private/parse2.rkt" honu-expression)) (prefix-in literal: "private/literals.rkt")) (provide #%top #%datum print printf true false + (for-syntax (rename-out [honu-expression expression])) (rename-out [#%dynamic-honu-module-begin #%module-begin] [honu-function function] + [honu-macro macro] + [honu-syntax syntax] [honu-var var] [honu-val val] [honu-for for] @@ -21,6 +26,7 @@ [honu-> >] [honu-< <] [honu->= >=] [honu-<= <=] [honu-= =] + [honu-assignment :=] [literal:honu-<- <-] [honu-map map] [honu-flow \|] diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-scheme.rkt index 8113b5e43d..8e4b1fcb98 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -445,21 +445,22 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt #'rest)]))) (define-for-syntax (honu-expand forms) - (parse-all forms)) + (parse-one forms)) (define-for-syntax (honu-compile forms) #'(void)) - (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)) (syntax-parse stx [(_) #'(void)] [(_ forms ...) - (define expanded (honu-expand #'(forms ...))) - (debug "expanded ~a\n" (syntax->datum expanded)) - expanded])) + (define-values (parsed unparsed) (honu-expand #'(forms ...))) + (debug "expanded ~a\n" (syntax->datum parsed)) + (with-syntax ([parsed parsed] + [(unparsed ...) unparsed]) + #'(begin parsed (honu-unparsed-begin unparsed ...)))])) (define-syntax (#%dynamic-honu-module-begin stx) (syntax-case stx () diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 72d3edf7c6..60a799978a 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/define syntax/parse + syntax/stx "literals.rkt" "parse2.rkt" "debug.rkt" @@ -17,30 +18,39 @@ (syntax/loc stx (define-syntax id (make-honu-transformer rhs)))))) -(define-for-syntax (convert-pattern pattern) - (syntax-parse pattern - [(name semicolon class) - #'(~var name class)])) +(define-for-syntax (convert-pattern original-pattern) + (define-splicing-syntax-class pattern-type + #:literal-sets (cruft) + [pattern (~seq name colon class) + #:with result #'(~var name class #:attr-name-separator "_")] + [pattern x #:with result #'x]) + (syntax-parse original-pattern + [(thing:pattern-type ...) + #'(thing.result ...)])) -(provide macro) -(define-honu-syntax macro +(provide honu-macro) +(define-honu-syntax honu-macro (lambda (code context) (debug "Macroize ~a\n" code) (syntax-parse code #:literal-sets (cruft) [(_ name literals (#%braces pattern ...) (#%braces action ...) . rest) (debug "Pattern is ~a\n" #'(pattern ...)) (values - (with-syntax ([syntax-parse-pattern + (with-syntax ([(syntax-parse-pattern ...) (convert-pattern #'(pattern ...))]) #'(define-honu-syntax name (lambda (stx context-name) (syntax-parse stx - [(_ syntax-parse-pattern . more) + [(_ syntax-parse-pattern ... . more) (values #'(let-syntax ([do-parse (lambda (stx) - (parse-all stx))]) + (define what (parse-all (stx-cdr stx))) + (debug "Macro parse all ~a\n" what) + what)]) (do-parse action ...)) - #'more)])))) - #'rest)]))) + #'more + #t)])))) + #'rest + #t)]))) (provide (rename-out [honu-with-syntax withSyntax])) (define-honu-syntax honu-with-syntax @@ -49,3 +59,18 @@ [(_ [#%brackets name:id data] (#%braces code ...)) #'(with-syntax ([name data]) code ...)]))) + +(define-syntax (parse-stuff stx) + (syntax-parse stx + [(_ stuff ...) + (parse-all #'(stuff ...))])) + +(provide honu-syntax) +(define-honu-syntax honu-syntax + (lambda (code context) + (syntax-parse code #:literal-sets (cruft) + [(_ (#%parens stuff ...) . rest) + (values + #'(parse-stuff stuff ...) + #'rest + #f)]))) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 142f60586b..4ac102cc19 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -290,6 +290,10 @@ [() #t] [else #f])) +(provide parse-one) +(define (parse-one code) + (parse (strip-stops code))) + (define (parse-all code) (let loop ([all '()] [code code])