diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index f6291a468d..892ea9ae38 100644 --- a/collects/honu/main.rkt +++ b/collects/honu/main.rkt @@ -14,6 +14,7 @@ "private/literals.ss" "private/syntax.ss" "private/more.ss" + (for-template scheme/base) (for-template "private/literals.rkt") (for-syntax "private/more.ss") (for-syntax "private/syntax.ss") @@ -34,7 +35,7 @@ (define (sql5) #f) (provide (rename-out (#%dynamic-honu-module-begin #%module-begin) - (honu-top #%top) + ;; (honu-top #%top) (semicolon \; ) (honu-+ +) @@ -48,6 +49,8 @@ (honu-. |.|) ) + #%top + ;; sql nonsense (rename-out (sql1 SQL_create_insert) @@ -97,12 +100,15 @@ display2 newline with-syntax + honu-unparsed-begin + (for-template with-syntax) ;; stuff i done want define let ;; end stuff else #%app + (for-template #%app) quote ... foobar2000 diff --git a/collects/honu/private/honu-typed-scheme.rkt b/collects/honu/private/honu-typed-scheme.rkt index f3b7a20268..d5c2a585b1 100644 --- a/collects/honu/private/honu-typed-scheme.rkt +++ b/collects/honu/private/honu-typed-scheme.rkt @@ -8,6 +8,7 @@ syntax/parse syntax/parse/experimental/splicing scheme/splicing + macro-debugger/emit "contexts.ss" "util.ss" "ops.ss" @@ -506,10 +507,11 @@ if (foo){ (define-honu-syntax scheme-syntax (lambda (body ctx) (syntax-parse body - [(_ expr . rest) + [(_ template . rest) (values (lambda () - (apply-scheme-syntax #'#'expr)) + (printf "Applying syntax to ~a\n" (quote-syntax template)) + (apply-scheme-syntax #'#'template)) #'rest)]))) (define-honu-syntax honu-provide @@ -562,6 +564,9 @@ if (foo){ [pattern (~seq x ...) #:with result #'(honu-unparsed-begin x ...)]) (define-syntax (honu-unparsed-begin stx) + (emit-remark "Honu unparsed begin!" stx) + #; + (emit-remark "Honu unparsed begin" stx) (printf "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level)) (syntax-case stx () [(_) #'(void)] diff --git a/collects/honu/private/macro.rkt b/collects/honu/private/macro.rkt index 480a1d2d50..0afbbcbb7b 100644 --- a/collects/honu/private/macro.rkt +++ b/collects/honu/private/macro.rkt @@ -5,6 +5,9 @@ "parse.ss" "syntax.ss" syntax/parse + (for-syntax macro-debugger/emit) + (for-meta 2 macro-debugger/emit + scheme/base) (for-meta -3 (only-in "literals.rkt" (#%parens literal-parens))) #; @@ -454,6 +457,7 @@ (define foobar 0) + (define-honu-syntax honu-macro (lambda (stx ctx) (define-syntax-class honu-macro3 @@ -493,6 +497,7 @@ (syntax/loc stx (define-honu-syntax name (lambda (stx ctx) + #; (printf "Executing macro `~a' on input `~a'\n" 'name (syntax->datum stx)) (syntax-parse stx #:literal-sets ([cruft #:at name]) @@ -503,9 +508,15 @@ (with-syntax ([(real-out (... ...)) #'(code ...)]) (let ([result (honu-unparsed-begin #'(real-out (... ...)))]) (lambda () result))) - (printf "Macro transformer `~a'\n" (syntax->datum #'(code ...))) - (let ([result (honu-unparsed-begin code ...)]) - (lambda () result)) + (begin + #; + (emit-remark "Do macro transformer" (quote-syntax (code ...))) + #; + (printf "Macro transformer `~a'\n" (syntax->datum (quote-syntax (code ...)))) + (let ([result (honu-unparsed-begin code ...)]) + (lambda () + (emit-remark "Excuting macro " (symbol->string 'name)) + result))) #'(rrest (... ...)))])))))) #; (with-syntax ([parsed (let-values ([(out rest*) diff --git a/collects/honu/private/more.ss b/collects/honu/private/more.ss index 3e3ec66912..38f61b298e 100644 --- a/collects/honu/private/more.ss +++ b/collects/honu/private/more.ss @@ -214,6 +214,19 @@ (with-syntax ([unparsed (make-unparsed #'(expr ...))]) #'(fix-template unparsed)) + #; + (datum->syntax stx + (cons #'fix-template + (cons #'unparsed #'(expr (... ...)))) + stx stx) + + #; + (let ([original #'(expr (... ...))]) + (datum->syntax original + (cons #'fix-template + (cons #'unparsed #'(expr (... ...)))) + original original)) + #'(fix-template (unparsed expr (... ...))) #; diff --git a/collects/honu/private/parse.rkt b/collects/honu/private/parse.rkt index 5a81250572..4689444d72 100644 --- a/collects/honu/private/parse.rkt +++ b/collects/honu/private/parse.rkt @@ -9,6 +9,7 @@ syntax/parse/experimental/splicing "syntax.ss" (for-syntax syntax/parse) + macro-debugger/emit scheme/splicing (for-syntax syntax/define) syntax/name @@ -496,11 +497,6 @@ [else (raise-syntax-error 'parse-an-expr "cant parse" stx)] )) -(define-syntax (invoke-transformer stx) - (syntax-parse stx - [(_ all ...) - (parse #'(all ...))])) - (define-splicing-syntax-class honu-body:class #:literals (#%braces) [pattern (~seq (#%braces code ...))]) @@ -553,14 +549,7 @@ (parse-block-one/2 #'(stuff ... more ...) context))]) (values out rest2)))) ] - [(get-transformer stx) => - (lambda (transformer) - (values - (with-syntax ([(all ...) stx]) - #'(invoke-transformer all ...)) - #'())) - #; - (lambda (transformer) + [(get-transformer stx) => (lambda (transformer) (define introducer (make-syntax-introducer)) (define introduce introducer) (define unintroduce introducer)