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 (define guard-macro
(lambda (x) (lambda (x)
(syntax-match x (else) (define (gen-clauses con outerk clause*)
[(_ (con clause* ... [else e e* ...]) b b* ...) (define (f x k)
(bless (syntax-match x (=>)
`((call/cc [(e => p)
(lambda (outerk) (let ([t (gensym)])
(lambda () `(let ([,t ,e])
(with-exception-handler (if ,t (,p ,t) ,k)))]
(lambda (,con) [(e)
(outerk (let ([t (gensym)])
(lambda () `(let ([,t ,e])
(cond ,@clause* [else ,e ,@e*])))) (if ,t ,t ,k)))]
(lambda () #f ,b ,@b*)))))))] [(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* ...) [(_ (con clause* ...) b b* ...)
(bless (id? con)
`((call/cc (let ([outerk (gensym)])
(lambda (outerk) (bless
(lambda () `((call/cc
(with-exception-handler (lambda (,outerk)
(lambda (,con) (lambda ()
((call/cc (with-exception-handler
(lambda (raisek) (lambda (,con)
(outerk ,(gen-clauses con outerk clause*))
(lambda () (lambda () #f ,b ,@b*))))))))])))
(cond ,@clause*
[else
(raisek (lambda () (raise ,con)))])))))))
(lambda () #f ,b ,@b* )))))))])))
(define time-macro (define time-macro
(lambda (stx) (lambda (stx)

26
scheme/todo-r6rs.ss
View File

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