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

special case for delimiters

Browse Source 
svn: r17114
This commit is contained in:
Jon Rafkind 2009-11-30 19:08:55 +00:00
parent 5b3fa4c120
commit ef194eb948
2 changed files with 24 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/honu/private/honu.ss
View File

@ -126,7 +126,7 @@
(let ([v (syntax-local-value (stx-car first) (lambda () #f))]) (let ([v (syntax-local-value (stx-car first) (lambda () #f))])
(and (honu-transformer? v) v))] (and (honu-transformer? v) v))]
[else #f])))) [else #f]))))
(printf "~a bound transformer? ~a\n" stx (bound-transformer stx)) ;; (printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
(or (bound-transformer stx) (or (bound-transformer stx)
(special-transformer stx))) (special-transformer stx)))

25
collects/honu/private/macro.ss
View File

@ -153,7 +153,8 @@
#'rest))]) #'rest))])
)) ))
(define-for-syntax (delimiter? x) #f) (define-for-syntax (delimiter? x)
(or (free-identifier=? x #'\;)))
(define-syntax (my-ellipses stx) (raise-syntax-error 'my-ellipses "dont use this")) (define-syntax (my-ellipses stx) (raise-syntax-error 'my-ellipses "dont use this"))
;; (define-syntax (wrapped stx) (raise-syntax-error 'wrapped "dont use wrap")) ;; (define-syntax (wrapped stx) (raise-syntax-error 'wrapped "dont use wrap"))
@ -166,6 +167,8 @@
(define (reverse-syntax stx) (define (reverse-syntax stx)
(with-syntax ([(x ...) (reverse (syntax->list stx))]) (with-syntax ([(x ...) (reverse (syntax->list stx))])
#'(x ...))) #'(x ...)))
(define-syntax-class delimiter-class
(pattern x:id #:when (delimiter? #'x)))
(define-syntax-class ellipses-class (define-syntax-class ellipses-class
(pattern x:id #:when (free-identifier=? #'x #'(... ...)))) (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
;; use this if you are defining your own ellipses identifier ;; use this if you are defining your own ellipses identifier
@ -180,6 +183,19 @@
;; (printf "stx is ~a\n" stx) ;; (printf "stx is ~a\n" stx)
;; (printf "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx))) ;; (printf "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx)))
(syntax-parse stx (syntax-parse stx
[(ellipses1:ellipses-class ellipses:ellipses-class ... delimiter:delimiter-class x ...)
(with-syntax ([(x* ...) (reverse-syntax (pull #'(delimiter x ...)))])
(reverse-syntax
(with-syntax ([wrapped #'wrapped]
[original
(with-syntax ([(ellipses* ...) (map (lambda (_)
#'((... ...) (... ...)))
(syntax->list #'(ellipses1 ellipses ...)))]
[(x-new ...) (generate-temporaries #'(delimiter x ...))])
(reverse-syntax #'(ellipses* ... x-new ...)))]
#;
[original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))])
#'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))]
[(ellipses1:ellipses-class ellipses:ellipses-class ... x ...) [(ellipses1:ellipses-class ellipses:ellipses-class ... x ...)
(with-syntax ([(x* ...) (reverse-syntax (pull #'(x ...)))]) (with-syntax ([(x* ...) (reverse-syntax (pull #'(x ...)))])
(reverse-syntax (reverse-syntax
@ -196,13 +212,18 @@
[(x ...) (with-syntax ([(x* ...) (map pull (syntax->list #'(x ...)))]) [(x ...) (with-syntax ([(x* ...) (map pull (syntax->list #'(x ...)))])
(reverse-syntax #'(x* ...)))])))) (reverse-syntax #'(x* ...)))]))))
(begin-for-syntax (trace pull)) ;; (begin-for-syntax (trace pull))
(define-for-syntax (unpull stx) (define-for-syntax (unpull stx)
(define-syntax-class ellipses-class (define-syntax-class ellipses-class
(pattern x:id #:when (free-identifier=? #'x #'(... ...)))) (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
(define-syntax-class delimiter-class
(pattern x:id #:when (delimiter? #'x)))
(syntax-parse stx (syntax-parse stx
#:literals (wrapped unwrap) #:literals (wrapped unwrap)
[(unwrap (wrapped x ... delimiter:delimiter-class) ...)
(with-syntax ([(x1 ...) (apply append (map syntax->list (syntax->list #'((x ... delimiter) ...))))])
#'(x1 ...))]
[(unwrap (wrapped x ... y) ...) [(unwrap (wrapped x ... y) ...)
(with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))]) (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
(with-syntax ([(x1* ...) (map unpull (syntax->list #'(x1 ...)))] (with-syntax ([(x1* ...) (map unpull (syntax->list #'(x1 ...)))]