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

parse macro functions

Browse Source
This commit is contained in:
Jon Rafkind 2010-05-07 18:59:37 -06:00
parent 31cafd7974
commit 3d52f5ff12
3 changed files with 30 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/honu/main.rkt
View File

@ -1,10 +1,12 @@
#lang scheme/base #lang scheme/base
(require (for-syntax scheme/base))
(require scheme/class) (require scheme/class)
(require "private/honu-typed-scheme.ss" (require "private/honu-typed-scheme.ss"
;; "private/honu.ss" ;; "private/honu.ss"
"private/parse.ss" "private/parse.ss"
(for-syntax "private/literals.ss")
"private/literals.ss" "private/literals.ss"
"private/syntax.ss" "private/syntax.ss"
"private/macro.ss") "private/macro.ss")
@ -30,6 +32,9 @@
(honu-. |.|) (honu-. |.|)
) )
#%datum #%datum
(for-syntax #%datum
(rename-out (semicolon \;
)))
#%braces #%braces
#%parens #%parens
x x
@ -37,6 +42,7 @@
false false
display display
display2 display2
(for-syntax display)
newline newline
else else
foobar2000 foobar2000

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

@ -22,7 +22,6 @@
(provide (all-defined-out)) (provide (all-defined-out))
;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx)) ;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx))
(begin-for-syntax (begin-for-syntax
@ -477,8 +476,6 @@ if (foo){
(define (display2 x y) (define (display2 x y)
(printf "~a ~a" x y)) (printf "~a ~a" x y))
(define-syntax (honu-unparsed-begin stx) (define-syntax (honu-unparsed-begin stx)
(printf "honu unparsed begin: ~a\n" (syntax->datum stx)) (printf "honu unparsed begin: ~a\n" (syntax->datum stx))
(syntax-case stx () (syntax-case stx ()

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

@ -7,6 +7,8 @@
;; (for-template "syntax.ss") ;; (for-template "syntax.ss")
(for-syntax "debug.ss" (for-syntax "debug.ss"
"contexts.ss" "contexts.ss"
"parse.ss"
"honu-typed-scheme.ss"
scheme/base scheme/base
syntax/parse syntax/parse
syntax/stx syntax/stx
@ -392,10 +394,29 @@
(with-syntax ([pulled (pull #'(x ...))]) (with-syntax ([pulled (pull #'(x ...))])
#'(unpull pulled)))])) #'(unpull pulled)))]))
(define-honu-syntax honu-macro (define-honu-syntax honu-macro
(lambda (stx ctx) (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 (define-syntax-class honu-macro1
#:literals (#%parens #%braces) #:literals (#%parens #%braces)
[pattern (_ (#%parens honu-literal ...) [pattern (_ (#%parens honu-literal ...)
@ -465,6 +486,7 @@
(printf "Executing honu macro\n") (printf "Executing honu macro\n")
(syntax-parse stx #:literals (#%parens #%braces) (syntax-parse stx #:literals (#%parens #%braces)
[out:honu-macro1 (apply (lambda (a b) (values a b)) (syntax->list (attribute out.result)))] [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 ...) [(_ (#%parens honu-literal ...)