From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 28 Feb 2016 01:12:23 +0000 (-0800)
Subject: Fix parameterization of load.scm.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~114
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4877907057856c599bb611c10822f8904c1db235;p=mit-scheme.git

Fix parameterization of load.scm.
---

diff --git a/src/6001/edextra.scm b/src/6001/edextra.scm
index b58510f22..06db40c15 100644
--- 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 94cd32f1f..ee08daecf 100644
--- 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 2fa542712..2d2826707 100644
--- 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 7c740be29..2bab7ec4a 100644
--- 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 173a28b5b..144dccbe8 100644
--- 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 ec7733754..f0adc4b90 100644
--- 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 b39be6422..2c5b996cb 100644
--- 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?))
 
 (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)))
 
 (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 722a1a1a1..9b5a765a4 100644
--- 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 d482db8b4..67f6bbb05 100644
--- 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 fe334c5fa..51150b787 100644
--- 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 b7a8aa9f5..7b18b1e60 100644
--- 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