scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

=> for case-returned-via

This commit is contained in:
mainzelm 2003-03-03 20:38:17 +00:00
parent f4baad5ab1
commit e12ba6a042
1 changed files with 13 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
scheme/httpd/surflets/surflets.scm
View File

@ -690,7 +690,7 @@
;; This is from Martin Gasbichler ;; This is from Martin Gasbichler
(define-syntax case-returned-via (define-syntax case-returned-via
(syntax-rules (else) (syntax-rules (else =>)
((case-returned-via (%bindings ...) clauses ...) ((case-returned-via (%bindings ...) clauses ...)
(let ((bindings (%bindings ...))) (let ((bindings (%bindings ...)))
(case-returned-via bindings clauses ...))) (case-returned-via bindings clauses ...)))
@ -700,9 +700,20 @@
((%return-object ...) %body ...)) ((%return-object ...) %body ...))
(if (or (returned-via? %return-object bindings) ...) (if (or (returned-via? %return-object bindings) ...)
(begin %body ...))) (begin %body ...)))
((case-returned-via bindings
((%return-object ...) => %proc))
(cond ((or (returned-via %return-object bindings) ...)
=> %proc)))
((case-returned-via bindings ((case-returned-via bindings
((%return-object ...) %body ...) ((%return-object ...) %body ...)
%clause %clauses ...) %clause %clauses ...)
(if (or (returned-via? %return-object bindings) ...) (if (or (returned-via? %return-object bindings) ...)
(begin %body ...) (begin %body ...)
(case-returned-via bindings %clause %clauses ...))))) (case-returned-via bindings %clause %clauses ...)))
((case-returned-via bindings
((%return-object ...) %proc)
%clause %clauses ...)
(cond ((or (returned-via %return-object bindings) ...)
=> %proc)
(else
(case-returned-via bindings %clause %clauses ...))))))