Implement CONDITION-OF-TYPE?.

diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index b37fa3f4e26e9060b683e5fefe289ca01881e9a2..79f3f2fce0ccc9c5dd8af76694170030bd7197ee 100644 (file)
--- a/v7/src/runtime/error.scm
+++ b/v7/src/runtime/error.scm
@@ -1,10 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: error.scm,v 14.66 2004/11/19 17:25:28 cph Exp $
+$Id: error.scm,v 14.67 2005/02/18 18:20:55 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1995,2000,2001,2002 Massachusetts Institute of Technology
-Copyright 2003,2004 Massachusetts Institute of Technology
+Copyright 2003,2004,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -220,12 +220,17 @@ USA.
         (guarantee-restarts restarts operator)
         (list-copy restarts))))
 \f
+(define (condition-of-type? object type)
+  (guarantee-condition-type type 'CONDITION-OF-TYPE?)
+  (%condition-of-type? object type))
+
 (define (condition-predicate type)
   (guarantee-condition-type type 'CONDITION-PREDICATE)
-  (lambda (object)
-    (and (condition? object)
-        (memq type
-              (%condition-type/generalizations (%condition/type object))))))
+  (lambda (object) (%condition-of-type? object type)))
+
+(define (%condition-of-type? object type)
+  (and (condition? object)
+       (memq type (%condition-type/generalizations (%condition/type object)))))
 
 (define (condition-accessor type field-name)
   (guarantee-condition-type type 'CONDITION-ACCESSOR)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 53d1873ad1f336a6bc65a6898d12b658cf57fbed..2852365b623c3fc0ae64a5e7a3d3a00b7e5523e4 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.530 2005/02/08 00:10:55 cph Exp $
+$Id: runtime.pkg,v 14.531 2005/02/18 18:21:09 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -1445,6 +1445,7 @@ USA.
          break-on-signals
          condition-accessor
          condition-constructor
+         condition-of-type?
          condition-predicate
          condition-signaller
          condition-type/error?