From 99545f8a08edfe777ccd7b5ba4bf9152d72a6b1b Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 26 May 2010 11:09:54 -0600 Subject: [PATCH] repeater for entire expressions --- collects/honu/main.rkt | 3 ++ collects/honu/private/honu-typed-scheme.rkt | 1 - collects/honu/private/literals.rkt | 4 +- collects/honu/private/macro.rkt | 22 ++++++---- collects/honu/private/more.ss | 46 ++++++++++++++------- 5 files changed, 49 insertions(+), 27 deletions(-) diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index 9f311ecda6..4f3e78c96f 100644 --- a/collects/honu/main.rkt +++ b/collects/honu/main.rkt @@ -14,6 +14,7 @@ "private/literals.ss" "private/syntax.ss" "private/more.ss" + (for-template "private/literals.rkt") (for-syntax "private/more.ss") (for-syntax "private/syntax.ss") "private/macro.ss") @@ -71,6 +72,7 @@ (rename-out (semicolon \; ) (ellipses-comma ec) + (ellipses-repeat repeat) #; (honu-identifier identifier) (expression-comma expression_comma) @@ -97,6 +99,7 @@ foobar2000 expression str + (for-template #%parens) (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 1681010e2e..fb9a149ea3 100644 --- a/collects/honu/private/honu-typed-scheme.rkt +++ b/collects/honu/private/honu-typed-scheme.rkt @@ -14,7 +14,6 @@ "syntax.ss" "parse.ss" ) - (for-template scheme/base) "literals.ss" ;; "typed-utils.ss" ) diff --git a/collects/honu/private/literals.rkt b/collects/honu/private/literals.rkt index 5350416536..d1f4cca313 100644 --- a/collects/honu/private/literals.rkt +++ b/collects/honu/private/literals.rkt @@ -1,4 +1,4 @@ -#lang scheme +#lang racket (provide (all-defined-out)) @@ -17,4 +17,4 @@ honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>= honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->= honu-? honu-: honu-comma honu-. #%braces #%brackets #%parens colon - ellipses-comma honu-for-syntax) + ellipses-comma ellipses-comma* ellipses-repeat honu-for-syntax) diff --git a/collects/honu/private/macro.rkt b/collects/honu/private/macro.rkt index cbc1df40c6..3ef0ac461b 100644 --- a/collects/honu/private/macro.rkt +++ b/collects/honu/private/macro.rkt @@ -1,14 +1,14 @@ #lang scheme/base (require "honu-typed-scheme.ss" - "literals.ss" + "literals.rkt" "parse.ss" "syntax.ss" syntax/parse (for-meta -3 - (only-in "literals.ss" (#%parens literal-parens))) + (only-in "literals.rkt" (#%parens literal-parens))) #; - (for-template (only-in "literals.ss" (#%parens literal-parens))) + (for-template (only-in "literals.rkt" (#%parens literal-parens))) (for-syntax "debug.ss" "contexts.ss" "parse.ss" @@ -433,15 +433,21 @@ (syntax-parse stx #:literals (#%parens #%brackets semicolon) [(_ name (#%parens all-attributes:identifier ...) (#%brackets xpattern ...) semicolon . rest) + (define my-parens (datum->syntax #'name '#%parens #'name #'name)) (define (create-pattern stuff) (with-syntax ([(fixed ...) (fix-template stuff)]) - #'(pattern (~seq fixed ...)))) + (syntax/loc stuff (pattern (~seq fixed ...))))) (values (lambda () - (with-syntax ([final-pattern (create-pattern #'(xpattern ...))]) - #'(define-splicing-syntax-class name - #:attributes (all-attributes ...) - final-pattern))) + (with-syntax ([final-pattern (create-pattern #'(xpattern ...))] + #; + [parens (datum->syntax stx '#%parens stx)] + [parens (datum->syntax #'name '#%parens #'name #'name)]) + (syntax/loc stx + (define-splicing-syntax-class name + #:literals (parens) + #:attributes (all-attributes ...) + final-pattern)))) #'rest)]))) diff --git a/collects/honu/private/more.ss b/collects/honu/private/more.ss index 0ed25a6eb6..475342b934 100644 --- a/collects/honu/private/more.ss +++ b/collects/honu/private/more.ss @@ -28,18 +28,16 @@ (define (replace-commas stuff) (printf "Replace commas with: ~a\n" (syntax->datum stuff)) - (syntax-parse stuff #:literals (ellipses-comma) - #; - [((ellipses-comma (z ...)) thing blah ...) - (define (maybe-apply-raw stx) - (syntax-parse stuff #:literals (ellipses-comma) - [((ellipses-comma x) . rest) - (if (raw-scheme? #'x) - (apply-scheme-syntax stx) - stx)])) + (syntax-parse stuff #:literals (ellipses-comma ellipses-comma*) + [((ellipses-comma* z ...) thing blah ...) + #; (printf "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(thing blah ...))) (with-syntax ([(rest ...) (replace-commas #'(thing blah ...))]) - (datum->syntax stuff (cons #'(z ...) (cons #'honu-comma #'(rest ...))) + (datum->syntax stuff + #'(z ... honu-comma rest ...) + ;; `(1 ,#'(z ...) ,#'honu-comma ,#'(rest ...)) + #; + (append (syntax->list #'(z ...)) (cons #'honu-comma #'(rest ...))) stuff stuff) #; @@ -55,6 +53,14 @@ stuff) #; #'(z honu-comma rest ...))] + [(front (ellipses-comma* z ...) thing more ...) + (with-syntax ([front* (replace-commas #'front)] + [(rest* ...) (replace-commas #'(thing more ...))]) + (datum->syntax stuff #'(front z ... honu-comma rest* ...) stuff stuff) + #; + (datum->syntax stuff (cons #'front* (cons #'(z ...) (cons #'honu-comma #'(rest* ...)))) + stuff + stuff))] [(front (ellipses-comma z) thing more ...) (define (maybe-apply-raw stx) (syntax-parse stuff #:literals (ellipses-comma) @@ -84,6 +90,7 @@ stuff))] #; [((ellipses-comma (z ...))) (datum->syntax stuff #'(z ...) stuff stuff)] + [((ellipses-comma* z ...)) (datum->syntax stuff #'(z ...) stuff stuff)] [((ellipses-comma z)) (datum->syntax stuff #'(z) stuff stuff)] [(z rest ...) (with-syntax ([z* (replace-commas #'z)] @@ -124,17 +131,24 @@ #'(one* rest* ...))] [else stuff])) (define (replace stuff) - (syntax-parse stuff #:literals (ellipses-comma) + (syntax-parse stuff #:literals (ellipses-comma ellipses-repeat #%parens) + [(ellipses-repeat (#%parens ellipses-comma things-to-repeat ...) rest ...) + (with-syntax ([(rest* ...) (replace #'(rest ...))]) + (datum->syntax stuff + (cons + (cons #'ellipses-comma* #'(things-to-repeat ...)) + (cons + #'(... ...) + #'(rest* ...))) + stuff stuff)) + #; + #'((ellipses-comma a*) (... ...) rest* ...)] [(a ellipses-comma rest ...) (with-syntax ([a* (replace #'a)] [(rest* ...) (replace #'(rest ...))]) (datum->syntax stuff (cons - (cons #'ellipses-comma (cons #'a* '()) - #; - (if (stx-pair? #'a*) - #'a* - (cons #'a* '()))) + (cons #'ellipses-comma (cons #'a* '())) (cons #'(... ...) #'(rest* ...)))