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

* stupid syntax-foo helpers are gone.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-08 06:03:11 -04:00
parent 9a3d959142
commit e4f2b18f80
2 changed files with 27 additions and 57 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.

84
src/ikarus.syntax.ss
View File

@ -1053,66 +1053,36 @@
(let-values (((y ids) (cvt* (cdr p*) n ids))) (let-values (((y ids) (cvt* (cdr p*) n ids)))
(let-values (((x ids) (cvt (car p*) n ids))) (let-values (((x ids) (cvt (car p*) n ids)))
(values (cons x y) ids)))))) (values (cons x y) ids))))))
;;; FIXME: these should go away
(define id-dots?
(lambda (x)
(and (syntax-pair? x)
(let ([d (syntax-cdr x)])
(and (syntax-pair? d)
(syntax-null? (syntax-cdr d))
(ellipsis? (syntax-car d)))))))
(define id-dots-id
(lambda (x) (syntax-car x)))
(define syntax-foo?
(lambda (x)
(and (syntax-pair? x)
(let ((d (syntax-cdr x)))
(and (syntax-pair? d)
(ellipsis? (syntax-car d)))))))
(define syntax-foo-z
(lambda (x)
(let f ([x (syntax-cdr (syntax-cdr x))])
(cond
((syntax-pair? x) (f (syntax-cdr x)))
(else x)))))
(define syntax-foo-ys
(lambda (x)
(let f ([x (syntax-cdr (syntax-cdr x))])
(cond
[(syntax-pair? x)
(cons (syntax-car x) (f (syntax-cdr x)))]
[else '()]))))
(define syntax-foo-x
(lambda (x) (syntax-car x)))
(define cvt (define cvt
(lambda (p n ids) (lambda (p n ids)
(cond (syntax-match p ()
[(not (id? p)) [id (id? id)
(cond (cond
[(id-dots? p) [(bound-id-member? p keys)
(let-values ([(p ids) (cvt (id-dots-id p) (+ n 1) ids)]) (values (vector 'free-id p) ids)]
(values [(free-id=? p (scheme-stx '_))
(if (eq? p 'any) 'each-any (vector 'each p)) (values '_ ids)]
ids))] [else (values 'any (cons (cons p n) ids))])]
[(syntax-foo? p) ; (x dots y ... . z) [(p dots) (ellipsis? dots)
(let-values ([(z ids) (cvt (syntax-foo-z p) n ids)]) (let-values ([(p ids) (cvt p (+ n 1) ids)])
(let-values ([(y ids) (cvt* (syntax-foo-ys p) n ids)]) (values
(let-values ([(x ids) (cvt (syntax-foo-x p) (+ n 1) ids)]) (if (eq? p 'any) 'each-any (vector 'each p))
(values (vector 'each+ x (reverse y) z) ids))))] ids))]
[(syntax-pair? p) [(x dots ys ... . z) (ellipsis? dots)
(let-values ([(y ids) (cvt (syntax-cdr p) n ids)]) (let-values ([(z ids) (cvt z n ids)])
(let-values ([(x ids) (cvt (syntax-car p) n ids)]) (let-values ([(ys ids) (cvt* ys n ids)])
(values (cons x y) ids)))] (let-values ([(x ids) (cvt x (+ n 1) ids)])
[(syntax-null? p) (values '() ids)] (values (vector 'each+ x (reverse ys) z) ids))))]
[(syntax-vector? p) [(x . y)
(let-values ([(p ids) (cvt (syntax-vector->list p) n ids)]) (let-values ([(y ids) (cvt y n ids)])
(values (vector 'vector p) ids))] (let-values ([(x ids) (cvt x n ids)])
[else (values (vector 'atom (strip p '())) ids)])] (values (cons x y) ids)))]
[(bound-id-member? p keys) [() (values '() ids)]
(values (vector 'free-id p) ids)] [#(p ...)
[(free-id=? p (scheme-stx '_)) (let-values ([(p ids) (cvt p n ids)])
(values '_ ids)] (values (vector 'vector p) ids))]
[else (values 'any (cons (cons p n) ids))]))) [datum
(values (vector 'atom (strip datum '())) ids)])))
(cvt pattern 0 '()))) (cvt pattern 0 '())))
(define syntax-dispatch (define syntax-dispatch
(lambda (e p) (lambda (e p)