Skip to content

Commit

Permalink
Simplify guard form using call-in-continuation
Browse files Browse the repository at this point in the history
Chez Scheme 10's new call-in-continuation procedure allows implementing
guard in a simpler and likely more efficient way.
  • Loading branch information
mnieper committed Jan 21, 2025
1 parent ae31756 commit 5748a74
Showing 1 changed file with 21 additions and 31 deletions.
52 changes: 21 additions & 31 deletions s/exceptions.ss
Original file line number Diff line number Diff line change
@@ -1,12 +1,12 @@
;;; exceptions.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
Expand Down Expand Up @@ -94,7 +94,7 @@ TODO:
[(message-condition? c)
(let ([irritants (if (irritants-condition? c) (condition-irritants c) '())])
(case (and (list? irritants) (length irritants))
[(0)
[(0)
($report-string op
(and prefix? (if (warning-only? c) "warning" "exception"))
(and (who-condition? c) (condition-who c))
Expand Down Expand Up @@ -263,37 +263,27 @@ TODO:
(set-who! $guard
(lambda (supply-else? guards body)
(if supply-else?
((call/cc
(lambda (kouter)
(let ([original-handler-stack ($current-handler-stack)])
(with-exception-handler
(lambda (arg)
((call/cc
(call/cc
(lambda (kouter)
(let ([original-handler-stack ($current-handler-stack)])
(with-exception-handler
(lambda (arg)
(call/cc
(lambda (kinner)
(kouter
(call-in-continuation kouter
(lambda ()
(guards arg
(lambda ()
(kinner
(call-in-continuation kinner
(lambda ()
(parameterize ([$current-handler-stack original-handler-stack])
(raise-continuable arg))))))))))))
(lambda ()
(call-with-values
body
(case-lambda
[(x) (lambda () x)]
[vals (lambda () (apply values vals))]))))))))
((call/cc
(lambda (k)
(with-exception-handler
(lambda (arg) (k (lambda () (guards arg))))
(lambda ()
(call-with-values
body
(case-lambda
[(x) (lambda () x)]
[vals (lambda () (apply values vals))]))))))))))
(raise-continuable arg)))))))))))
body))))
(call/cc
(lambda (k)
(with-exception-handler
(lambda (arg) (call-in-continuation k (lambda () (guards arg))))
body))))))
)

(define-syntax guard
Expand Down Expand Up @@ -471,7 +461,7 @@ TODO:
;;; defining its child types, even though the system is compiled with
;;; (eval-syntax-expanders-when) not including compile.
(begin
(let-syntax ([a (syntax-rules ()
(let-syntax ([a (syntax-rules ()
[(_ &condition) ; leave only &condition visible
(define-record-type (&condition make-simple-condition simple-condition?)
(nongenerative #{&condition oyb459ue1fphfx4-a}))])])
Expand Down Expand Up @@ -706,7 +696,7 @@ TODO:
(for-each
(lambda (m) (unless (string? m) ($oops who "~s is not a string" m)))
messages)
(error-help #f who #f
(error-help #f who #f
(if (null? messages) "invalid syntax" (apply string-append messages))
#f (make-syntax-violation form #f))))

Expand Down

0 comments on commit 5748a74

Please sign in to comment.