suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

emit macro-debugger steps. dont try to use phased macro invocation

Browse Source
This commit is contained in:
Jon Rafkind 2010-06-30 14:33:27 -06:00
parent af678f40ec
commit 44fc323cff
5 changed files with 43 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/honu/main.rkt
View File

@ -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

9
collects/honu/private/honu-typed-scheme.rkt
View File

@ -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)]

17
collects/honu/private/macro.rkt
View File

@ -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*)

13
collects/honu/private/more.ss
View File

@ -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 (... ...)))
#;

15
collects/honu/private/parse.rkt
View File

@ -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)