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

rewrite guard definition

This commit is contained in:
Yuichi Nishiwaki 2015-07-09 03:58:08 +09:00
parent 370f7eb4f1
commit 9514bab879
1 changed files with 47 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
contrib/20.r7rs/scheme/base.scm
View File

@ -75,43 +75,34 @@
;; 4.2.7. Exception handling ;; 4.2.7. Exception handling
(define-syntax guard-aux (define-syntax (guard-aux reraise . clauses)
(syntax-rules (else =>) (letrec
((guard-aux reraise (else result1 result2 ...)) ((else?
(begin result1 result2 ...)) (lambda (clause)
((guard-aux reraise (test => result)) (and (list? clause) (equal? #'else (car clause)))))
(let ((temp test)) (=>?
(if temp (lambda (clause)
(result temp) (and (list? clause) (= (length clause) 3) (equal? #'=> (list-ref clause 1))))))
reraise))) (if (null? clauses)
((guard-aux reraise (test => result) reraise
clause1 clause2 ...) (let ((clause (car clauses)))
(let ((temp test)) (cond
(if temp ((else? clause)
(result temp) #`(begin #,@(cdr clause)))
(guard-aux reraise clause1 clause2 ...)))) ((=>? clause)
((guard-aux reraise (test)) #`(let ((tmp #,(list-ref clause 0)))
(or test reraise)) (if tmp
((guard-aux reraise (test) clause1 clause2 ...) (#,(list-ref clause 2) tmp)
(let ((temp test)) (guard-aux #,reraise #,@(cdr clauses)))))
(if temp (else
temp #`(if #,(car clause)
(guard-aux reraise clause1 clause2 ...)))) (begin #,@(cdr clause))
((guard-aux reraise (test result1 result2 ...)) (guard-aux #,reraise #,@(cdr clauses)))))))))
(if test
(begin result1 result2 ...)
reraise))
((guard-aux reraise
(test result1 result2 ...)
clause1 clause2 ...)
(if test
(begin result1 result2 ...)
(guard-aux reraise clause1 clause2 ...)))))
(define-syntax guard (define-syntax (guard formal . body)
(syntax-rules () (let ((var (car formal))
((guard (var clause ...) e1 e2 ...) (clauses (cdr formal)))
((call/cc #`((call/cc
(lambda (guard-k) (lambda (guard-k)
(with-exception-handler (with-exception-handler
(lambda (condition) (lambda (condition)
@ -119,19 +110,19 @@
(lambda (handler-k) (lambda (handler-k)
(guard-k (guard-k
(lambda () (lambda ()
(let ((var condition)) (let ((#,var condition))
(guard-aux (guard-aux
(handler-k (handler-k
(lambda () (lambda ()
(raise-continuable condition))) (raise-continuable condition)))
clause ...)))))))) #,@clauses))))))))
(lambda () (lambda ()
(call-with-values (call-with-values
(lambda () e1 e2 ...) (lambda () #,@body)
(lambda args (lambda args
(guard-k (guard-k
(lambda () (lambda ()
(apply values args))))))))))))) (apply values args))))))))))))
(export guard) (export guard)