From 5748a74e1e846dfffb29aa3e665f78e7ac72d453 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= Date: Tue, 21 Jan 2025 18:24:11 +0100 Subject: [PATCH] Simplify guard form using call-in-continuation Chez Scheme 10's new call-in-continuation procedure allows implementing guard in a simpler and likely more efficient way. --- s/exceptions.ss | 52 ++++++++++++++++++++----------------------------- 1 file changed, 21 insertions(+), 31 deletions(-) diff --git a/s/exceptions.ss b/s/exceptions.ss index 86abba1fb..f15b0f4ae 100644 --- a/s/exceptions.ss +++ b/s/exceptions.ss @@ -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. @@ -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)) @@ -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 @@ -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}))])]) @@ -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))))