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

* fixed implementation of guard-macro in psyntax.expander.

This commit is contained in:
Abdulaziz Ghuloum 2007-10-27 11:15:10 -04:00
parent b7d871af9e
commit 79a38bc54b
3 changed files with 56 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

69
scheme/psyntax.expander.ss
View File

@ -1031,33 +1031,50 @@
(define guard-macro
(lambda (x)
(syntax-match x (else)
[(_ (con clause* ... [else e e* ...]) b b* ...)
(bless
`((call/cc
(lambda (outerk)
(lambda ()
(with-exception-handler
(lambda (,con)
(outerk
(lambda ()
(cond ,@clause* [else ,e ,@e*]))))
(lambda () #f ,b ,@b*)))))))]
(define (gen-clauses con outerk clause*)
(define (f x k)
(syntax-match x (=>)
[(e => p)
(let ([t (gensym)])
`(let ([,t ,e])
(if ,t (,p ,t) ,k)))]
[(e)
(let ([t (gensym)])
`(let ([,t ,e])
(if ,t ,t ,k)))]
[(e v v* ...)
`(if ,e (begin ,v ,@v*) ,k)]
[_ (stx-error x "invalid guard clause")]))
(define (f* x*)
(syntax-match x* (else)
[()
(let ([g (gensym)])
(values `(,g (lambda () (raise ,con))) g))]
[([else e e* ...])
(values `(begin ,e ,@e*) #f)]
[(cls . cls*)
(let-values ([(e g) (f* cls*)])
(values (f cls e) g))]
[others (stx-error others "invalid guard clause")]))
(let-values ([(code raisek) (f* clause*)])
(if raisek
`((call/cc
(lambda (,raisek)
(,outerk
(lambda () ,code)))))
`(,outerk (lambda () ,code)))))
(syntax-match x ()
[(_ (con clause* ...) b b* ...)
(bless
`((call/cc
(lambda (outerk)
(lambda ()
(with-exception-handler
(lambda (,con)
((call/cc
(lambda (raisek)
(outerk
(lambda ()
(cond ,@clause*
[else
(raisek (lambda () (raise ,con)))])))))))
(lambda () #f ,b ,@b* )))))))])))
(id? con)
(let ([outerk (gensym)])
(bless
`((call/cc
(lambda (,outerk)
(lambda ()
(with-exception-handler
(lambda (,con)
,(gen-clauses con outerk clause*))
(lambda () #f ,b ,@b*))))))))])))
(define time-macro
(lambda (stx)

26
scheme/todo-r6rs.ss
View File

@ -487,19 +487,19 @@
[when C ct]
;;;
[define-enumeration D en]
[enum-set->list D en]
[enum-set-complement D en]
[enum-set-constructor D en]
[enum-set-difference D en]
[enum-set-indexer D en]
[enum-set-intersection D en]
[enum-set-member? D en]
[enum-set-projection D en]
[enum-set-subset? D en]
[enum-set-union D en]
[enum-set-universe D en]
[enum-set=? D en]
[make-enumeration D en]
[enum-set->list C en]
[enum-set-complement C en]
[enum-set-constructor C en]
[enum-set-difference C en]
[enum-set-indexer C en]
[enum-set-intersection C en]
[enum-set-member? C en]
[enum-set-projection C en]
[enum-set-subset? C en]
[enum-set-union C en]
[enum-set-universe C en]
[enum-set=? C en]
[make-enumeration C en]
;;;
[environment C ev]
[eval C ev se]