conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* major cleanup in the syntax-case macro.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-08 06:21:55 -04:00
parent bae137b21d
commit 88cbbaeb12
2 changed files with 25 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

58
src/ikarus.syntax.ss
View File

@ -1347,51 +1347,43 @@
(stx-error src "2misplaced ellipsis in syntax form") (stx-error src "2misplaced ellipsis in syntax form")
(gen-syntax src e r maps (lambda (x) #f) #f))) (gen-syntax src e r maps (lambda (x) #f) #f)))
(lambda () (lambda ()
(cond (syntax-match e ()
((and (syntax-pair? e) ;(x dots . y) [(x dots . y) (ellipsis? dots)
(let ((t (syntax-cdr e))) (let f ([y y]
(and (syntax-pair? t) [k (lambda (maps)
(ellipsis? (syntax-car t))))) (let-values ([(x maps)
(let f ((y (syntax-cdr (syntax-cdr e))) (gen-syntax src x r
(k (lambda (maps) (cons '() maps) ellipsis? #f)])
(let-values (((x maps)
(gen-syntax src (syntax-car e) r
(cons '() maps) ellipsis? #f)))
(if (null? (car maps)) (if (null? (car maps))
(stx-error src (stx-error src
"extra ellipsis in syntax form") "extra ellipsis in syntax form")
(values (gen-map x (car maps)) (cdr maps))))))) (values (gen-map x (car maps)) (cdr maps)))))])
(cond (syntax-match y ()
((syntax-null? y) (k maps)) [() (k maps)]
((and (syntax-pair? y) (ellipsis? (syntax-car y))) [(dots . y) (ellipsis? dots)
; (dots . y) (f y
(f (syntax-cdr y)
(lambda (maps) (lambda (maps)
(let-values (((x maps) (k (cons '() maps)))) (let-values (((x maps) (k (cons '() maps))))
(if (null? (car maps)) (if (null? (car maps))
(stx-error src "extra ellipsis in syntax form") (stx-error src "extra ellipsis in syntax form")
(values (gen-mappend x (car maps)) (cdr maps))))))) (values (gen-mappend x (car maps)) (cdr maps))))))]
(else [_
(let-values (((y maps) (let-values (((y maps)
(gen-syntax src y r maps ellipsis? vec?))) (gen-syntax src y r maps ellipsis? vec?)))
(let-values (((x maps) (k maps))) (let-values (((x maps) (k maps)))
(values (gen-append x y) maps))))))) (values (gen-append x y) maps)))]))]
((syntax-pair? e) ;(x . y) [(x . y)
(let-values (((xnew maps) (let-values (((xnew maps)
(gen-syntax src (syntax-car e) r (gen-syntax src x r maps ellipsis? #f)))
maps ellipsis? #f)))
(let-values (((ynew maps) (let-values (((ynew maps)
(gen-syntax src (syntax-cdr e) r (gen-syntax src y r maps ellipsis? vec?)))
maps ellipsis? vec?))) (values (gen-cons e x y xnew ynew) maps)))]
(values (gen-cons e (syntax-car e) (syntax-cdr e) xnew ynew) [#(ls ...)
maps)))) (let-values (((lsnew maps)
((syntax-vector? e) ;#(x1 x2 ...) (gen-syntax src ls r maps ellipsis? #t)))
(let ((ls (syntax-vector->list e))) (values (gen-vector e ls lsnew) maps))]
(let-values (((lsnew maps) [() (values '(quote ()) maps)]
(gen-syntax src ls r maps ellipsis? #t))) [_ (values `(quote ,e) maps)]))))))
(values (gen-vector e ls lsnew) maps))))
((and (syntax-null? e) vec?) (values '(quote ()) maps))
(else (values `(quote ,e) maps))))))))
(define gen-ref (define gen-ref
(lambda (src var level maps) (lambda (src var level maps)
(if (= level 0) (if (= level 0)