From befa88f1acbacd580c2f2beb46608d8223e06b69 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 2 Jun 2010 17:21:02 -0600 Subject: [PATCH] use literal sets --- collects/honu/main.rkt | 17 ++++++++-- collects/honu/private/honu-typed-scheme.rkt | 12 ++++++- collects/honu/private/literals.rkt | 3 ++ collects/honu/private/macro.rkt | 27 ++++++++++++---- collects/honu/private/more.ss | 2 +- collects/honu/private/parse.rkt | 35 +++++++++++++++------ collects/honu/private/syntax.ss | 1 + 7 files changed, 77 insertions(+), 20 deletions(-) diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index 4f3e78c96f..077667ef5d 100644 --- a/collects/honu/main.rkt +++ b/collects/honu/main.rkt @@ -17,6 +17,7 @@ (for-template "private/literals.rkt") (for-syntax "private/more.ss") (for-syntax "private/syntax.ss") + (for-syntax "private/macro.ss") "private/macro.ss") (define test-x-class @@ -26,7 +27,7 @@ (define x (new test-x-class [tuna 5])) -(define (sql1) #f) +(define (sql1 . x) #f) (define (sql2) #f) (define (sql3) #f) (define (sql4) #f) @@ -63,12 +64,13 @@ with-syntax quote #%app - #%parens + #%parens #%brackets #%braces ... map syntax->list identifier expression + statement (rename-out (semicolon \; ) (ellipses-comma ec) @@ -76,6 +78,7 @@ #; (honu-identifier identifier) (expression-comma expression_comma) + (honu-macro macro) (parse-an-expr parse) (... scheme:...) (honu-body:class body) @@ -84,6 +87,7 @@ (honu-+ +) (honu-scheme scheme2) (scheme-syntax scheme:syntax) + (scheme-syntax schemeSyntax) )) #%braces #%parens #%brackets x @@ -92,6 +96,10 @@ display display2 newline + ;; stuff i done want + define + let + ;; end stuff else #%app quote @@ -99,7 +107,10 @@ foobar2000 expression str - (for-template #%parens) + define-struct + #; + (for-template #%parens #%brackets #%braces) + ;; (for-meta 2 (rename-out (honu-syntax syntax))) (rename-out (honu-if if) (honu-provide provide) diff --git a/collects/honu/private/honu-typed-scheme.rkt b/collects/honu/private/honu-typed-scheme.rkt index fb9a149ea3..fd736cb281 100644 --- a/collects/honu/private/honu-typed-scheme.rkt +++ b/collects/honu/private/honu-typed-scheme.rkt @@ -13,6 +13,7 @@ "ops.ss" "syntax.ss" "parse.ss" + "literals.ss" ) "literals.ss" ;; "typed-utils.ss" @@ -501,6 +502,15 @@ if (foo){ [(_ expr ...) (parse-an-expr #'(expr ...))])) +(define-honu-syntax scheme-syntax + (lambda (body ctx) + (syntax-parse body + [(_ expr . rest) + (values + (lambda () + (apply-scheme-syntax #'#'expr)) + #'rest)]))) + (define-honu-syntax honu-provide (lambda (body ctx) (syntax-parse body #:literals (semicolon) @@ -547,7 +557,7 @@ if (foo){ #'rest)]))) (define-syntax (honu-unparsed-begin stx) - (printf "honu unparsed begin: ~a\n" (syntax->datum stx)) + (printf "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level)) (syntax-case stx () [(_) #'(void)] [(_ . body) diff --git a/collects/honu/private/literals.rkt b/collects/honu/private/literals.rkt index d1f4cca313..1eae990460 100644 --- a/collects/honu/private/literals.rkt +++ b/collects/honu/private/literals.rkt @@ -1,6 +1,7 @@ #lang racket (provide (all-defined-out)) +(require syntax/parse) ;; macro for defining literal tokens that can be used in macros (define-syntax-rule (define-literal name ...) @@ -18,3 +19,5 @@ honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->= honu-? honu-: honu-comma honu-. #%braces #%brackets #%parens colon ellipses-comma ellipses-comma* ellipses-repeat honu-for-syntax) + +(define-literal-set cruft (#%parens #%brackets #%braces semicolon)) diff --git a/collects/honu/private/macro.rkt b/collects/honu/private/macro.rkt index 3ef0ac461b..cdb97b87f1 100644 --- a/collects/honu/private/macro.rkt +++ b/collects/honu/private/macro.rkt @@ -13,6 +13,7 @@ "contexts.ss" "parse.ss" "syntax.ss" + "literals.rkt" "honu-typed-scheme.ss" scheme/base syntax/parse @@ -430,7 +431,8 @@ (define-honu-syntax honu-pattern (lambda (stx ctx) - (syntax-parse stx #:literals (#%parens #%brackets semicolon) + (syntax-parse stx #:literal-sets ([cruft #:at stx]) + ;; #%parens #%brackets semicolon) [(_ name (#%parens all-attributes:identifier ...) (#%brackets xpattern ...) semicolon . rest) (define my-parens (datum->syntax #'name '#%parens #'name #'name)) @@ -445,28 +447,38 @@ [parens (datum->syntax #'name '#%parens #'name #'name)]) (syntax/loc stx (define-splicing-syntax-class name - #:literals (parens) + #:literal-sets ([cruft #:at name]) #:attributes (all-attributes ...) final-pattern)))) #'rest)]))) +(define foobar 0) (define-honu-syntax honu-macro (lambda (stx ctx) (define-syntax-class honu-macro3 - #:literals (#%parens #%braces) + ;; #:literals (#%parens #%braces) + #:literal-sets ([cruft ;;#:at stx + #:phase (syntax-local-phase-level) + ]) [pattern (_ name (#%parens literals ...) (#%braces template ...) (#%braces code ...) . rest) #:with result (list (with-syntax ([(fixed ...) (fix-template #'(template ...))] + [first-pattern (stx-car #'(template ...))] + #; + [your-bracket (datum->syntax #'name '#%brackets #'name)] + #; + [your-braces (datum->syntax #'name '#%braces #'name)] + #; [your-parens (datum->syntax #'name '#%parens #'name)]) #; #'(define-honu-syntax name (lambda (stx ctx) - (syntax-parse stx #:literals (your-parens literals ...) + (syntax-parse stx #:literals (your-parens your-bracket literals ...) [(fixed ... rrest (... ...)) (values #; @@ -481,7 +493,10 @@ (syntax/loc stx (define-honu-syntax name (lambda (stx ctx) - (syntax-parse stx #:literals (your-parens literals ...) + (printf "Executing macro `~a' on input `~a'\n" 'name (syntax->datum stx)) + (syntax-parse stx + #:literal-sets ([cruft #:at name]) + #:literals (foobar literals ...) [(fixed ... rrest (... ...)) (values #; @@ -595,7 +610,7 @@ #'rrest))])))) #'rest))]) (printf "Executing honu macro\n") - (syntax-parse stx #:literals (#%parens #%braces) + (syntax-parse stx [out:honu-macro1 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))] [out:honu-macro3 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))] [out:honu-macro2 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))] diff --git a/collects/honu/private/more.ss b/collects/honu/private/more.ss index 475342b934..7e8b7d33d3 100644 --- a/collects/honu/private/more.ss +++ b/collects/honu/private/more.ss @@ -180,7 +180,7 @@ (define-syntax-rule (honu-syntax-maker maker unparsed) (define-honu-syntax maker (lambda (stx ctx) - (syntax-parse stx #:literals (semicolon #%parens) + (syntax-parse stx #:literal-sets ([cruft #:at unparsed]) [(_ (#%parens expr (... ...)) semicolon . rest) (values (lambda () diff --git a/collects/honu/private/parse.rkt b/collects/honu/private/parse.rkt index 516be18d27..a416c2f7b6 100644 --- a/collects/honu/private/parse.rkt +++ b/collects/honu/private/parse.rkt @@ -56,7 +56,7 @@ #:attrs (result) #:description "honu-expr" (lambda (stx fail) - (printf "Honu expr from transformer ~a in context ~a\n" (syntax->datum stx) context) + (printf "Honu expr from transformer `~a' in context ~a transformer ~a\n" (syntax->datum stx) context (get-transformer stx)) (cond [(stx-null? stx) (fail)] #; @@ -336,7 +336,7 @@ [pattern ((~var e (ternary context)) (~var x1 (debug-here (format "expression top 1 ~a\n" (syntax->datum #'e)))) semicolon - (~var x2 (debug-here "2")) + (~var x2 (debug-here "expression top 2")) . rest) #:with result #'e.result]) @@ -432,6 +432,27 @@ [pattern (~seq (~var x (expression-1 the-expression-context))) #:with result (apply-scheme-syntax #'x.result)]) +(define-splicing-syntax-class (whats-here? hm) + [pattern (~seq x) + #:when (begin (printf "Whats at `~a': `~a'\n" hm #'x) + #f)]) + +(define-syntax-class statement + [pattern (~var x (expression-top the-top-block-context)) + #:with result (apply-scheme-syntax (attribute x.result)) + #:with rest #'x.rest]) + +#; +(define-splicing-syntax-class statement + [pattern (~seq + (~optional (~var zz (whats-here? "statement"))) + (~var d1 (debug-here (format "statement 1\n"))) + (~var x (expression-top the-top-block-context)) + (~var d2 (debug-here (format "statement 2\n"))) + ) + #:with result (apply-scheme-syntax #'x.result) + #:with rest #'x.rest]) + (define-splicing-syntax-class expression-comma #:literals (honu-comma) #; @@ -454,7 +475,7 @@ (define (parse-an-expr stx) (printf "Parse an expr ~a\n" (syntax->datum stx)) (syntax-parse (with-syntax ([(s ...) stx]) - #'(s ... semicolon)) + #'(s ...)) #; [(raw:raw-scheme-syntax . rest) #'raw] [((~var expr (expression-1 the-expression-context)) . rest) #'expr.result] @@ -555,10 +576,6 @@ (and (positive? (string-length str)) (memq (string-ref str 0) sym-chars))))))) - - - - ;; returns a transformer or #f (define (get-transformer stx) ;; if its an identifier and bound to a transformer return it @@ -566,7 +583,6 @@ (and (stx-pair? stx) (identifier? (stx-car stx)) (let ([v (begin - #; (printf "Transformer is ~a. Local value is ~a\n" (stx-car stx) (syntax-local-value (stx-car stx) (lambda () #f))) (syntax-local-value (stx-car stx) (lambda () #f)))]) (and (honu-transformer? v) v)))) @@ -596,8 +612,9 @@ (let ([v (syntax-local-value (stx-car first) (lambda () #f))]) (and (honu-transformer? v) v))] [else #f])))) - #; (printf "~a bound transformer? ~a\n" stx (bound-transformer stx)) + (bound-transformer stx) + #; (or (bound-transformer stx) (special-transformer stx))) diff --git a/collects/honu/private/syntax.ss b/collects/honu/private/syntax.ss index 95c410d894..4bc958c727 100644 --- a/collects/honu/private/syntax.ss +++ b/collects/honu/private/syntax.ss @@ -24,6 +24,7 @@ #; (define honu-scheme-syntax (gensym)) +#; (define-syntax-rule (scheme-syntax stx) (syntax-property (syntax stx) honu-scheme-syntax #t))