Fluidize *pp-...*, i.e. *pp-default-as-code?*,...

... *pp-named-lambda->define?*,
    *pp-primitives-by-name*,
    *pp-uninterned-symbols-by-name*,
    *pp-no-highlights?*,
    *pp-save-vertical-space?*,
    *pp-lists-as-tables?*,
    *pp-forced-x-size*,
    *pp-avoid-circularity?*,
    *pp-auto-highlighter*, and
    *pp-arity-dispatched-procedure-style*.

diff --git a/src/6001/make.scm b/src/6001/make.scm
index e5119633f7d259539393c0120a22e8c9335cd2eb..607ea748708e7cc99dcaa9cb2f31f34bd9cfa7fa 100644 (file)
--- a/src/6001/make.scm
+++ b/src/6001/make.scm
@@ -39,8 +39,8 @@ USA.
 ;;; Customize the runtime system:
 (set! repl:allow-restart-notifications? #f)
 (set! repl:write-result-hash-numbers? #f)
-(set! *pp-default-as-code?* #t)
-(set! *pp-named-lambda->define?* 'LAMBDA)
+(set-fluid! *pp-default-as-code?* #t)
+(set-fluid! *pp-named-lambda->define?* 'LAMBDA)
 (set! x-graphics:auto-raise? #t)
 (set! (access write-result:undefined-value-is-special?
              (->environment '(RUNTIME USER-INTERFACE)))

diff --git a/src/compiler/base/debug.scm b/src/compiler/base/debug.scm
index 114b8c8fa5a1151884b86e8c71b05de0cbe0b372..abe5003b8a02604478199b267cb26ab48853f406 100644 (file)
--- a/src/compiler/base/debug.scm
+++ b/src/compiler/base/debug.scm
@@ -110,9 +110,9 @@ USA.
       thunk)))
 
 (define (pp-instructions thunk)
-  (fluid-let ((*show-instruction* pretty-print)
-             (*pp-primitives-by-name* #f))
-    (let-fluids *unparser-radix* 16
+  (fluid-let ((*show-instruction* pretty-print))
+    (let-fluids *pp-primitives-by-name* #f
+               *unparser-radix* 16
                *unparse-uninterned-symbols-by-name?* #t
       thunk)))
 

diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm
index d2ccb48f9af52da46673a58fd1c9cae6df9d04d8..be55ffc8607e009b68dfbef3b7621c1f35b44fc7 100644 (file)
--- a/src/edwin/artdebug.scm
+++ b/src/edwin/artdebug.scm
@@ -681,8 +681,8 @@ Move to the last subproblem if the subproblem number is too high."
                        (if (or argument
                                (invalid-subexpression? sub))
                            (pp exp)
-                           (fluid-let ((*pp-no-highlights?* #f))
-                             (do-hairy))))
+                           (let-fluid *pp-no-highlights?* #f
+                             do-hairy)))
                       ((debugging-info/noise? exp)
                        (message ((debugging-info/noise exp) #t)))
                       (else

diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm
index 1dc72cd9a7b6424c341bff148f8a493348de4850..2f049e3452046463f524077354625ce8ea5f0516 100644 (file)
--- a/src/edwin/debug.scm
+++ b/src/edwin/debug.scm
@@ -49,25 +49,26 @@ USA.
                                             indentation port)
   (let ((start-mark #f)
        (end-mark #f))
-    (fluid-let ((*pp-no-highlights?* #f))
-      (debugger-pp
-       (unsyntax-with-substitutions
-       expression
-       (list (cons subexpression
-                   (make-pretty-printer-highlight
-                    (unsyntax subexpression)
-                    (lambda (port)
-                      (set! start-mark
-                            (mark-right-inserting-copy
-                             (output-port->mark port)))
-                      unspecific)
-                    (lambda (port)
-                      (set! end-mark
-                            (mark-right-inserting-copy
-                             (output-port->mark port)))
-                      unspecific)))))
-       indentation
-       port))
+    (let-fluid *pp-no-highlights?* #f
+      (lambda ()
+       (debugger-pp
+        (unsyntax-with-substitutions
+         expression
+         (list (cons subexpression
+                     (make-pretty-printer-highlight
+                      (unsyntax subexpression)
+                      (lambda (port)
+                        (set! start-mark
+                              (mark-right-inserting-copy
+                               (output-port->mark port)))
+                        unspecific)
+                      (lambda (port)
+                        (set! end-mark
+                              (mark-right-inserting-copy
+                               (output-port->mark port)))
+                        unspecific)))))
+        indentation
+        port)))
     (if (and start-mark end-mark)
        (highlight-region-excluding-indentation
         (make-region start-mark end-mark)

diff --git a/src/pcsample/pcsdisp.scm b/src/pcsample/pcsdisp.scm
index 7af6810bba72a24fc7c32d2c4b45d98510f671d0..fd3c3f99ec1098dadb4cff0ee1d4ac6b45b93b32 100644 (file)
--- a/src/pcsample/pcsdisp.scm
+++ b/src/pcsample/pcsdisp.scm
@@ -141,8 +141,9 @@ USA.
             (display-sample-list displayee))))))
 
 (define (display-sample-list sample-list) ; not integrated so can play w/ it
-  (fluid-let ((*pp-default-as-code?* #T)) ; for now: just pp as code, but
-    (pp sample-list)))                   ; maybe opt for wizzy graphics later
+  (let-fluid *pp-default-as-code?* #T    ; for now: just pp as code, but
+    (lambda ()                           ; maybe opt for wizzy graphics later
+      (pp sample-list))))
 
 (define (install-displayers)
   (set! pc-sample/builtin/display     (generate:pc-sample/table/displayer

diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index 9b9e761475f7f2604234122a4e2cd1406645e3d2..63fbbd7dbd44968f17a8af94eff6f685459a0abf 100644 (file)
--- a/src/runtime/pp.scm
+++ b/src/runtime/pp.scm
@@ -30,6 +30,17 @@ USA.
 (declare (usual-integrations))
 \f
 (define (initialize-package!)
+  (set! *pp-named-lambda->define?* (make-fluid #f))
+  (set! *pp-primitives-by-name* (make-fluid #t))
+  (set! *pp-uninterned-symbols-by-name* (make-fluid #t))
+  (set! *pp-no-highlights?* (make-fluid #t))
+  (set! *pp-save-vertical-space?* (make-fluid #f))
+  (set! *pp-lists-as-tables?* (make-fluid #t))
+  (set! *pp-forced-x-size* (make-fluid #f))
+  (set! *pp-avoid-circularity?* (make-fluid #f))
+  (set! *pp-default-as-code?* (make-fluid #t))
+  (set! *pp-auto-highlighter* (make-fluid #f))
+  (set! *pp-arity-dispatched-procedure-style* (make-fluid 'FULL))
   (set! x-size (make-fluid #f))
   (set! output-port (make-fluid #f))
   (set! pp-description (make-generic-procedure 1 'PP-DESCRIPTION))
@@ -62,16 +73,16 @@ USA.
   (set! cocked-object (generate-uninterned-symbol))
   unspecific)
 
-(define *pp-named-lambda->define?* #f)
-(define *pp-primitives-by-name* #t)
-(define *pp-uninterned-symbols-by-name* #t)
-(define *pp-no-highlights?* #t)
-(define *pp-save-vertical-space?* #f)
-(define *pp-lists-as-tables?* #t)
-(define *pp-forced-x-size* #f)
-(define *pp-avoid-circularity?* #f)
-(define *pp-default-as-code?* #t)
-(define *pp-auto-highlighter* #f)
+(define *pp-named-lambda->define?*)
+(define *pp-primitives-by-name*)
+(define *pp-uninterned-symbols-by-name*)
+(define *pp-no-highlights?*)
+(define *pp-save-vertical-space?*)
+(define *pp-lists-as-tables?*)
+(define *pp-forced-x-size*)
+(define *pp-avoid-circularity?*)
+(define *pp-default-as-code?*)
+(define *pp-auto-highlighter*)
 
 (define (pp object #!optional port . rest)
   (let ((port (if (default-object? port) (current-output-port) port)))
@@ -114,11 +125,11 @@ USA.
 ;;;  FULL:  full bodies of procedures
 ;;;  NAMED: just name if the procedure is a named lambda, like FULL if unnamed
 ;;;  SHORT: procedures appear in #[...] unparser syntax
-(define *pp-arity-dispatched-procedure-style* 'FULL)
+(define *pp-arity-dispatched-procedure-style*)
 
 (define (unsyntax-entity object)
   (define (unsyntax-entry procedure)
-    (case *pp-arity-dispatched-procedure-style*
+    (case (fluid *pp-arity-dispatched-procedure-style*)
       ((FULL)  (unsyntax-entity procedure))
       ((NAMED)
        (let ((text (unsyntax-entity procedure)))
@@ -155,7 +166,7 @@ USA.
 (define (pretty-print object #!optional port as-code? indentation)
   (let ((as-code?
         (if (default-object? as-code?)
-            (let ((default *pp-default-as-code?*))
+            (let ((default (fluid *pp-default-as-code?*)))
               (if (boolean? default)
                   default
                   (not (scode-constant? object))))
@@ -167,8 +178,9 @@ USA.
                    (if (and as-code?
                             (pair? sexp)
                             (eq? (car sexp) 'NAMED-LAMBDA)
-                            *pp-named-lambda->define?*)
-                       (if (and (eq? 'LAMBDA *pp-named-lambda->define?*)
+                            (fluid *pp-named-lambda->define?*))
+                       (if (and (eq? 'LAMBDA
+                                     (fluid *pp-named-lambda->define?*))
                                 (pair? (cdr sexp))
                                 (pair? (cadr sexp)))
                            `(LAMBDA ,(cdadr sexp) ,@(cddr sexp))
@@ -218,16 +230,17 @@ USA.
        0)))
 
 (define (pp-top-level expression port as-code? indentation list-depth)
-  (let-fluids x-size (- (or *pp-forced-x-size* (output-port/x-size port)) 1)
+  (let-fluids x-size (- (or (fluid *pp-forced-x-size*)
+                           (output-port/x-size port)) 1)
              output-port port
              *unparse-uninterned-symbols-by-name?*
-             *pp-uninterned-symbols-by-name*
+             (fluid *pp-uninterned-symbols-by-name*)
              *unparse-abbreviate-quotations?*
              (or as-code?
                  (fluid *unparse-abbreviate-quotations?*))
     (lambda ()
       (let* ((numerical-walk
-             (if *pp-avoid-circularity?*
+             (if (fluid *pp-avoid-circularity?*)
                  numerical-walk-avoid-circularities
                  numerical-walk))
             (node (numerical-walk expression list-depth)))
@@ -262,7 +275,7 @@ USA.
 (define (print-non-code-node node column depth)
   (let-fluids dispatch-list '()
              dispatch-default
-             (if *pp-lists-as-tables?*
+             (if (fluid *pp-lists-as-tables?*)
                  print-data-table
                  print-data-column)
     (lambda ()
@@ -319,7 +332,7 @@ USA.
         (*unparse-string node))))
 
 (define (print-list-node node column depth)
-  (if (and *pp-save-vertical-space?*
+  (if (and (fluid *pp-save-vertical-space?*)
           (fits-within? node column depth))
       (print-guaranteed-list-node node)
       (let* ((subnodes (node-subnodes node))
@@ -649,7 +662,7 @@ USA.
                       (walk-custom unparser object list-depth)
                       (walk-pair object list-depth))))))
          ((symbol? object)
-          (if (or *pp-uninterned-symbols-by-name*
+          (if (or (fluid *pp-uninterned-symbols-by-name*)
                   (interned-symbol? object))
               object
               (walk-custom unparse-object object list-depth)))
@@ -673,7 +686,7 @@ USA.
                                       (walk-pair (vector->list object)
                                                  list-depth))))))
          ((primitive-procedure? object)
-          (if *pp-primitives-by-name*
+          (if (fluid *pp-primitives-by-name*)
               (primitive-procedure-name object)
               (walk-custom unparse-object object list-depth)))
          (else
@@ -686,9 +699,10 @@ USA.
   ;; otherwise we would get infinite recursion when the `unwrapped'
   ;; object REST is re-auto-highlighted by the test below.
 
-  (cond ((and *pp-auto-highlighter*
-             (not (pretty-printer-highlight? object))
-             (*pp-auto-highlighter* object))
+  (cond ((let ((highlighter (fluid *pp-auto-highlighter*)))
+          (and highlighter
+               (not (pretty-printer-highlight? object))
+               (highlighter object)))
         => (lambda (highlighted)
              (numerical-walk-no-auto-highlight highlighted list-depth)))
        (else
@@ -739,7 +753,7 @@ USA.
                                              list-depth)))))))))))))
 
 (define-integrable (no-highlights? object)
-  (or *pp-no-highlights?*
+  (or (fluid *pp-no-highlights?*)
       (not (partially-highlighted? object))))
 
 (define (partially-highlighted? object)
@@ -814,7 +828,7 @@ USA.
                     (walk-pair-terminating object half-pointer/queue
                                            list-depth))))))
        ((symbol? object)
-        (if (or *pp-uninterned-symbols-by-name*
+        (if (or (fluid *pp-uninterned-symbols-by-name*)
                 (interned-symbol? object))
             object
             (walk-custom unparse-object object list-depth)))
@@ -837,7 +851,7 @@ USA.
                     (vector->list object)
                     half-pointer/queue list-depth))))))
        ((primitive-procedure? object)
-        (if *pp-primitives-by-name*
+        (if (fluid *pp-primitives-by-name*)
             (primitive-procedure-name object)
             (walk-custom unparse-object object list-depth)))
        (else

diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm
index d2d86f17174770ef578a785dbb38b1406de2d005..b2f434ed0e261e0559b61fb496d8dbfffebf5de8 100644 (file)
--- a/src/runtime/stack-sample.scm
+++ b/src/runtime/stack-sample.scm
@@ -84,6 +84,7 @@
 (define event-return-address 'UNINITIALIZED)
 
 (define (initialize-package!)
+  (set! stack-sampling-return-address (make-fluid #f))
   (let ((blocked? (block-thread-events)))
     (signal-thread-event (current-thread)
       (lambda ()
@@ -160,10 +161,10 @@
               (stack-frame/type stack-frame))
          (eq? event-return-address (stack-frame/return-address stack-frame)))))
 
-(define stack-sampling-return-address #f)
+(define stack-sampling-return-address)
 
 (define (stack-sampling-stack-frame? stack-frame)
-  (let ((return-address stack-sampling-return-address))
+  (let ((return-address (fluid stack-sampling-return-address)))
     (and (compiled-return-address? return-address)
          (eq? stack-frame-type/compiled-return-address
               (stack-frame/type stack-frame))
@@ -179,9 +180,9 @@
        (let ((stack-frame (continuation/first-subproblem continuation)))
          (if (eq? stack-frame-type/compiled-return-address
                   (stack-frame/type stack-frame))
-             (fluid-let ((stack-sampling-return-address
-                          (stack-frame/return-address stack-frame)))
-               (thunk))
+             (let-fluid stack-sampling-return-address
+                       (stack-frame/return-address stack-frame)
+               thunk)
              (thunk)))))))
 \f
 ;;;; Profile Data
@@ -399,7 +400,7 @@
               *unparser-list-depth-limit* 3
               *unparser-string-length-limit* 40
               *unparse-primitives-by-name?* #t
+             *pp-save-vertical-space?* #t
+             *pp-default-as-code?* #t
     (lambda ()
-      (fluid-let ((*pp-save-vertical-space?* #t)
-                 (*pp-default-as-code?* #t))
-       (pp expression output-port)))))
\ No newline at end of file
+      (pp expression output-port))))
\ No newline at end of file

diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm
index 3483726aba151019a26c2b6d84bd7380850c97c1..933151d4cdfc1bcb662e251bf01ec20973c9df4f 100644 (file)
--- a/src/sf/cgen.scm
+++ b/src/sf/cgen.scm
@@ -243,8 +243,8 @@ USA.
 \f
 ;;; Debugging utility
 (define (pp-expression form #!optional port)
-  (fluid-let ((*pp-primitives-by-name* #f)
-             (*pp-uninterned-symbols-by-name* #f))
-    (let-fluid *unparse-abbreviate-quotations?* #t
-      (lambda ()
-       (pp (cgen/external-with-declarations form) port)))))
+  (let-fluids *pp-primitives-by-name* #f
+             *pp-uninterned-symbols-by-name* #f
+             *unparse-abbreviate-quotations?* #t
+    (lambda ()
+      (pp (cgen/external-with-declarations form) port))))
\ No newline at end of file