From e694d84041f9aeff91f0b6c422ceb2bcdd3a1c06 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Mon, 11 Aug 2014 17:25:58 -0700
Subject: [PATCH] Fluidize (runtime load) exported variables: i.e.
 load/loading?...

and load/suppress-loading-message?.  Punted old load-noisily?.
---
 doc/user-manual/user.texinfo |  8 --------
 src/6001/edextra.scm         |  5 +++--
 src/edwin/autold.scm         | 14 ++++++++------
 src/edwin/filcom.scm         |  5 +++--
 src/ffi/build.scm            | 12 +++++++-----
 src/ffi/cdecls.scm           |  2 +-
 src/runtime/ffi.scm          |  5 +++--
 src/runtime/load.scm         | 28 ++++++++++++++--------------
 src/runtime/option.scm       |  5 +++--
 src/runtime/runtime.pkg      |  1 -
 src/ssp/xhtml-expander.scm   | 19 ++++++++++---------
 src/ssp/xmlrpc.scm           |  5 +++--
 tests/ffi/test-ffi.scm       |  5 +++--
 13 files changed, 58 insertions(+), 56 deletions(-)

diff --git a/doc/user-manual/user.texinfo b/doc/user-manual/user.texinfo
index 104dbfae8..919dd9cc2 100644
--- a/doc/user-manual/user.texinfo
+++ b/doc/user-manual/user.texinfo
@@ -1478,14 +1478,6 @@ pathname type @code{"com"}.  (See the description of
 Components of Pathnames, scheme, MIT/GNU Scheme Reference Manual}.)
 @end deffn
 
