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

allow multiple patterns in a macro. parse call before macro invocation. expressions can end with any number of semicolons

Browse Source
This commit is contained in:
Jon Rafkind 2010-07-13 10:46:26 -06:00
parent 44fc323cff
commit 222a3f509b
4 changed files with 68 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/honu/main.rkt
View File

@ -71,14 +71,13 @@
...
map
syntax->list
identifier
;identifier
expression
statement
(rename-out (semicolon \;
)
(ellipses-comma ec)
(ellipses-repeat repeat)
#;
(honu-identifier identifier)
(expression-comma expression_comma)
(honu-macro macro)
@ -107,6 +106,7 @@
let
;; end stuff
else
lambda
#%app
(for-template #%app)
quote
@ -117,14 +117,17 @@
define-struct
#;
(for-template #%parens #%brackets #%braces)
in-range
;; (for-meta 2 (rename-out (honu-syntax syntax)))
(rename-out
(syntax real-syntax)
(for scheme-for)
(honu-if if)
(honu-provide provide)
(honu-macro-item macroItem)
(honu-macro macro)
(honu-identifier identifier)
(honu-identifier identifier123)
(honu-require require)
(honu-for-syntax forSyntax)
(honu-syntax syntax)

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

@ -355,11 +355,12 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(define-honu-syntax honu-keywords
(lambda (stx ctx)
(syntax-parse stx #:literals (semicolon)
[(_ word:identifier ... semicolon . rest)
[(_ keyword:honu-identifier ... semicolon . rest)
(values (lambda () (apply-scheme-syntax
#'(begin
(define-syntax word (lambda (xx) (raise-syntax-error 'word "dont use this")))
...)))
(syntax/loc stx
(begin
(define-syntax keyword.x (lambda (xx) (raise-syntax-error 'keyword.x "dont use this")))
...))))
#'rest)])))
(define-honu-syntax honu-if
@ -517,10 +518,11 @@ if (foo){
(define-honu-syntax honu-provide
(lambda (body ctx)
(syntax-parse body #:literals (semicolon)
[(_ x:id ... semicolon . rest)
[(_ x:honu-identifier ... semicolon . rest)
(values
(lambda ()
#'(provide x ...))
(printf "Providing ~a\n" #'(x ...))
#'(provide x.x ...))
#'rest)])))
(define-honu-syntax honu-require

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

@ -460,17 +460,25 @@
(define-honu-syntax honu-macro
(lambda (stx ctx)
(define-splicing-syntax-class patterns
#:literal-sets ([cruft #:phase (syntax-local-phase-level)])
[pattern (~seq (#%braces template ...)
(#%braces code ...))
#:with (fixed ...) (fix-template #'(template ...))])
(define-syntax-class honu-macro3
;; #:literals (#%parens #%braces)
#:literal-sets ([cruft ;;#:at stx
#:phase (syntax-local-phase-level)
])
[pattern (_ name (#%parens literals ...)
(#%braces template ...) (#%braces code ...)
pattern:patterns ...
. rest)
#:with result
(list
(with-syntax ([(fixed ...) (fix-template #'(template ...))]
(with-syntax (
#;
[(fixed ...) (fix-template #'(template ...))]
#;
[first-pattern (stx-car #'(template ...))]
#;
[your-bracket (datum->syntax #'name '#%brackets #'name)]
@ -492,7 +500,8 @@
(let ([result (honu-unparsed-begin code ...)])
(lambda () result))
#'(rrest (... ...)))])))
(printf "Original pattern ~a\n" (syntax->datum #'(fixed ... rrest (... ...))))
#;
(printf "Original pattern ~a\n" (syntax->datum #'(pattern.fixed ... rrest (... ...))))
(apply-scheme-syntax
(syntax/loc stx
(define-honu-syntax name
@ -502,7 +511,7 @@
(syntax-parse stx
#:literal-sets ([cruft #:at name])
#:literals (foobar literals ...)
[(fixed ... rrest (... ...))
[(pattern.fixed ... rrest (... ...))
(values
#;
(with-syntax ([(real-out (... ...)) #'(code ...)])
@ -513,11 +522,13 @@
(emit-remark "Do macro transformer" (quote-syntax (code ...)))
#;
(printf "Macro transformer `~a'\n" (syntax->datum (quote-syntax (code ...))))
(let ([result (honu-unparsed-begin code ...)])
(let ([result (honu-unparsed-begin pattern.code ...)])
(lambda ()
(emit-remark "Excuting macro " (symbol->string 'name))
result)))
#'(rrest (... ...)))]))))))
#'(rrest (... ...)))]
...
))))))
#;
(with-syntax ([parsed (let-values ([(out rest*)
(parse-block-one/2 #'(code ...)

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

@ -1,4 +1,4 @@
#lang scheme
#lang racket/base
(require "contexts.ss"
"util.ss"
@ -8,7 +8,8 @@
syntax/parse
syntax/parse/experimental/splicing
"syntax.ss"
(for-syntax syntax/parse)
(for-syntax syntax/parse
racket/base)
macro-debugger/emit
scheme/splicing
(for-syntax syntax/define)
@ -18,7 +19,7 @@
(for-syntax syntax/private/stxparse/runtime-prose
syntax/private/stxparse/runtime
)
(for-template scheme/base))
(for-template racket/base))
(provide (all-defined-out))
@ -116,7 +117,7 @@
(printf "Transforming honu macro ~a\n" (car stx))
(let-values ([(used rest)
(transformer (introducer stx) context)])
(list rest (syntax-object-position stx rest)
(list (introducer rest) (syntax-object-position stx rest)
(introducer (used)))))]
[else (syntax-case stx ()
@ -144,6 +145,18 @@
(printf "Trying a call on ~a and ~a\n" #'e #'(rest ...))
#f)]
[pattern (~seq (~var e (expression-simple context))
(#%parens
(~seq (~var arg (ternary context))
(~var d3 (debug-here (format "call 3 ~a\n" #'arg)))
(~optional honu-comma))
...))
#:with call
(begin
(printf "Resulting call is ~a\n" (syntax->datum #'(e.result arg.result ...)))
#'(e.result arg.result ...))]
#;
[pattern (~seq (~var e honu-identifier
#;
(honu-expr context))
@ -161,7 +174,21 @@
#'(e.x arg.result ...))])
(define-splicing-syntax-class honu-identifier
[pattern (~seq x:identifier) #:when (not (free-identifier=? #'honu-comma #'x))])
[pattern (~seq x:identifier) #:when (not (or (free-identifier=? #'honu-comma #'x)
(free-identifier=? #'semicolon #'x))
)
#:with result #'x])
(define-splicing-syntax-class (expression-simple context)
#:literals (#%parens)
[pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result]
[pattern (~seq (~var e (honu-transformer
the-expression-context
#;
context))) #:with result #'e.result]
[pattern (~seq x:number) #:with result (begin (printf "got a number ~a\n" #'x) #'x)]
[pattern (~seq x:str) #:with result #'x]
[pattern (~seq x:honu-identifier) #:with result #'x.x])
(define-splicing-syntax-class (expression-last context)
#:literals (#%parens)
@ -179,11 +206,13 @@
#'raw))]
[pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result]
[pattern (~seq (~var call (call context))) #:with result #'call.call]
[pattern (~seq (~var e (honu-transformer
the-expression-context
#;
context))) #:with result #'e.result]
[pattern (~seq (~var call (call context))) #:with result #'call.call]
context)))
#:with result #'e.result
#:with rest #'e.rest]
[pattern (~seq x:number) #:with result (begin (printf "got a number ~a\n" #'x) #'x)]
[pattern (~seq x:str) #:with result #'x]
[pattern (~seq x:honu-identifier) #:with result #'x.x]
@ -324,7 +353,7 @@
[pattern ((~var x0 (debug-here (format "expression top\n")))
(~var e (ternary context))
(~var x1 (debug-here (format "expression top 1 ~a\n" (syntax->datum #'e))))
semicolon
semicolon ...
(~var x2 (debug-here "expression top 2"))
. rest)
#:with result #'e.result])
@ -549,6 +578,7 @@
(parse-block-one/2 #'(stuff ... more ...) context))])
(values out rest2))))
]
#;
[(get-transformer stx) => (lambda (transformer)
(define introducer (make-syntax-introducer))
(define introduce introducer)