DEFAULT-OBJECT? is no longer a special form.

diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index aa6d968406f4136b6e3e7fb067c123604ad600bb..b37fa3f4e26e9060b683e5fefe289ca01881e9a2 100644 (file)
--- 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))))))
 \f
 (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)))
 \f
 ;;;; Condition Signalling and Handling
 

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index d0cc13fa668b013f404a4bcb925b3e724eb47f5d..e190a7e19851905067c7dc8de314be77e5534ef3 100644 (file)
--- 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))
 \f
 (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)))
 \f
@@ -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?