[Guile-commits] branch master updated: Re-implement `guard'

[Andy Wingo]

This is an automated email from the git hooks/post-receive script.

wingo pushed a commit to branch master
in repository guile.

The following commit(s) were added to refs/heads/master by this push:
     new 8068994  Re-implement `guard'
8068994 is described below

commit 8068994ba859e2a81830b2bd7e71c002e3a79700
Author: Andy Wingo <address@hidden>
AuthorDate: Fri Jan 10 21:42:26 2020 +0100

    Re-implement `guard'
    
    * module/ice-9/exceptions.scm (guard): Add guard definition that
      re-propagates from original continuation, runs consequents in tail
      position in guard continuation, and doesn't rewind the stack.
    * module/srfi/srfi-34.scm:
    * module/rnrs/exceptions.scm (guard): Re-export from (ice-9
      exceptions).
---
 module/ice-9/exceptions.scm | 68 +++++++++++++++++++++++++++++++++++++++++++--
 module/rnrs/exceptions.scm  | 20 ++-----------
 module/srfi/srfi-34.scm     | 48 ++++----------------------------
 3 files changed, 74 insertions(+), 62 deletions(-)

diff --git a/module/ice-9/exceptions.scm b/module/ice-9/exceptions.scm
index 25f68a3..3e0b8cc 100644
--- a/module/ice-9/exceptions.scm
+++ b/module/ice-9/exceptions.scm
@@ -1,5 +1,5 @@
 ;;; Exceptions
-;;; Copyright (C) 2019 Free Software Foundation, Inc.
+;;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU Lesser General Public License as
@@ -97,7 +97,9 @@
             make-undefined-variable-error
             undefined-variable-error?
 
-            raise-continuable))
+            raise-continuable
+
+            guard))
 
 (define-syntax define-exception-type-procedures
   (syntax-rules ()
@@ -339,3 +341,65 @@
 
 ;; Override core definition.
 (set! make-exception-from-throw convert-guile-exception)
+
+(define-syntax guard
+  (lambda (stx)
+    "Establish an exception handler during the evaluation of an expression.
+
+@example
+(guard (@var{exn} @var{clause1} @var{clause2} ...)
+  @var{body} @var{body*} ...)
+@end example
+
+Each @var{clause} should have the same form as a @code{cond} clause.
+
+The @code{(begin body body* ...)} is evaluated with an exception
+handler that binds the raised object to @var{exn} and within the scope of
+that binding evaluates the clauses as if they were the clauses of a cond
+expression.
+
+When a clause of that implicit cond expression matches, its consequent
+is evaluated with the continuation and dynamic environment of the
+@code{guard} expression.
+
+If every clause's test evaluates to false and there is no @code{else}
+clause, then @code{raise-continuable} is re-invoked on the raised
+object, within the dynamic environment of the original call to raise
+except that the current exception handler is that of the guard
+expression.
+
+Note that in a slight deviation from SRFI-34, R6RS, and R7RS, Guile
+evaluates the clause tests within the continuation of the exception
+handler, not the continuation of the @code{guard}.  This allows
+unhandled exceptions to continue to dispatch within the original
+continuation, without unwinding then rewinding any intermediate
+@code{dynamic-wind} invocations."
+    (define (dispatch tag exn clauses)
+      (define (build-clause test handler clauses)
+        #`(let ((t #,test))
+            (if t
+                (abort-to-prompt #,tag #,handler t)
+                #,(dispatch tag exn clauses))))
+      (syntax-case clauses (=> else)
+        (() #`(raise-continuable #,exn))
+        (((test => f) . clauses)
+         (build-clause #'test #'(lambda (res) (f res)) #'clauses))
+        (((else e e* ...) . clauses)
+         (build-clause #'#t #'(lambda (res) e e* ...) #'clauses))
+        (((test) . clauses)
+         (build-clause #'test #'(lambda (res) res) #'clauses))
+        (((test e* ...) . clauses)
+         (build-clause #'test #'(lambda (res) e* ...) #'clauses))))
+    (syntax-case stx ()
+      ((guard (exn clause clause* ...) body body* ...)
+       (identifier? #'exn)
+       #`(let ((tag (make-prompt-tag)))
+           (call-with-prompt
+            tag
+            (lambda ()
+              (with-exception-handler
+               (lambda (exn)
+                 #,(dispatch #'tag #'exn #'(clause clause* ...)))
+               (lambda () body body* ...)))
+            (lambda (_ h v)
+              (h v))))))))
diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm
index 68797b2..862a0f7 100644
--- a/module/rnrs/exceptions.scm
+++ b/module/rnrs/exceptions.scm
@@ -1,6 +1,6 @@
 ;;; exceptions.scm --- The R6RS exceptions library
 
-;;      Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
+;;      Copyright (C) 2010, 2011, 2013, 2020 Free Software Foundation, Inc.
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -23,20 +23,4 @@
           (rnrs control (6))
           (rnrs conditions (6))
          (rename (ice-9 exceptions)
-                  (raise-exception raise)))
-
-  (define-syntax guard0
-    (syntax-rules ()
-      ((_ (variable cond-clause ...) . body)
-       (call/cc (lambda (continuation)
-                 (with-exception-handler
-                  (lambda (variable)
-                    (continuation (cond cond-clause ...)))
-                  (lambda () . body)))))))
-
-  (define-syntax guard
-    (syntax-rules (else)
-      ((_ (variable cond-clause ... . ((else else-clause ...))) . body)
-       (guard0 (variable cond-clause ... (else else-clause ...)) . body))
-      ((_ (variable cond-clause ...) . body)
-       (guard0 (variable cond-clause ... (else (raise variable))) . body)))))
+                  (raise-exception raise))))
diff --git a/module/srfi/srfi-34.scm b/module/srfi/srfi-34.scm
index 4eb94b4..728b871 100644
--- a/module/srfi/srfi-34.scm
+++ b/module/srfi/srfi-34.scm
@@ -1,6 +1,7 @@
 ;;; srfi-34.scm --- Exception handling for programs
 
-;; Copyright (C) 2003, 2006, 2008, 2010, 2019 Free Software Foundation, Inc.
+;; Copyright (C) 2003,2006,2008-2010,2019-2020
+;;   Free Software Foundation, Inc.
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -27,47 +28,10 @@
 ;;; Code:
 
 (define-module (srfi srfi-34)
+  #:use-module ((ice-9 exceptions) #:select (guard))
   #:re-export (with-exception-handler
-               (raise-exception . raise))
-  #:re-export-and-replace ((raise-exception . raise))
-  #:export-syntax (guard))
+               (raise-exception . raise)
+               guard)
+  #:re-export-and-replace ((raise-exception . raise)))
 
 (cond-expand-provide (current-module) '(srfi-34))
-
-(define-syntax guard
-  (syntax-rules (else)
-    "Syntax: (guard (<var> <clause1> <clause2> ...) <body>)
-Each <clause> should have the same form as a `cond' clause.
-
-Semantics: Evaluating a guard form evaluates <body> with an exception
-handler that binds the raised object to <var> and within the scope of
-that binding evaluates the clauses as if they were the clauses of a
-cond expression.  That implicit cond expression is evaluated with the
-continuation and dynamic environment of the guard expression.  If
-every <clause>'s <test> evaluates to false and there is no else
-clause, then raise is re-invoked on the raised object within the
-dynamic environment of the original call to raise except that the
-current exception handler is that of the guard expression."
-    ((guard (var clause ... (else e e* ...)) body body* ...)
-     (with-exception-handler
-      (lambda (var)
-        (cond clause ...
-              (else e e* ...)))
-      (lambda () body body* ...)
-      #:unwind? #t))
-    ((guard (var clause clause* ...) body body* ...)
-     (let ((tag (make-prompt-tag)))
-       (call-with-prompt
-        tag
-        (lambda ()
-          (with-exception-handler
-           (lambda (exn)
-             (abort-to-prompt tag exn)
-             (raise-exception exn))
-           (lambda () body body* ...)))
-        (lambda (rewind var)
-          (cond clause clause* ...
-                (else (rewind)))))))))
-
-
-;;; (srfi srfi-34) ends here.