From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 19 Nov 2004 17:28:51 +0000 (+0000)
Subject: DEFAULT-OBJECT? is no longer a special form.
X-Git-Tag: 20090517-FFI~1456
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=20ce2946b91aaaaca82509e8864641068c0e1446;p=mit-scheme.git

DEFAULT-OBJECT? is no longer a special form.
---

diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index aa6d96840..b37fa3f4e 100644
--- a/v7/src/runtime/error.scm
+++ b/v7/src/runtime/error.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: error.scm,v 14.65 2004/02/16 05:36:11 cph Exp $
+$Id: error.scm,v 14.66 2004/11/19 17:25:28 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1995,2000,2001,2002 Massachusetts Institute of Technology
@@ -419,21 +419,6 @@ USA.
 	 (if (eq? name (%restart/name (car restarts)))
 	     (car restarts)
 	     (loop (cdr restarts))))))
-
-(define-syntax restarts-default
-  (sc-macro-transformer
-   (lambda (form environment)
-     (let ((restarts (close-syntax (cadr form) environment))
-	   (name (close-syntax (caddr form) environment)))
-       ;; This is a macro because DEFAULT-OBJECT? is.
-       `(COND ((OR (DEFAULT-OBJECT? ,restarts)
-		   (EQ? 'BOUND-RESTARTS ,restarts))
-	       *BOUND-RESTARTS*)
-	      ((CONDITION? ,restarts)
-	       (%CONDITION/RESTARTS ,restarts))
-	      (ELSE
-	       (GUARANTEE-RESTARTS ,restarts ,name)
-	       ,restarts))))))
 
 (define (find-restart name #!optional restarts)
   (guarantee-symbol name 'FIND-RESTART)
@@ -478,6 +463,16 @@ USA.
 			(restarts-default restarts 'USE-VALUE))))
     (if restart
 	((%restart/effector restart) datum))))
+
+(define (restarts-default restarts name)
+  (cond ((or (default-object? restarts)
+	     (eq? 'BOUND-RESTARTS restarts))
+	 *bound-restarts*)
+	((condition? restarts)
+	 (%condition/restarts restarts))
+	(else
+	 (guarantee-restarts restarts name)
+	 restarts)))
 
 ;;;; Condition Signalling and Handling
 
diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index d0cc13fa6..e190a7e19 100644
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,9 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.66 2003/09/05 20:51:14 cph Exp $
+$Id: load.scm,v 14.67 2004/11/19 17:28:51 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology
+Copyright 2004 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -71,13 +72,11 @@ USA.
 (define (load filename/s #!optional environment syntax-table purify?)
   syntax-table				;ignored
   (let ((environment
-	 ;; Kludge until optional defaulting fixed.
-	 (if (or (default-object? environment)
-		 (eq? environment default-object))
-	     default-object
+	 (if (default-object? environment)
+	     environment
 	     (->environment environment)))
 	(purify?
-	 (if (or (default-object? purify?) (eq? purify? default-object))
+	 (if (default-object? purify?)
 	     #f
 	     purify?)))
     (handle-load-hooks
@@ -133,20 +132,10 @@ USA.
     (lambda (result hooks)
       (for-each (lambda (hook) (hook)) hooks)
       result)))
-
-(define default-object
-  (list 'DEFAULT-OBJECT))
 
 (define (load-noisily filename #!optional environment syntax-table purify?)
-  syntax-table				;ignored
   (fluid-let ((load-noisily? #t))
-    (load filename
-	  ;; This defaulting is a kludge until we get the optional
-	  ;; defaulting fixed.  Right now it must match the defaulting
-	  ;; of `load'.
-	  (if (default-object? environment) default-object environment)
-	  'DEFAULT
-	  (if (default-object? purify?) default-object purify?))))
+    (load filename environment syntax-table purify?)))
 
 (define (load-latest . args)
   (fluid-let ((load/default-find-pathname-with-type find-latest-file))
@@ -277,7 +266,7 @@ USA.
 (define (load-scode-end scode environment purify?)
   (if purify? (purify (load/purification-root scode)))
   (extended-scode-eval scode
-		       (if (eq? environment default-object)
+		       (if (default-object? environment)
 			   (nearest-repl/environment)
 			   environment)))
 
@@ -370,7 +359,7 @@ USA.
   (stream-map stream
 	      (let ((repl (nearest-repl)))
 		(let* ((environment
-			(if (eq? environment default-object)
+			(if (default-object? environment)
 			    (repl/environment repl)
 			    environment)))
 		  (lambda (s-expression)
@@ -579,27 +568,24 @@ USA.
 	  ((load
 	    (lambda (fname #!optional env syntax-table purify?)
 	      syntax-table		;ignored
-	      (let ((env (if (default-object? env) default-object env))
-		    (purify?
-		     (if (default-object? purify?) default-object purify?)))
-		(let ((place (find-filename fname alist)))
-		  (if (not place)
-		      (real-load fname env 'DEFAULT purify?)
-		      (handle-load-hooks
-		       (lambda ()
-			 (let ((scode (caddr place)))
-			   (loading-message fname
-					    load/suppress-loading-message?
-					    ";Pseudo-loading ")
-			   (if (and (not (eq? purify? default-object)) purify?)
-			       (set! to-purify
-				     (cons (load/purification-root scode)
-					   to-purify)))
-			   (fluid-let ((load/current-pathname (cadr place)))
-			     (extended-scode-eval scode
-						  (if (eq? env default-object)
-						      environment
-						      env)))))))))))
+	      (let ((place (find-filename fname alist)))
+		(if (not place)
+		    (real-load fname env 'DEFAULT purify?)
+		    (handle-load-hooks
+		     (lambda ()
+		       (let ((scode (caddr place)))
+			 (loading-message fname
+					  load/suppress-loading-message?
+					  ";Pseudo-loading ")
+			 (if (if (default-object? purify?) #f purify?)
+			     (set! to-purify
+				   (cons (load/purification-root scode)
+					 to-purify)))
+			 (fluid-let ((load/current-pathname (cadr place)))
+			   (extended-scode-eval scode
+						(if (default-object? env)
+						    environment
+						    env))))))))))
 	   (fasload
 	    (lambda (filename #!optional suppress-message?)
 	      (let ((suppress-message?