From 222a3f509b94f2d21c3866793a38f90eed103af4 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 13 Jul 2010 10:46:26 -0600 Subject: [PATCH] allow multiple patterns in a macro. parse call before macro invocation. expressions can end with any number of semicolons --- collects/honu/main.rkt | 7 +++- collects/honu/private/honu-typed-scheme.rkt | 14 ++++--- collects/honu/private/macro.rkt | 23 ++++++++--- collects/honu/private/parse.rkt | 46 +++++++++++++++++---- 4 files changed, 68 insertions(+), 22 deletions(-) diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index 892ea9ae38..4984d34fe2 100644 --- a/collects/honu/main.rkt +++ b/collects/honu/main.rkt @@ -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) diff --git a/collects/honu/private/honu-typed-scheme.rkt b/collects/honu/private/honu-typed-scheme.rkt index d5c2a585b1..52e0d060ef 100644 --- a/collects/honu/private/honu-typed-scheme.rkt +++ b/collects/honu/private/honu-typed-scheme.rkt @@ -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 diff --git a/collects/honu/private/macro.rkt b/collects/honu/private/macro.rkt index 0afbbcbb7b..fdef6c5897 100644 --- a/collects/honu/private/macro.rkt +++ b/collects/honu/private/macro.rkt @@ -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 ...) diff --git a/collects/honu/private/parse.rkt b/collects/honu/private/parse.rkt index 4689444d72..019b1dfd01 100644 --- a/collects/honu/private/parse.rkt +++ b/collects/honu/private/parse.rkt @@ -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)