diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index f8152e879c..de75c11c25 100644 --- a/collects/honu/main.rkt +++ b/collects/honu/main.rkt @@ -1,10 +1,12 @@ #lang scheme/base +(require (for-syntax scheme/base)) (require scheme/class) (require "private/honu-typed-scheme.ss" ;; "private/honu.ss" "private/parse.ss" + (for-syntax "private/literals.ss") "private/literals.ss" "private/syntax.ss" "private/macro.ss") @@ -30,6 +32,9 @@ (honu-. |.|) ) #%datum + (for-syntax #%datum + (rename-out (semicolon \; + ))) #%braces #%parens x @@ -37,6 +42,7 @@ false display display2 + (for-syntax display) newline else foobar2000 diff --git a/collects/honu/private/honu-typed-scheme.rkt b/collects/honu/private/honu-typed-scheme.rkt index 8d9f840e8f..c2eee9fa32 100644 --- a/collects/honu/private/honu-typed-scheme.rkt +++ b/collects/honu/private/honu-typed-scheme.rkt @@ -22,7 +22,6 @@ (provide (all-defined-out)) - ;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx)) (begin-for-syntax @@ -477,8 +476,6 @@ if (foo){ (define (display2 x y) (printf "~a ~a" x y)) - - (define-syntax (honu-unparsed-begin stx) (printf "honu unparsed begin: ~a\n" (syntax->datum stx)) (syntax-case stx () diff --git a/collects/honu/private/macro.rkt b/collects/honu/private/macro.rkt index c82c4a773e..e048c28b1d 100644 --- a/collects/honu/private/macro.rkt +++ b/collects/honu/private/macro.rkt @@ -7,6 +7,8 @@ ;; (for-template "syntax.ss") (for-syntax "debug.ss" "contexts.ss" + "parse.ss" + "honu-typed-scheme.ss" scheme/base syntax/parse syntax/stx @@ -392,10 +394,29 @@ (with-syntax ([pulled (pull #'(x ...))]) #'(unpull pulled)))])) - - (define-honu-syntax honu-macro (lambda (stx ctx) + (define-syntax-class honu-macro2 + #:literals (#%parens #%braces) + [pattern (_ name (#%braces code ...) + . rest) + #:with result + (list + (syntax/loc stx + (define-honu-syntax name + (lambda (stx ctx) + (honu-unparsed-begin code ...)))) + #; + (with-syntax ([parsed (let-values ([(out rest*) + (parse-block-one/2 #'(code ...) + the-expression-context)]) + out)]) + (syntax/loc stx + (define-honu-syntax name + (lambda (stx ctx) + parsed)))) + #'rest)]) + (define-syntax-class honu-macro1 #:literals (#%parens #%braces) [pattern (_ (#%parens honu-literal ...) @@ -465,6 +486,7 @@ (printf "Executing honu macro\n") (syntax-parse stx #:literals (#%parens #%braces) [out:honu-macro1 (apply (lambda (a b) (values a b)) (syntax->list (attribute out.result)))] + [out:honu-macro2 (apply (lambda (a b) (values a b)) (syntax->list (attribute out.result)))] #; [(_ (#%parens honu-literal ...)