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

* good cleanup of the syntax macro done.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-08 06:33:19 -04:00
parent 88cbbaeb12
commit 741c261b7e
2 changed files with 56 additions and 71 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.

127
src/ikarus.syntax.ss
View File

@ -1316,74 +1316,60 @@
(list (chi-expr expr r mr))))))])))) (list (chi-expr expr r mr))))))]))))
(define syntax-transformer (define syntax-transformer
(let () (let ()
(define match2
(lambda (e f? sk fk)
(if (syntax-list? e)
(let ((e (syntax->list e)))
(if (= (length e) 2)
(let ((e0 (car e)) (e1 (cadr e)))
(if (or (eq? f? #t) (f? e0 e1))
(sk e0 e1)
(fk)))
(fk)))
(fk))))
(define gen-syntax (define gen-syntax
(lambda (src e r maps ellipsis? vec?) (lambda (src e r maps ellipsis? vec?)
(if (id? e) (syntax-match e ()
(let ((label (id->label e))) [dots (ellipsis? dots)
(let ((b (label->binding label r))) (stx-error src "misplaced ellipsis in syntax form")]
(if (eq? (binding-type b) 'syntax) [id (id? id)
(let-values (((var maps) (let* ([label (id->label e)]
(let ((var.lev (binding-value b))) [b (label->binding label r)])
(gen-ref src (car var.lev) (cdr var.lev) maps)))) (if (eq? (binding-type b) 'syntax)
(values (list 'ref var) maps)) (let-values ([(var maps)
(if (ellipsis? e) (let ((var.lev (binding-value b)))
(stx-error src "1misplaced ellipsis in syntax form") (gen-ref src (car var.lev) (cdr var.lev) maps))])
(begin (values (list 'ref var) maps))
(values (list 'quote e) maps)))))) (values (list 'quote e) maps)))]
(match2 e (lambda (dots e) (ellipsis? dots)) [(dots e) (ellipsis? dots)
(lambda (dots e) (if vec?
(if vec? (stx-error src "misplaced 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))) [(x dots . y) (ellipsis? dots)
(lambda () (let f ([y y]
(syntax-match e () [k (lambda (maps)
[(x dots . y) (ellipsis? dots) (let-values ([(x maps)
(let f ([y y] (gen-syntax src x r
[k (lambda (maps) (cons '() maps) ellipsis? #f)])
(let-values ([(x maps) (if (null? (car maps))
(gen-syntax src x r (stx-error src
(cons '() maps) ellipsis? #f)]) "extra ellipsis in syntax form")
(if (null? (car maps)) (values (gen-map x (car maps)) (cdr maps)))))])
(stx-error src (syntax-match y ()
"extra ellipsis in syntax form") [() (k maps)]
(values (gen-map x (car maps)) (cdr maps)))))]) [(dots . y) (ellipsis? dots)
(syntax-match y () (f y
[() (k maps)] (lambda (maps)
[(dots . y) (ellipsis? dots) (let-values ([(x maps) (k (cons '() maps))])
(f y (if (null? (car maps))
(lambda (maps) (stx-error src "extra ellipsis in syntax form")
(let-values (((x maps) (k (cons '() maps)))) (values (gen-mappend x (car maps)) (cdr maps))))))]
(if (null? (car maps)) [_
(stx-error src "extra ellipsis in syntax form") (let-values ([(y maps)
(values (gen-mappend x (car maps)) (cdr maps))))))] (gen-syntax src y r maps ellipsis? vec?)])
[_ (let-values (((x maps) (k maps)))
(let-values (((y maps) (values (gen-append x y) maps)))]))]
(gen-syntax src y r maps ellipsis? vec?))) [(x . y)
(let-values (((x maps) (k maps))) (let-values ([(xnew maps)
(values (gen-append x y) maps)))]))] (gen-syntax src x r maps ellipsis? #f)])
[(x . y) (let-values ([(ynew maps)
(let-values (((xnew maps) (gen-syntax src y r maps ellipsis? vec?)])
(gen-syntax src x r maps ellipsis? #f))) (values (gen-cons e x y xnew ynew) maps)))]
(let-values (((ynew maps) [#(ls ...)
(gen-syntax src y r maps ellipsis? vec?))) (let-values ([(lsnew maps)
(values (gen-cons e x y xnew ynew) maps)))] (gen-syntax src ls r maps ellipsis? #t)])
[#(ls ...) (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))]
[() (values '(quote ()) maps)]
[_ (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)
@ -1469,11 +1455,10 @@
(build-primref no-source (car x)) (build-primref no-source (car x))
(map regen (cdr x))))))) (map regen (cdr x)))))))
(lambda (e r mr) (lambda (e r mr)
(match2 e #t (syntax-match e ()
(lambda (_ x) [(_ x)
(let-values (((e maps) (gen-syntax e x r '() ellipsis? #f))) (let-values (((e maps) (gen-syntax e x r '() ellipsis? #f)))
(regen e))) (regen e))]))))
(lambda () (stx-error e))))))
(define core-macro-transformer (define core-macro-transformer
(lambda (name) (lambda (name)
(case name (case name