Fix parameterization of load.scm.

diff --git a/src/6001/edextra.scm b/src/6001/edextra.scm
index b58510f22a6501df36b8c84e17d7d3a8e6371113..06db40c158be3e58c4a2cf080246f10f0d2bdf27 100644 (file)
--- a/src/6001/edextra.scm
+++ b/src/6001/edextra.scm
@@ -296,7 +296,7 @@ Now, there is formatting stuff to be considered here, in print-pgm.sh.
                (groups/files-to-copy groups)))))
 
 (define (load-quietly pathname environment)
-  (parameterize* (list (cons load/suppress-loading-message? #t))
+  (parameterize* (list (cons param:suppress-loading-message? #t))
     (lambda ()
       (load pathname environment))))
 

diff --git a/src/edwin/autold.scm b/src/edwin/autold.scm
index 94cd32f1f71f548c994d3ac088e18b156ac70caf..ee08daecfa23f6d0bb6e3c47bc44f34b2ef8eb77 100644 (file)
--- a/src/edwin/autold.scm
+++ b/src/edwin/autold.scm
@@ -207,7 +207,7 @@ Second arg is prefix arg when called interactively."
                             evaluation-error-handler
                           (lambda ()
                             (parameterize*
-                             (list (cons load/suppress-loading-message? #t))
+                             (list (cons param:suppress-loading-message? #t))
                              (lambda ()
                                ((message-wrapper #f "Loading " (car library))
                                 (lambda ()
@@ -236,6 +236,6 @@ Second arg PURIFY? means purify the file's contents after loading;
      (bind-condition-handler (list condition-type:error)
         evaluation-error-handler
        (lambda ()
-        (parameterize* (list (cons load/suppress-loading-message? #t))
+        (parameterize* (list (cons param:suppress-loading-message? #t))
           (lambda ()
             (load filename environment 'DEFAULT purify?))))))))
\ No newline at end of file

diff --git a/src/edwin/filcom.scm b/src/edwin/filcom.scm
index 2fa542712239c842d92ed73a97052f740bc7cef7..2d2826707f927e43280a3b2f90207e8436698966 100644 (file)
--- a/src/edwin/filcom.scm
+++ b/src/edwin/filcom.scm
@@ -219,7 +219,7 @@ procedures are called."
                      (catch-file-errors (lambda (condition) condition #f)
                        (lambda ()
                          (parameterize*
-                          (list (cons load/suppress-loading-message? #t))
+                          (list (cons param:suppress-loading-message? #t))
                           (lambda ()
                             (load pathname '(EDWIN))))))))))))
          (if (and (procedure? database)

diff --git a/src/ffi/build.scm b/src/ffi/build.scm
index 7c740be2939f39cd73aba9360eb3281ee70bb2b6..2bab7ec4ab39ed132f73a686ae64f2490ff98670 100644 (file)
--- a/src/ffi/build.scm
+++ b/src/ffi/build.scm
@@ -83,7 +83,7 @@ USA.
        string<?)))))
 
 (define (update-html-index directory)
-  ;;(parameterize* (list (cons load/suppress-loading-message? #t)
+  ;;(parameterize* (list (cons param:suppress-loading-message? #t)
   ;;  (lambda () (load-option 'XML)))
   (rewrite-file
    (merge-pathnames "index.html" directory)

diff --git a/src/ffi/cdecls.scm b/src/ffi/cdecls.scm
index 173a28b5b8148e93e712e4bdff5514d94bdcbb76..144dccbe8f9f965e5414ae14e521e378c0ddf148 100644 (file)
--- a/src/ffi/cdecls.scm
+++ b/src/ffi/cdecls.scm
@@ -59,7 +59,7 @@ USA.
   ;; Toplevel entry point for the generator.
   ;; Returns a new C-INCLUDES structure.
   (let ((includes (make-c-includes library))
-       (cwd (if (load/loading?)
+       (cwd (if (param:loading?)
                 (directory-pathname (current-load-pathname))
                 (working-directory-pathname))))
     (fluid-let ((c-include-noisily? #t))

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index ec7733754d16806cc3673b2e72b9dca55861efd5..f0adc4b90363663f17ec1912af42bf67cd603c6c 100644 (file)
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -594,7 +594,7 @@ USA.
   (if (not (name->package '(FFI)))
       (let ((kernel
             (lambda ()
-              (parameterize* (list (cons load/suppress-loading-message? #t))
+              (parameterize* (list (cons param:suppress-loading-message? #t))
                 (lambda ()
                   (load-option 'FFI))))))
        (if (nearest-cmdl/batch-mode?)

diff --git a/src/runtime/load.scm b/src/runtime/load.scm
index b39be64229cb6eff5d032b563ffae23a7ad0880e..2c5b996cbe01c12ab607219723423a7a20243fd7 100644 (file)
--- a/src/runtime/load.scm
+++ b/src/runtime/load.scm
@@ -34,26 +34,37 @@ USA.
   (set! condition-type:not-loading
        (make-condition-type 'NOT-LOADING condition-type:error '()
          "No file being loaded."))
-  (set! load/loading? (make-parameter #f))
-  (set! load/suppress-loading-message? (make-parameter #f))
-  (set! load/after-load-hooks (make-parameter '()))
-  (set! *eval-unit* (make-parameter #f))
-  (set! *current-load-environment* (make-parameter 'NONE))
-  (set! *write-notifications?* (make-parameter #t))
-  (set! *load-init-file?* (make-parameter #t))
+
+  (set! param:after-load-hooks (make-parameter '()))
+  (set! param:current-load-environment (make-parameter #!default))
+  (set! param:eval-unit (make-parameter #f))
+  (set! param:load-init-file? (make-parameter #t))
+  (set! param:loading? (make-parameter #f))
+  (set! param:suppress-loading-message? (make-parameter #f))
+  (set! param:write-notifications? (make-parameter #t))
+
   (initialize-command-line-parsers)
   (set! hook/process-command-line default/process-command-line)
   (add-event-receiver! event:after-restart process-command-line))
 
-(define load/loading?)
-(define load/after-load-hooks)
-(define load/suppress-loading-message?)
-(define *eval-unit*)
-(define *current-load-environment*)
-(define *write-notifications?*)
-
 (define *purification-root-marker*)
 (define condition-type:not-loading)
+
+(define param:after-load-hooks)
+(define param:current-load-environment)
+(define param:eval-unit)
+(define param:load-init-file?)
+(define param:loading?)
+(define param:suppress-loading-message?)
+(define param:write-notifications?)
+
+;; Backwards compatibility:
+(define load/loading? #f)
+(define load/suppress-loading-message? #!default)
+(define (suppress-loading-message?)
+  (if (default-object? load/suppress-loading-message?)
+      (param:suppress-loading-message?)
+      load/suppress-loading-message?))
 \f
 (define (load pathname #!optional environment syntax-table purify?)
   syntax-table                         ;ignored
@@ -76,7 +87,7 @@ USA.
 (define (load-1 pathname environment purify?)
   (receive (pathname* loader notifier) (choose-load-method pathname)
     (if pathname*
-       (maybe-notify (load/suppress-loading-message?)
+       (maybe-notify (suppress-loading-message?)
                      (loader environment purify?)
                      notifier)
        (load-failure load-1 pathname environment purify?))))
@@ -228,11 +239,11 @@ USA.
 (define (maybe-notify suppress-notifications? loader notifier)
   (let ((notify?
         (if (if (default-object? suppress-notifications?)
-                (load/suppress-loading-message?)
+                (suppress-loading-message?)
                 suppress-notifications?)
             #f
-            (*write-notifications?*))))
-    (parameterize* (list (cons *write-notifications?* notify?))
+            (param:write-notifications?))))
+    (parameterize* (list (cons param:write-notifications? notify?))
       (lambda ()
        (if notify?
            (notifier loader)
@@ -254,11 +265,12 @@ USA.
     (thunk)))
 \f
 (define (with-eval-unit uri thunk)
-  (parameterize* (list (cons *eval-unit* (->absolute-uri uri 'WITH-EVAL-UNIT)))
-    thunk))
+  (parameterize*
+   (list (cons param:eval-unit (->absolute-uri uri 'WITH-EVAL-UNIT)))
+   thunk))
 
 (define (current-eval-unit #!optional error?)
-  (let ((unit (*eval-unit*)))
+  (let ((unit (param:eval-unit)))
     (if (and (not unit)
             (if (default-object? error?) #t error?))
        (error condition-type:not-loading))
@@ -269,35 +281,33 @@ USA.
       (error condition-type:not-loading)))
 
 (define (current-load-environment)
-  (let ((env (*current-load-environment*)))
-    (if (eq? env 'NONE)
+  (let ((env (param:current-load-environment)))
+    (if (default-object? env)
        (nearest-repl/environment)
        env)))
 
 (define (set-load-environment! environment)
   (guarantee-environment environment 'SET-LOAD-ENVIRONMENT!)
-  (if (not (eq? (*current-load-environment*) 'NONE))
-      (begin
-       (*current-load-environment* environment)
-       unspecific)))
+  (if (not (default-object? (param:current-load-environment)))
+      (param:current-load-environment environment)))
 
 (define (with-load-environment environment thunk)
   (guarantee-environment environment 'WITH-LOAD-ENVIRONMENT)
-  (parameterize* (list (cons *current-load-environment* environment))
+  (parameterize* (list (cons param:current-load-environment environment))
     thunk))
 
 (define (load/push-hook! hook)
-  (if (not (load/loading?)) (error condition-type:not-loading))
-  (load/after-load-hooks (cons hook (load/after-load-hooks)))
-  unspecific)
+  (if (not (param:loading?)) (error condition-type:not-loading))
+  (param:after-load-hooks (cons hook (param:after-load-hooks))))
 
 (define (handle-load-hooks thunk)
   (receive (result hooks)
-      (parameterize* (list (cons load/loading? #t)
-                          (cons load/after-load-hooks '()))
-       (lambda ()
-         (let ((result (thunk)))
-           (values result (reverse (load/after-load-hooks))))))
+      (fluid-let ((load/loading? #t))  ;backwards compatibility
+       (parameterize* (list (cons param:loading? #t)
+                            (cons param:after-load-hooks '()))
+         (lambda ()
+           (let ((result (thunk)))
+             (values result (reverse (param:after-load-hooks)))))))
     (for-each (lambda (hook) (hook)) hooks)
     result))
 
@@ -460,7 +470,6 @@ USA.
 
 (define *unused-command-line*)
 (define *command-line-parsers*)
-(define *load-init-file?*)
 
 (define (command-line)
   *command-line*)
@@ -506,13 +515,13 @@ USA.
     (if unused-command-line
        (begin
          (set! *unused-command-line*)
-         (parameterize* (list (cons *load-init-file?* #t))
+         (parameterize* (list (cons param:load-init-file? #t))
            (lambda ()
              (set! *unused-command-line*
                    (process-keyword (vector->list unused-command-line) '()))
              (for-each (lambda (act) (act))
                        (reverse after-parsing-actions))
-             (if (*load-init-file?*) (load-init-file)))))
+             (if (param:load-init-file?) (load-init-file)))))
        (begin
          (set! *unused-command-line* #f)
          (load-init-file)))))
@@ -662,8 +671,7 @@ ADDITIONAL OPTIONS supported by this band:\n")
   (set! *command-line-parsers* '())
   (simple-command-line-parser "no-init-file"
     (lambda ()
-      (*load-init-file?* #f)
-      unspecific)
+      (param:load-init-file? #f))
     "Inhibits automatic loading of the ~/.scheme.init file.")
   (set! generate-suspend-file? #f)
   (simple-command-line-parser "suspend-file"
@@ -683,7 +691,7 @@ ADDITIONAL OPTIONS supported by this band:\n")
     (lambda (arg)
       (run-in-nearest-repl
        (lambda (repl)
-        (parameterize* (list (cons load/suppress-loading-message?
+        (parameterize* (list (cons param:suppress-loading-message?
                                    (cmdl/batch-mode? repl)))
           (lambda ()
             (load arg (repl/environment repl)))))))

diff --git a/src/runtime/option.scm b/src/runtime/option.scm
index 722a1a1a1c6010d58827c6edb043bf1585feab33..9b5a765a41d987befc8911b30e8f4ecf45abf0ae 100644 (file)
--- a/src/runtime/option.scm
+++ b/src/runtime/option.scm
@@ -48,7 +48,7 @@ USA.
          (lambda ()
            (parameterize* (list (cons *options* '())
                                 (cons *parent* #f)
-                                (cons load/suppress-loading-message? #t))
+                                (cons param:suppress-loading-message? #t))
              (lambda ()
                (load pathname (make-load-environment))
                (values (*options*) (*parent*)))))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d482db8b4cffefdaf60cb35f50d646d1b7f55ce9..67f6bbb05fac9527a4671402d58f404841ec9f30 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2824,6 +2824,8 @@ USA.
          load/purification-root
          load/push-hook!
          load/suppress-loading-message?
+         param:loading?
+         param:suppress-loading-message?
          set-command-line-parser!
          set-load-environment!
          simple-command-line-parser
@@ -3626,7 +3628,6 @@ USA.
          standard-breakpoint-hook
          ve
          with-repl-eval-boundary)
-  (export (runtime load))
   (export (runtime emacs-interface)
          hook/error-decision
          set-cmdl/port!)

diff --git a/src/ssp/xhtml-expander.scm b/src/ssp/xhtml-expander.scm
index fe334c5fad046a497b22f50301131556c2a816db..51150b7873e2bf9969421f970229cb2fb2c9aa3b 100644 (file)
--- a/src/ssp/xhtml-expander.scm
+++ b/src/ssp/xhtml-expander.scm
@@ -95,7 +95,7 @@ USA.
 
 (define ((pi-expander environment) text)
   (fluid-let ((*outputs* (cons '() '())))
-    (parameterize* (list (cons load/suppress-loading-message? #t))
+    (parameterize* (list (cons param:suppress-loading-message? #t))
       (lambda ()
        (let ((port (open-input-string text)))
          (let loop ()

diff --git a/src/ssp/xmlrpc.scm b/src/ssp/xmlrpc.scm
index b7a8aa9f5113a9415de9422bbb9ade40cbfb74c2..7b18b1e60cb89d8e8233beb3baf3faf50024cffe 100644 (file)
--- a/src/ssp/xmlrpc.scm
+++ b/src/ssp/xmlrpc.scm
@@ -63,7 +63,7 @@ USA.
       (environment-define environment 'define-xmlrpc-method
        (lambda (name handler)
          (hash-table/put! methods name handler)))
-      (parameterize* (list (cons load/suppress-loading-message? #t))
+      (parameterize* (list (cons param:suppress-loading-message? #t))
        (lambda ()
          (load pathname environment))))
     (hash-table/get methods name #f)))
\ No newline at end of file