From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 10 Oct 2003 17:35:01 +0000 (+0000)
Subject: Allow IGNORE-ERRORS to take an optional second argument that maps the
X-Git-Tag: 20090517-FFI~1775
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8ae595b5686ef9000f5975ff49534283fc4c6c40;p=mit-scheme.git

Allow IGNORE-ERRORS to take an optional second argument that maps the
error condition to something else.
---

diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index 8352bea62..a516db57a 100644
--- a/v7/src/runtime/error.scm
+++ b/v7/src/runtime/error.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: error.scm,v 14.62 2003/03/10 20:53:34 cph Exp $
+$Id: error.scm,v 14.63 2003/10/10 17:35:01 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1995,2000,2001,2002 Massachusetts Institute of Technology
@@ -499,12 +499,6 @@ USA.
 	       (cons (cons types handler) dynamic-handler-frames)))
     (thunk)))
 
-(define (ignore-errors thunk)
-  (call-with-current-continuation
-   (lambda (continuation)
-     (bind-condition-handler (list condition-type:error) continuation
-       thunk))))
-
 (define (break-on-signals types)
   (guarantee-condition-types types 'BREAK-ON-SIGNALS)
   (set! break-on-signals-types types)
@@ -1165,6 +1159,24 @@ USA.
 
 ;;;; Utilities
 
+(define (ignore-errors thunk #!optional map-error)
+  (let ((handler
+	 (cond ((or (default-object? map-error)
+		    (not map-error))
+		k)
+	       ((and (procedure? map-error)
+		     (procedure-arity-valid? map-error 1))
+		(lambda (condition)
+		  (k (map-error condition))))
+	       (else
+		(error:wrong-type-argument map-error
+					   "map-error procedure"
+					   'IGNORE-ERRORS)))))
+    (call-with-current-continuation
+     (lambda (k)
+       (bind-condition-handler (list condition-type:error) handler
+	 thunk)))))
+
 (define (format-error-message message irritants port)
   (fluid-let ((*unparser-list-depth-limit* 2)
 	      (*unparser-list-breadth-limit* 5))