-@defvr variable load-noisily?
-If @code{load-noisily?} is set to @code{#t}, @code{load} will print the
-value of each expression in the file as it is evaluated.  Otherwise,
-nothing is printed except for the value of the last expression in the
-file.  (Note: the noisy loading feature is implemented for source-code
-files only.)
-@end defvr
-
 @cindex working directory
 @findex pwd
 @findex cd
diff --git a/src/6001/edextra.scm b/src/6001/edextra.scm
index b94bf89c1..7aab85840 100644
--- a/src/6001/edextra.scm
+++ b/src/6001/edextra.scm
@@ -296,8 +296,9 @@ Now, there is formatting stuff to be considered here, in print-pgm.sh.
 		(groups/files-to-copy groups)))))
 
 (define (load-quietly pathname environment)
-  (fluid-let ((load/suppress-loading-message? #t))
-    (load pathname environment)))
+  (let-fluid load/suppress-loading-message? #t
+    (lambda ()
+      (load pathname environment))))
 
 (define (->string object)
   (if (string? object)
diff --git a/src/edwin/autold.scm b/src/edwin/autold.scm
index 0a6654290..fe13f358e 100644
--- a/src/edwin/autold.scm
+++ b/src/edwin/autold.scm
@@ -206,10 +206,11 @@ Second arg is prefix arg when called interactively."
 			 (bind-condition-handler (list condition-type:error)
 			     evaluation-error-handler
 			   (lambda ()
-			     (fluid-let ((load/suppress-loading-message? #t))
-			       ((message-wrapper #f "Loading " (car library))
-				(lambda ()
-				  (load-library library))))))))
+			     (let-fluid load/suppress-loading-message? #t
+			       (lambda ()
+				 ((message-wrapper #f "Loading " (car library))
+				  (lambda ()
+				    (load-library library)))))))))
 		   (load-library library))))))
       (cond ((not (library-loaded? name))
 	     (do-it))
@@ -234,5 +235,6 @@ Second arg PURIFY? means purify the file's contents after loading;
      (bind-condition-handler (list condition-type:error)
 	 evaluation-error-handler
        (lambda ()
-	 (fluid-let ((load/suppress-loading-message? #t))
-	   (load filename environment 'DEFAULT purify?)))))))
\ No newline at end of file
+	 (let-fluid load/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 53ebee402..7d1cd19ac 100644
--- a/src/edwin/filcom.scm
+++ b/src/edwin/filcom.scm
@@ -218,8 +218,9 @@ procedures are called."
 		    (lambda ()
 		      (catch-file-errors (lambda (condition) condition #f)
 			(lambda ()
-			  (fluid-let ((load/suppress-loading-message? #t))
-			    (load pathname '(EDWIN)))))))))))
+			  (let-fluid load/suppress-loading-message? #t
+			    (lambda ()
+			      (load pathname '(EDWIN))))))))))))
 	  (if (and (procedure? database)
 		   (procedure-arity-valid? database 1))
 	      (database buffer)
diff --git a/src/ffi/build.scm b/src/ffi/build.scm
index 63bd5a146..c5ce7312f 100644
--- a/src/ffi/build.scm
+++ b/src/ffi/build.scm
@@ -180,13 +180,15 @@ USA.
   (->namestring (system-library-directory-pathname)))
 
 (define (shim-conf)
-  (fluid-let ((load/suppress-loading-message? #t))
-    (load (system-library-pathname "shim-config.scm"))))
+  (let-fluid load/suppress-loading-message? #t
+    (lambda ()
+      (load (system-library-pathname "shim-config.scm")))))
 
 (define (doc-conf)
-  (fluid-let ((load/suppress-loading-message? #t))
-    (load (string-append (conf-value (shim-conf) 'INFODIR)
-				     "mit-scheme-doc-config.scm"))))
+  (let-fluid load/suppress-loading-message? #t
+    (lambda ()
+      (load (string-append (conf-value (shim-conf) 'INFODIR)
+			   "mit-scheme-doc-config.scm")))))
 
 (define (conf-values conf name)
   (let ((entry (assq name conf)))
diff --git a/src/ffi/cdecls.scm b/src/ffi/cdecls.scm
index 417bb722d..d334c1641 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 (fluid load/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 0cae19f5d..e21557078 100644
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -553,8 +553,9 @@ USA.
 (define (load-ffi-quietly)
   (if (not (name->package '(FFI)))
       (let ((kernel (lambda ()
-		      (fluid-let ((load/suppress-loading-message? #t))
-			(load-option 'FFI)))))
+		      (let-fluid load/suppress-loading-message? #t
+			(lambda ()
+			  (load-option 'FFI))))))
 	(if (nearest-cmdl/batch-mode?)
 	    (kernel)
 	    (with-notification (lambda (port)
diff --git a/src/runtime/load.scm b/src/runtime/load.scm
index d2bd605da..210c45aa7 100644
--- a/src/runtime/load.scm
+++ b/src/runtime/load.scm
@@ -34,6 +34,8 @@ USA.
   (set! condition-type:not-loading
 	(make-condition-type 'NOT-LOADING condition-type:error '()
 	  "No file being loaded."))
+  (set! load/loading? (make-fluid #f))
+  (set! load/suppress-loading-message? (make-fluid #f))
   (set! load/after-load-hooks (make-fluid '()))
   (set! *eval-unit* (make-fluid #f))
   (set! *current-load-environment* (make-fluid 'NONE))
@@ -45,16 +47,13 @@ USA.
 
 (define load/loading?)
 (define load/after-load-hooks)
-(define load/suppress-loading-message? #f)
+(define load/suppress-loading-message?)
 (define *eval-unit*)
 (define *current-load-environment*)
 (define *write-notifications?*)
 
 (define *purification-root-marker*)
 (define condition-type:not-loading)
-
-;; Obsolete and ignored:
-(define load-noisily? #f)
 
 (define (load pathname #!optional environment syntax-table purify?)
   syntax-table				;ignored
@@ -77,7 +76,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 (fluid load/suppress-loading-message?)
 		      (loader environment purify?)
 		      notifier)
 	(load-failure load-1 pathname environment purify?))))
@@ -229,7 +228,7 @@ USA.
 (define (maybe-notify suppress-notifications? loader notifier)
   (let ((notify?
 	 (if (if (default-object? suppress-notifications?)
-		 load/suppress-loading-message?
+		 (fluid load/suppress-loading-message?)
 		 suppress-notifications?)
 	     #f
 	     (fluid *write-notifications?*))))
@@ -288,17 +287,17 @@ USA.
     thunk))
 
 (define (load/push-hook! hook)
-  (if (not load/loading?) (error condition-type:not-loading))
+  (if (not (fluid load/loading?)) (error condition-type:not-loading))
   (set-fluid! load/after-load-hooks (cons hook (fluid load/after-load-hooks)))
   unspecific)
 
 (define (handle-load-hooks thunk)
   (receive (result hooks)
-      (fluid-let ((load/loading? #t))
-	(let-fluid load/after-load-hooks '()
-	  (lambda ()
-	    (let ((result (thunk)))
-	      (values result (reverse (fluid load/after-load-hooks)))))))
+      (let-fluids load/loading? #t
+		  load/after-load-hooks '()
+	(lambda ()
+	  (let ((result (thunk)))
+	    (values result (reverse (fluid load/after-load-hooks))))))
     (for-each (lambda (hook) (hook)) hooks)
     result))
 
@@ -684,8 +683,9 @@ ADDITIONAL OPTIONS supported by this band:\n")
     (lambda (arg)
       (run-in-nearest-repl
        (lambda (repl)
-	 (fluid-let ((load/suppress-loading-message? (cmdl/batch-mode? repl)))
-	   (load arg (repl/environment repl))))))
+	 (let-fluid load/suppress-loading-message? (cmdl/batch-mode? repl)
+	   (lambda ()
+	     (load arg (repl/environment repl)))))))
     "Loads the argument files as if in the REPL."
     "In batch mode, loading messages are suppressed.")
   (argument-command-line-parser "eval" #t
diff --git a/src/runtime/option.scm b/src/runtime/option.scm
index 561c44ef0..980ade71e 100644
--- a/src/runtime/option.scm
+++ b/src/runtime/option.scm
@@ -48,8 +48,9 @@ USA.
 	  (lambda ()
 	    (fluid-let ((*options* '())
 			(*parent* #f))
-	      (fluid-let ((load/suppress-loading-message? #t))
-		(load pathname (make-load-environment)))
+	      (let-fluid load/suppress-loading-message? #t
+		(lambda ()
+		  (load pathname (make-load-environment))))
 	      (values *options* *parent*)))
 	find-option))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 17a4521c3..47aade8a6 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2766,7 +2766,6 @@ USA.
 	  file-loadable?
 	  load
 	  load-library-object-file
-	  load-noisily?
 	  load/loading?
 	  load/purification-root
 	  load/push-hook!
diff --git a/src/ssp/xhtml-expander.scm b/src/ssp/xhtml-expander.scm
index 4c6680105..5006dde61 100644
--- a/src/ssp/xhtml-expander.scm
+++ b/src/ssp/xhtml-expander.scm
@@ -94,15 +94,16 @@ USA.
     environment))
 
 (define ((pi-expander environment) text)
-  (fluid-let ((*outputs* (cons '() '()))
-	      (load/suppress-loading-message? #t))
-    (let ((port (open-input-string text)))
-      (let loop ()
-	(let ((expression (read port)))
-	  (if (not (eof-object? expression))
-	      (begin
-		(expander-eval expression environment)
-		(loop))))))
+  (fluid-let ((*outputs* (cons '() '())))
+    (let-fluid load/suppress-loading-message? #t
+      (lambda ()
+	(let ((port (open-input-string text)))
+	  (let loop ()
+	    (let ((expression (read port)))
+	      (if (not (eof-object? expression))
+		  (begin
+		    (expander-eval expression environment)
+		    (loop))))))))
     (car *outputs*)))
 
 (define expander-eval eval)
diff --git a/src/ssp/xmlrpc.scm b/src/ssp/xmlrpc.scm
index 6226135de..15c813d05 100644
--- a/src/ssp/xmlrpc.scm
+++ b/src/ssp/xmlrpc.scm
@@ -63,6 +63,7 @@ USA.
       (environment-define environment 'define-xmlrpc-method
 	(lambda (name handler)
 	  (hash-table/put! methods name handler)))
-      (fluid-let ((load/suppress-loading-message? #t))
-	(load pathname environment)))
+      (let-fluid load/suppress-loading-message? #t
+	(lambda ()
+	  (load pathname environment))))
     (hash-table/get methods name #f)))
\ No newline at end of file
diff --git a/tests/ffi/test-ffi.scm b/tests/ffi/test-ffi.scm
index df6a3bed8..717aa47a6 100644
--- a/tests/ffi/test-ffi.scm
+++ b/tests/ffi/test-ffi.scm
@@ -39,8 +39,9 @@ USA.
 			  (notification-output-port))
 	    (error "Test FFI build failed:" status))
 	  (begin
-	    (fluid-let ((load/suppress-loading-message? #t))
-	      (load-option 'FFI))
+	    (let-fluid load/suppress-loading-message? #t
+	      (lambda ()
+		(load-option 'FFI)))
 	    (with-system-library-directories '("./")
 	      (lambda ()
 		(compile-file "test-ffi-wrapper")))
-- 
2.25.1