From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 6 Mar 1991 05:14:50 +0000 (+0000)
Subject: Add new procedure `bind-default-condition-handler'.
X-Git-Tag: 20090517-FFI~10879
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5c62ff3046d1a8830e2453c35471f8127d6ab749;p=mit-scheme.git

Add new procedure `bind-default-condition-handler'.
---

diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index 731ab88e2..e4ceadf12 100644
--- a/v7/src/runtime/error.scm
+++ b/v7/src/runtime/error.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.11 1991/02/15 18:05:10 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.12 1991/03/06 05:14:06 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -398,21 +398,22 @@ MIT in each case. |#
 
 ;;;; Condition Signalling and Handling
 
-(define handler-frames false)
+(define static-handler-frames '())
+(define dynamic-handler-frames '())
 (define break-on-signals-types '())
 
-(define-structure (handler-frame
-		   (type vector)
-		   (conc-name handler-frame/))
-  (types false read-only true)
-  (handler false read-only true)
-  (next false read-only true))
+(define (bind-default-condition-handler types handler)
+  (guarantee-condition-types types 'BIND-DEFAULT-CONDITION-HANDLER)
+  (guarantee-condition-handler handler 'BIND-DEFAULT-CONDITION-HANDLER)
+  (set! static-handler-frames
+	(cons (cons types handler) static-handler-frames))
+  unspecific)
 
 (define (bind-condition-handler types handler thunk)
   (guarantee-condition-types types 'BIND-CONDITION-HANDLER)
   (guarantee-condition-handler handler 'BIND-CONDITION-HANDLER)
-  (fluid-let ((handler-frames
-	       (make-handler-frame types handler handler-frames)))
+  (fluid-let ((dynamic-handler-frames
+	       (cons (cons types handler) dynamic-handler-frames)))
     (thunk)))
 
 (define (break-on-signals types)
@@ -437,15 +438,21 @@ MIT in each case. |#
 	    (and (not (null? types))
 		 (intersect-generalizations? types)))
 	  (bkpt "BKPT entered because of BREAK-ON-SIGNALS:" condition))
-      (let loop ((frame handler-frames))
-	(if frame
-	    (let ((next (handler-frame/next frame)))
-	      (if (let ((types (handler-frame/types frame)))
-		    (or (null? types)
-			(intersect-generalizations? types)))
-		  (fluid-let ((handler-frames next))
-		    ((handler-frame/handler frame) condition)))
-	      (loop next)))))))
+      (do ((frames dynamic-handler-frames (cdr frames)))
+	  ((null? frames))
+	(if (let ((types (caar frames)))
+	      (or (null? types)
+		  (intersect-generalizations? types)))
+	    (fluid-let ((dynamic-handler-frames (cdr frames)))
+	      ((cdar frames) condition))))
+      (do ((frames static-handler-frames (cdr frames)))
+	  ((null? frames))
+	(if (let ((types (caar frames)))
+	      (or (null? types)
+		  (intersect-generalizations? types)))
+	    (fluid-let ((static-handler-frames (cdr frames))
+			(dynamic-handler-frames '()))
+	      ((cdar frames) condition)))))))
 
 ;;;; Standard Condition Signallers
 
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index c23350ed4..5d45e75e2 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.91 1991/03/01 01:06:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.92 1991/03/06 05:14:23 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -532,6 +532,7 @@ MIT in each case. |#
 	  abort
 	  access-condition
 	  bind-condition-handler
+	  bind-default-condition-handler
 	  bind-restart
 	  bound-restarts
 	  break-on-signals
diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 2de2a89dd..84210e203 100644
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.108 1991/03/01 20:15:47 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.109 1991/03/06 05:14:50 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
 		     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 108))
+  (add-identification! "Runtime" 14 109))
 
 (define microcode-system)
 
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index ad478cd75..829562e56 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.91 1991/03/01 01:06:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.92 1991/03/06 05:14:23 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -532,6 +532,7 @@ MIT in each case. |#
 	  abort
 	  access-condition
 	  bind-condition-handler
+	  bind-default-condition-handler
 	  bind-restart
 	  bound-restarts
 	  break-on-signals