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

repeater for entire expressions

Browse Source
This commit is contained in:
Jon Rafkind 2010-05-26 11:09:54 -06:00
parent 81544ea644
commit 99545f8a08
5 changed files with 49 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/honu/main.rkt
View File

@ -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)

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

@ -14,7 +14,6 @@
"syntax.ss"
"parse.ss"
)
(for-template scheme/base)
"literals.ss"
;; "typed-utils.ss"
)

4
collects/honu/private/literals.rkt
View File

@ -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)

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

@ -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)])))

46
collects/honu/private/more.ss
View File

@ -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* ...)))