From 056bf25b0e9c719c99965a732f49cd2d16cb1133 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 26 Feb 2016 02:08:56 -0800 Subject: [PATCH] Eliminate fluid data type in favor of parameters. Also simplify implementation of parameters. --- doc/ref-manual/error.texi | 10 +- doc/ref-manual/io.texi | 49 +++--- doc/ref-manual/misc-datatypes.texi | 31 ---- doc/ref-manual/numbers.texi | 42 ++--- doc/ref-manual/os-interface.texi | 8 +- doc/ref-manual/special-forms.texi | 82 ++++----- src/6001/edextra.scm | 2 +- src/6001/make.scm | 20 ++- src/6001/nodefs.scm | 6 +- src/compiler/base/debug.scm | 10 +- src/compiler/base/object.scm | 2 +- src/compiler/base/toplev.scm | 4 +- src/compiler/machines/alpha/dassm1.scm | 4 +- src/compiler/machines/bobcat/dassm1.scm | 4 +- src/compiler/machines/i386/dassm1.scm | 4 +- src/compiler/machines/mips/dassm1.scm | 4 +- src/compiler/machines/spectrum/dassm1.scm | 4 +- src/compiler/machines/svm/disassembler.scm | 4 +- src/compiler/machines/vax/dassm1.scm | 4 +- src/compiler/machines/x86-64/dassm1.scm | 4 +- src/edwin/artdebug.scm | 8 +- src/edwin/autold.scm | 13 +- src/edwin/debug.scm | 6 +- src/edwin/evlcom.scm | 15 +- src/edwin/filcom.scm | 7 +- src/edwin/intmod.scm | 36 ++-- src/edwin/prompt.scm | 2 +- src/edwin/schmod.scm | 10 +- src/ffi/build.scm | 3 +- src/ffi/cdecls.scm | 4 +- src/imail/imail-util.scm | 3 +- src/pcsample/pcsdisp.scm | 39 ++--- src/runtime/advice.scm | 28 ++-- src/runtime/boot.scm | 2 +- src/runtime/debug.scm | 23 +-- src/runtime/dosdir.scm | 9 +- src/runtime/dospth.scm | 2 +- src/runtime/dragon4.scm | 6 +- src/runtime/dynamic.scm | 73 ++------ src/runtime/error.scm | 72 ++++---- src/runtime/ffi.scm | 9 +- src/runtime/file-attributes.scm | 39 +++-- src/runtime/gcdemn.scm | 2 +- src/runtime/global.scm | 12 +- src/runtime/infutl.scm | 23 +-- src/runtime/load.scm | 53 +++--- src/runtime/ntdir.scm | 6 +- src/runtime/option.scm | 20 +-- src/runtime/os2dir.scm | 4 +- src/runtime/parse.scm | 65 ++++--- src/runtime/pathnm.scm | 24 +-- src/runtime/port.scm | 64 ++++--- src/runtime/pp.scm | 155 +++++++++-------- src/runtime/prgcop.scm | 22 +-- src/runtime/random.scm | 6 +- src/runtime/rep.scm | 55 +++--- src/runtime/runtime.pkg | 6 - src/runtime/savres.scm | 4 +- src/runtime/stack-sample.scm | 23 +-- src/runtime/structure-parser.scm | 6 +- src/runtime/swank.scm | 72 ++++---- src/runtime/syntax-output.scm | 12 +- src/runtime/syntax.scm | 2 +- src/runtime/thread.scm | 8 +- src/runtime/unpars.scm | 186 ++++++++++----------- src/runtime/unsyn.scm | 6 +- src/runtime/unxdir.scm | 9 +- src/runtime/unxpth.scm | 2 +- src/runtime/usrint.scm | 14 +- src/runtime/world-report.scm | 4 +- src/runtime/wrkdir.scm | 18 +- src/sf/cgen.scm | 6 +- src/sicp/compat.scm | 4 +- src/sicp/studen.scm | 4 +- src/sos/microbench.scm | 2 +- src/ssp/xhtml-expander.scm | 2 +- src/ssp/xmlrpc.scm | 2 +- src/swat/scheme/other/rtest.scm | 24 ++- tests/runtime/test-dynamic-env.scm | 53 +----- 79 files changed, 783 insertions(+), 904 deletions(-) diff --git a/doc/ref-manual/error.texi b/doc/ref-manual/error.texi index d9c42a3bd..260f510f3 100644 --- a/doc/ref-manual/error.texi +++ b/doc/ref-manual/error.texi @@ -451,12 +451,11 @@ order to simulate the effect of calling @code{error}, code may call @defvr variable standard-error-hook @findex standard-error-handler -@cindex fluid binding @cindex dynamic binding @cindex REP loop -This fluid controls the behavior of the procedure +This parameter controls the behavior of the procedure @code{standard-error-handler}, and hence @code{error}. It is intended -to be bound with @code{let-fluid} and is normally @code{#f}. It may be +to be bound with @code{parameterize} and is normally @code{#f}. It may be changed to a procedure of one argument and will then be invoked (with @code{standard-error-hook} rebound to @code{#f}) by @code{standard-error-handler} just prior to starting the error @@ -486,11 +485,10 @@ however. For that purpose an explicit restart must be provided.) @defvr variable standard-warning-hook @findex standard-warning-handler -@cindex fluid binding @cindex dynamic binding -This fluid controls the behavior of the procedure +This parameter controls the behavior of the procedure @code{standard-warning-handler}, and hence @code{warn}. It is intended -to be bound with @code{let-fluid} and is normally @code{#f}. It may be +to be bound with @code{parameterize} and is normally @code{#f}. It may be changed to a procedure of one argument and will then be invoked (with @code{standard-warning-hook} rebound to @code{#f}) by @code{standard-warning-handler} in lieu of writing the warning message. diff --git a/doc/ref-manual/io.texi b/doc/ref-manual/io.texi index a17a55f2c..6c3bb287c 100644 --- a/doc/ref-manual/io.texi +++ b/doc/ref-manual/io.texi @@ -704,17 +704,16 @@ amounts of data. The following names control the behavior of the @code{read} procedure. They are looked up in the environment that is passed to @code{read}, -and so may have different fluids in different environments. The -global fluids (fluids assigned to the global bindings) may be -dynamically bound by the @code{let-fluid} procedure, but should not be -mutated by @code{fluid-set!}. Make persistent, local changes by -shadowing the global bindings in the local environment and assigning -new fluids to them. +and so may have different values in different environments. The +global parameters may be dynamically bound by @code{parameterize}, but +should not be mutated. Make persistent, local changes by shadowing +the global bindings in the local environment and assigning new +parameters to them. @defvr variable *parser-radix* -This fluid defines the radix used by the reader when it parses +This parameter defines the radix used by the reader when it parses numbers. This is similar to passing a radix argument to -@code{string->number}. The value of the fluid must be one of +@code{string->number}. The value of the parameter must be one of @code{2}, @code{8}, @code{10}, or @code{16}; any other value is ignored, and the reader uses radix @code{10}. @@ -723,14 +722,14 @@ Note that much of the number syntax is invalid for radixes other than and signals an error. However, problems can still occur when @code{*parser-radix*} is set to @code{16}, because syntax that normally denotes symbols can now denote numbers (e.g.@: @code{abc}). Because of -this, it is usually undesirable to set this fluid to anything other +this, it is usually undesirable to set this parameter to anything other than the default. -The default value of this fluid is @code{10}. +The default value of this parameter is @code{10}. @end defvr @defvr variable *parser-canonicalize-symbols?* -This fluid controls how the parser handles case-sensitivity of +This parameter controls how the parser handles case-sensitivity of symbols. If it is bound to its default value of @code{#t}, symbols read by the parser are converted to lower case before being interned. Otherwise, symbols are interned without case conversion. @@ -887,27 +886,27 @@ The following variables may be dynamically bound to change the behavior of the @code{write} and @code{display} procedures. @defvr variable *unparser-radix* -This fluid specifies the default radix used to print numbers. Its +This parameter specifies the default radix used to print numbers. Its value must be one of the exact integers @code{2}, @code{8}, @code{10}, or @code{16}; the default is @code{10}. If @code{*unparser-radix*} is not @code{10}, numbers are prefixed to indicate their radix. @end defvr @defvr variable *unparser-list-breadth-limit* -This fluid specifies a limit on the length of the printed +This parameter specifies a limit on the length of the printed representation of a list or vector; for example, if the limit is @code{4}, only the first four elements of any list are printed, followed by ellipses to indicate any additional elements. The value of this -fluid must be an exact non-negative integer, or @code{#f} meaning no +parameter must be an exact non-negative integer, or @code{#f} meaning no limit; the default is @code{#f}. @example @group -(let-fluid *unparser-list-breadth-limit* 4 +(parameterize ((*unparser-list-breadth-limit* 4)) (lambda () (write-to-string '(a b c d)))) @result{} "(a b c d)" -(let-fluid *unparser-list-breadth-limit* 4 +(parameterize ((*unparser-list-breadth-limit* 4)) (lambda () (write-to-string '(a b c d e)))) @result{} "(a b c d ...)" @@ -916,20 +915,20 @@ limit; the default is @code{#f}. @end defvr @defvr variable *unparser-list-depth-limit* -This fluid specifies a limit on the nesting of lists and vectors in +This parameter specifies a limit on the nesting of lists and vectors in the printed representation. If lists (or vectors) are more deeply nested than the limit, the part of the representation that exceeds the -limit is replaced by ellipses. The value of this fluid must be an +limit is replaced by ellipses. The value of this parameter must be an exact non-negative integer, or @code{#f} meaning no limit; the default is @code{#f}. @example @group -(let-fluid *unparser-list-depth-limit* 4 +(parameterize((*unparser-list-depth-limit* 4)) (lambda () (write-to-string '((((a))) b c d)))) @result{} "((((a))) b c d)" -(let-fluid *unparser-list-depth-limit* 4 +(parameterize ((*unparser-list-depth-limit* 4)) (lambda () (write-to-string '(((((a)))) b c d)))) @result{} "((((...))) b c d)" @@ -938,20 +937,20 @@ is @code{#f}. @end defvr @defvr variable *unparser-string-length-limit* -This fluid specifies a limit on the length of the printed +This parameter specifies a limit on the length of the printed representation of strings. If a string's length exceeds this limit, the part of the printed representation for the characters exceeding the -limit is replaced by ellipses. The value of this fluid must be an +limit is replaced by ellipses. The value of this parameter must be an exact non-negative integer, or @code{#f} meaning no limit; the default is @code{#f}. @example @group -(let-fluid *unparser-string-length-limit* 4 +(parameterize ((*unparser-string-length-limit* 4)) (lambda () (write-to-string "abcd"))) @result{} "\"abcd\"" -(let-fluid *unparser-string-length-limit* 4 +(parameterize ((*unparser-string-length-limit* 4)) (lambda () (write-to-string "abcde"))) @result{} "\"abcd...\"" @@ -960,7 +959,7 @@ is @code{#f}. @end defvr @defvr variable *unparse-with-maximum-readability?* -This fluid, which takes a boolean value, tells the printer to use a +This parameter, which takes a boolean value, tells the printer to use a special printed representation for objects that normally print in a form that cannot be recognized by @code{read}. These objects are printed using the representation @code{#@@@var{n}}, where @var{n} is the result diff --git a/doc/ref-manual/misc-datatypes.texi b/doc/ref-manual/misc-datatypes.texi index 6e843993b..11a8b54eb 100644 --- a/doc/ref-manual/misc-datatypes.texi +++ b/doc/ref-manual/misc-datatypes.texi @@ -428,37 +428,6 @@ new values. Returns the value of @var{thunk} while the parameters are dynamically bound to the values. @end deffn -@anchor{Fluids} -@subsection Fluids - -@cindex fluid (defn) -A @dfn{fluid} object is very similar to a parameter. Its value can be -dynamically bound like a parameter, and it has a top-level value that -is used when it is unbound in the current dynamic environment. - -@deffn procedure make-fluid value -Returns a new fluid object with @var{value} as its initial, top-level -value. -@end deffn - -@deffn procedure fluid fluid -Returns @var{fluid}'s current value. -@end deffn - -@deffn procedure set-fluid! fluid value -Changes @var{fluid}'s current value. If @var{fluid} is not bound in -the current dynamic environment, its top-level value is changed. -@end deffn - -@anchor{let-fluids} -@deffn procedure let-fluid fluid value thunk -@deffnx procedure let-fluids fluid value [ fluid value ] @dots{} thunk -Returns the value of @var{thunk} while @var{fluid} is dynamically -bound to @var{value}. @code{Let-fluids} is identical to -@code{let-fluid} except that it binds an arbitrary number of fluids to -new values. -@end deffn - @anchor{Cells} @subsection Cells diff --git a/doc/ref-manual/numbers.texi b/doc/ref-manual/numbers.texi index 711fca001..b8edf9caa 100644 --- a/doc/ref-manual/numbers.texi +++ b/doc/ref-manual/numbers.texi @@ -934,9 +934,9 @@ the result, and consequently can be tolerated by many applications. @end defvr @defvr variable flonum-unparser-cutoff -This fluid controls the action of @code{number->string} when +This parameter controls the action of @code{number->string} when @var{number} is a flonum (and consequently controls all printing of -flonums). The value of this fluid is normally a list of three items: +flonums). The value of this parameter is normally a list of three items: @table @var @item rounding-type @@ -995,47 +995,47 @@ Some examples of @code{flonum-unparser-cutoff}: @example (number->string (* 4 (atan 1 1))) @result{} "3.141592653589793" -(let-fluid flonum-unparser-cutoff '(relative 5) +(parameterize ((flonum-unparser-cutoff '(relative 5))) (lambda () (number->string (* 4 (atan 1 1))))) @result{} "3.1416" -(let-fluid flonum-unparser-cutoff '(relative 5) +(parameterize ((flonum-unparser-cutoff '(relative 5))) (lambda () (number->string (* 4000 (atan 1 1))))) @result{} "3141.6" -(let-fluid flonum-unparser-cutoff '(relative 5 scientific) +(parameterize ((flonum-unparser-cutoff '(relative 5 scientific))) (lambda () (number->string (* 4000 (atan 1 1))))) @result{} "3.1416e3" -(let-fluid flonum-unparser-cutoff '(relative 5 scientific) +(parameterize ((flonum-unparser-cutoff '(relative 5 scientific))) (lambda () (number->string (* 40000 (atan 1 1))))) @result{} "3.1416e4" -(let-fluid flonum-unparser-cutoff '(relative 5 engineering) +(parameterize ((flonum-unparser-cutoff '(relative 5 engineering))) (lambda () (number->string (* 40000 (atan 1 1))))) @result{} "31.416e3" -(let-fluid flonum-unparser-cutoff '(absolute 5) +(parameterize ((flonum-unparser-cutoff '(absolute 5))) (lambda () (number->string (* 4 (atan 1 1))))) @result{} "3.14159" -(let-fluid flonum-unparser-cutoff '(absolute 5) +(parameterize ((flonum-unparser-cutoff '(absolute 5))) (lambda () (number->string (* 4000 (atan 1 1))))) @result{} "3141.59265" -(let-fluid flonum-unparser-cutoff '(absolute -4) +(parameterize ((flonum-unparser-cutoff '(absolute -4))) (lambda () (number->string (* 4e10 (atan 1 1))))) @result{} "31415930000." -(let-fluid flonum-unparser-cutoff '(absolute -4 scientific) +(parameterize ((flonum-unparser-cutoff '(absolute -4 scientific))) (lambda () (number->string (* 4e10 (atan 1 1))))) @result{} "3.141593e10" -(let-fluid flonum-unparser-cutoff '(absolute -4 engineering) +(parameterize ((flonum-unparser-cutoff '(absolute -4 engineering))) (lambda () (number->string (* 4e10 (atan 1 1))))) @result{} "31.41593e9" -(let-fluid flonum-unparser-cutoff '(absolute -5) +(parameterize ((flonum-unparser-cutoff '(absolute -5))) (lambda () (number->string (* 4e10 (atan 1 1))))) @result{} "31415900000." @@ -1364,7 +1364,7 @@ either an exact integer or an inexact real; the current implementation has been tuned to make these two cases fast. If @var{state} is given and not @code{#f}, it must be a random-state -object; otherwise, it defaults to the value of the fluid +object; otherwise, it defaults to the value of the parameter @code{*random-state*}. This object is used to maintain the state of the pseudo-random-number generator and is altered as a side effect of the @code{random} procedure. @@ -1399,20 +1399,20 @@ procedure. This allows a particular random-state object to be saved in order to replay a particular pseudo-random sequence. @defvr variable *random-state* -The value of this fluid is a data structure, a random-state object, that -encodes the internal state of the random-number generator that -@code{random} uses by default. A call to @code{random} will perform a -side effect on this data structure. The fluid may be changed, using -@code{set-fluid!} or @code{let-fluid}, to hold a new random-state object. +The value of this parameter is a data structure, a random-state +object, that encodes the internal state of the random-number generator +that @code{random} uses by default. A call to @code{random} will +perform a side effect on this data structure. The parameter may be +changed to hold a new random-state object. @end defvr @deffn procedure make-random-state [state] This procedure returns a new random-state object, suitable for use as -the value of the fluid @code{*random-state*}, or as the @var{state} +the value of the parameter @code{*random-state*}, or as the @var{state} argument to @code{random}. If @var{state} is not given or @code{#f}, @code{make-random-state} returns a @emph{copy} of the current random-number state object (the value of the @code{*random-state*} -fluid object). If @var{state} is a random-state object, a copy +parameter object). If @var{state} is a random-state object, a copy of that object is returned. If @var{state} is @code{#t}, then a new random-state object is returned that has been ``randomly'' initialized by some means (such as by a time-of-day clock). diff --git a/doc/ref-manual/os-interface.texi b/doc/ref-manual/os-interface.texi index 257365084..1cde5e567 100644 --- a/doc/ref-manual/os-interface.texi +++ b/doc/ref-manual/os-interface.texi @@ -543,11 +543,11 @@ from @var{defaults} together. @defvr variable *default-pathname-defaults* @cindex defaulting, of pathname -The value of this fluid (@pxref{Fluids}) is the default +The value of this parameter (@pxref{Parameters}) is the default pathname-defaults pathname; if any pathname primitive that needs a set of defaults is not given one, it uses this one. -@code{set-working-directory-pathname!} sets this fluid to a new value, -computed by merging the new working directory with the fluid's old +@code{set-working-directory-pathname!} sets this parameter to a new value, +computed by merging the new working directory with the parameter's old value. @end defvr @@ -846,7 +846,7 @@ working directory to @var{filename} and returns the value of @var{thunk} (a procedure of no arguments). @var{Filename} is coerced to a pathname using @code{pathname-as-directory}. In addition to binding the working directory, @code{with-working-directory-pathname} -also dynamically binds the @code{*default-pathname-defaults*} fluid, +also dynamically binds the @code{*default-pathname-defaults*} parameter, merging the old value with the new working directory pathname. @end deffn diff --git a/doc/ref-manual/special-forms.texi b/doc/ref-manual/special-forms.texi index 974facbb8..2aa3e2825 100644 --- a/doc/ref-manual/special-forms.texi +++ b/doc/ref-manual/special-forms.texi @@ -381,15 +381,14 @@ the call chain explicitly. @end group @end example -@cindex binding expression, dynamic (or fluid) -@cindex fluid binding +@cindex binding expression, dynamic @cindex dynamic binding -A @dfn{dynamic binding} or @dfn{fluid binding} changes the value of a -parameter (@pxref{Parameters}) or fluid (@pxref{Fluids}) object -temporarily, for a @dfn{dynamic extent}. The set of all fluid -bindings at a given time is called the @dfn{dynamic environment}. The -new values are only accessible to the thread that constructed the -dynamic environment, and any threads created within that environment. +A @dfn{dynamic binding} changes the value of a parameter +(@pxref{Parameters}) object temporarily, for a @dfn{dynamic extent}. +The set of all dynamic bindings at a given time is called the +@dfn{dynamic environment}. The new values are only accessible to the +thread that constructed the dynamic environment, and any threads +created within that environment. @cindex extent, of dynamic binding (defn) The @dfn{extent} of a dynamic binding is defined to be the time period @@ -407,38 +406,32 @@ environment captured by the continuation. When the continuation returns, the process is reversed, restoring the original dynamic environment. -The following example shows the interaction between dynamic -binding and continuations. Side effects to the binding that occur -both inside and outside of the body are preserved, even if -continuations are used to jump in and out of the body repeatedly. -A fluid object is used rather than a parameter only for variety. A -mutator similar to @code{set-fluid!} is available for parameter -bindings (@code{set-parameter!}). Both will modify the initial or -top-level value when the parameter or fluid is not bound in the -current dynamic environment. +The following example shows the interaction between dynamic binding +and continuations. Side effects to the binding that occur both inside +and outside of the body are preserved, even if continuations are used +to jump in and out of the body repeatedly. @example @group -(define (complicated-dynamic-binding) - (let ((variable (make-fluid 1)) +(define (complicated-dynamic-parameter) + (let ((variable (make-parameter 1)) (inside-continuation)) - (write-line (fluid variable)) + (write-line (variable)) (call-with-current-continuation (lambda (outside-continuation) - (let-fluid variable 2 - (lambda () - (write-line (fluid variable)) - (set-fluid! variable 3) - (call-with-current-continuation - (lambda (k) - (set! inside-continuation k) - (outside-continuation #t))) - (write-line (fluid variable)) - (set! inside-continuation #f))))) - (write-line (fluid variable)) + (parameterize ((variable 2)) + (write-line (variable)) + (variable 3) + (call-with-current-continuation + (lambda (k) + (set! inside-continuation k) + (outside-continuation #t))) + (write-line (variable)) + (set! inside-continuation #f)))) + (write-line (variable)) (if inside-continuation (begin - (set-fluid! variable 4) + (variable 4) (inside-continuation #f))))) @end group @end example @@ -459,17 +452,17 @@ the console: @noindent Commentary: the first two values written are the initial binding of -@code{variable} and its new binding after @code{let-fluid}'s thunk is -entered. Immediately after they are written, the binding visible in -the thunk is set to @samp{3}, and @code{outside-continuation} is -invoked, exiting the thunk. At this point, @samp{1} is written, -demonstrating that the original binding of @code{variable} is still -visible outside the thunk. Then we set @code{variable} to @samp{4} -and reenter the body by invoking @code{inside-continuation}. At this -point, @samp{3} is written, indicating that the binding modified in -the thunk is still the binding visible in the thunk. Finally, we exit -the thunk normally, and write @samp{4}, demonstrating that the binding -modified outside of the thunk was also preserved. +@code{variable} and its new binding inside @code{parameterize}'s body. +Immediately after they are written, the binding visible in the body +is set to @samp{3}, and @code{outside-continuation} is invoked, +exiting the body. At this point, @samp{1} is written, demonstrating +that the original binding of @code{variable} is still visible outside +the body. Then we set @code{variable} to @samp{4} and reenter the +body by invoking @code{inside-continuation}. At this point, @samp{3} +is written, indicating that the binding modified in the body is still +the binding visible in the body. Finally, we exit the body +normally, and write @samp{4}, demonstrating that the binding modified +outside of the body was also preserved. @subsection Fluid-Let @@ -479,8 +472,7 @@ multi-processing (SMP) world. It and the cell object type (@pxref{Cells}) are now @strong{deprecated}. They are still available and functional in a uni-processing (non-SMP) world, but will signal an error when used in an SMP world. The @code{parameterize} special form -(@pxref{parameterize}) or @code{let-fluids} procedure -(@pxref{let-fluids}) should be used instead. +(@pxref{parameterize}) should be used instead. @deffn {special form} fluid-let ((@var{variable} @var{init}) @dots{}) expression expression @dots{} @cindex variable binding, fluid-let diff --git a/src/6001/edextra.scm b/src/6001/edextra.scm index 93dac020f..b58510f22 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) - (let-fluid load/suppress-loading-message? #t + (parameterize* (list (cons load/suppress-loading-message? #t)) (lambda () (load pathname environment)))) diff --git a/src/6001/make.scm b/src/6001/make.scm index e6ebba905..64fb56905 100644 --- a/src/6001/make.scm +++ b/src/6001/make.scm @@ -39,17 +39,23 @@ USA. ;;; Customize the runtime system: (set! repl:allow-restart-notifications? #f) (set! repl:write-result-hash-numbers? #f) -(set-fluid! *pp-default-as-code?* #t) -(set-fluid! *pp-named-lambda->define?* 'LAMBDA) +(*pp-default-as-code?* #t) +(*pp-named-lambda->define?* 'LAMBDA) (set! x-graphics:auto-raise? #t) (set! (access write-result:undefined-value-is-special? (->environment '(RUNTIME USER-INTERFACE))) #f) -(set-fluid! hook/exit (lambda (integer) integer - (warn "EXIT has been disabled."))) -(set-fluid! hook/%exit (lambda (integer) integer - (warn "%EXIT has been disabled."))) -(set-fluid! hook/quit (lambda () (warn "QUIT has been disabled."))) +(hook/exit + (lambda (integer) + integer + (warn "EXIT has been disabled."))) +(hook/%exit + (lambda (integer) + integer + (warn "%EXIT has been disabled."))) +(hook/quit + (lambda () + (warn "QUIT has been disabled."))) (let ((edwin-env (->environment '(EDWIN))) (student-env (->environment '(STUDENT)))) diff --git a/src/6001/nodefs.scm b/src/6001/nodefs.scm index 802ecf5eb..f45f75d81 100644 --- a/src/6001/nodefs.scm +++ b/src/6001/nodefs.scm @@ -77,8 +77,8 @@ USA. (if (not (default-object? value)) (begin (write-string " --> " port) - (let-fluids *unparser-list-depth-limit* 2 - *unparser-list-breadth-limit* 10 - *unparser-string-length-limit* 30 + (parameterize* (list (cons *unparser-list-depth-limit* 2) + (cons *unparser-list-breadth-limit* 10) + (cons *unparser-string-length-limit* 30)) (lambda () (write value port)))))))) diff --git a/src/compiler/base/debug.scm b/src/compiler/base/debug.scm index d2b724502..d0632ca55 100644 --- a/src/compiler/base/debug.scm +++ b/src/compiler/base/debug.scm @@ -105,15 +105,15 @@ USA. (define (write-instructions thunk) (fluid-let ((*show-instruction* write)) - (let-fluids *unparser-radix* 16 - *unparse-uninterned-symbols-by-name?* #t + (parameterize* (list (cons *unparser-radix* 16) + (cons *unparse-uninterned-symbols-by-name?* #t)) thunk))) (define (pp-instructions thunk) (fluid-let ((*show-instruction* pretty-print)) - (let-fluids *pp-primitives-by-name* #f - *unparser-radix* 16 - *unparse-uninterned-symbols-by-name?* #t + (parameterize* (list (cons *pp-primitives-by-name* #f) + (cons *unparser-radix* 16) + (cons *unparse-uninterned-symbols-by-name?* #t)) thunk))) (define *show-instruction*) diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm index acf2204fb..842afc5c2 100644 --- a/src/compiler/base/object.scm +++ b/src/compiler/base/object.scm @@ -156,6 +156,6 @@ USA. (unparser/standard-method name)))) (define (tagged-vector/unparse state vector) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () ((tagged-vector/unparser vector) state vector)))) diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm index da2e246de..7dd7a50b3 100644 --- a/src/compiler/base/toplev.scm +++ b/src/compiler/base/toplev.scm @@ -1063,8 +1063,8 @@ USA. (define (phase/lap-file-output scode port) (compiler-phase "LAP File Output" (lambda () - (let-fluids *unparser-radix* 16 - *unparse-uninterned-symbols-by-name?* #t + (parameterize* (list (cons *unparser-radix* 16) + (cons *unparse-uninterned-symbols-by-name?* #t)) (lambda () (with-output-to-port port (lambda () diff --git a/src/compiler/machines/alpha/dassm1.scm b/src/compiler/machines/alpha/dassm1.scm index b6a13a7e0..aa6de8e3b 100644 --- a/src/compiler/machines/alpha/dassm1.scm +++ b/src/compiler/machines/alpha/dassm1.scm @@ -131,7 +131,7 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction) @@ -148,7 +148,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/constants-start block))) diff --git a/src/compiler/machines/bobcat/dassm1.scm b/src/compiler/machines/bobcat/dassm1.scm index f6e18dd9d..6a37eb763 100644 --- a/src/compiler/machines/bobcat/dassm1.scm +++ b/src/compiler/machines/bobcat/dassm1.scm @@ -117,7 +117,7 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction) @@ -134,7 +134,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/constants-start block))) diff --git a/src/compiler/machines/i386/dassm1.scm b/src/compiler/machines/i386/dassm1.scm index e7b798185..880ac5458 100644 --- a/src/compiler/machines/i386/dassm1.scm +++ b/src/compiler/machines/i386/dassm1.scm @@ -117,7 +117,7 @@ USA. (disassembler/instructions #f start-address end-address #f)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction comment) @@ -144,7 +144,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/marked-start block))) diff --git a/src/compiler/machines/mips/dassm1.scm b/src/compiler/machines/mips/dassm1.scm index f6e18dd9d..6a37eb763 100644 --- a/src/compiler/machines/mips/dassm1.scm +++ b/src/compiler/machines/mips/dassm1.scm @@ -117,7 +117,7 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction) @@ -134,7 +134,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/constants-start block))) diff --git a/src/compiler/machines/spectrum/dassm1.scm b/src/compiler/machines/spectrum/dassm1.scm index a6cb9bdf1..0adcc7b14 100644 --- a/src/compiler/machines/spectrum/dassm1.scm +++ b/src/compiler/machines/spectrum/dassm1.scm @@ -117,7 +117,7 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction) @@ -134,7 +134,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/constants-start block))) diff --git a/src/compiler/machines/svm/disassembler.scm b/src/compiler/machines/svm/disassembler.scm index 628c412b2..adcfee1d6 100644 --- a/src/compiler/machines/svm/disassembler.scm +++ b/src/compiler/machines/svm/disassembler.scm @@ -110,7 +110,7 @@ USA. (make-cursor block start symbol-table))) (define (write-instructions cursor) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (let ((end (compiled-code-block/code-end (cursor-block cursor)))) (let loop () @@ -219,7 +219,7 @@ USA. #t))))) (define (write-constants cursor) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (let* ((block (cursor-block cursor)) (end (compiled-code-block/index->offset diff --git a/src/compiler/machines/vax/dassm1.scm b/src/compiler/machines/vax/dassm1.scm index 3b29a4545..b9e7b401b 100644 --- a/src/compiler/machines/vax/dassm1.scm +++ b/src/compiler/machines/vax/dassm1.scm @@ -105,7 +105,7 @@ USA. (disassembler/instructions false start-address end-address false)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction) @@ -122,7 +122,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/constants-start block))) diff --git a/src/compiler/machines/x86-64/dassm1.scm b/src/compiler/machines/x86-64/dassm1.scm index e7b798185..880ac5458 100644 --- a/src/compiler/machines/x86-64/dassm1.scm +++ b/src/compiler/machines/x86-64/dassm1.scm @@ -117,7 +117,7 @@ USA. (disassembler/instructions #f start-address end-address #f)) (define (disassembler/write-instruction-stream symbol-table instruction-stream) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (disassembler/for-each-instruction instruction-stream (lambda (offset instruction comment) @@ -144,7 +144,7 @@ USA. (loop (instruction-stream))))))) (define (disassembler/write-constants-block block symbol-table) - (let-fluid *unparser-radix* 16 + (parameterize* (list (cons *unparser-radix* 16)) (lambda () (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/marked-start block))) diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm index 03a3e87b8..8cb1be85f 100644 --- a/src/edwin/artdebug.scm +++ b/src/edwin/artdebug.scm @@ -662,7 +662,7 @@ Move to the last subproblem if the subproblem number is too high." (pp (lambda (obj) (fresh-line port) (pp obj port #t)))) - + (if (dstate/reduction-number dstate) (pp (reduction-expression (dstate/reduction dstate))) (let ((exp (dstate/expression dstate)) @@ -681,7 +681,7 @@ Move to the last subproblem if the subproblem number is too high." (if (or argument (invalid-subexpression? sub)) (pp exp) - (let-fluid *pp-no-highlights?* #f + (parameterize* (list (cons *pp-no-highlights?* #f)) do-hairy))) ((debugging-info/noise? exp) (message ((debugging-info/noise exp) #t))) @@ -1013,7 +1013,7 @@ Prefix argument means do not kill the debugger buffer." port)))) (define (print-with-subexpression expression subexpression) - (let-fluid *unparse-primitives-by-name?* #t + (parameterize* (list (cons *unparse-primitives-by-name?* #t)) (lambda () (if (invalid-subexpression? subexpression) (write (unsyntax expression)) @@ -1043,7 +1043,7 @@ Prefix argument means do not kill the debugger buffer." port)) (define (print-reduction-as-subexpression expression) - (let-fluid *unparse-primitives-by-name?* #t + (parameterize* (list (cons *unparse-primitives-by-name?* #t)) (lambda () (write-string (ref-variable subexpression-start-marker)) (write (unsyntax expression)) diff --git a/src/edwin/autold.scm b/src/edwin/autold.scm index 151a9dc57..94cd32f1f 100644 --- a/src/edwin/autold.scm +++ b/src/edwin/autold.scm @@ -206,11 +206,12 @@ Second arg is prefix arg when called interactively." (bind-condition-handler (list condition-type:error) evaluation-error-handler (lambda () - (let-fluid load/suppress-loading-message? #t - (lambda () - ((message-wrapper #f "Loading " (car library)) - (lambda () - (load-library library))))))))) + (parameterize* + (list (cons 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)) @@ -235,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 () - (let-fluid load/suppress-loading-message? #t + (parameterize* (list (cons load/suppress-loading-message? #t)) (lambda () (load filename environment 'DEFAULT purify?)))))))) \ No newline at end of file diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm index 13946097f..7cbeb937d 100644 --- a/src/edwin/debug.scm +++ b/src/edwin/debug.scm @@ -49,7 +49,7 @@ USA. indentation port) (let ((start-mark #f) (end-mark #f)) - (let-fluid *pp-no-highlights?* #f + (parameterize* (list (cons *pp-no-highlights?* #f)) (lambda () (debugger-pp (unsyntax-with-substitutions @@ -1291,7 +1291,7 @@ it has been renamed, it will not be deleted automatically.") (cond ((debugging-info/compiled-code? expression) (write-string ";unknown compiled code" port)) ((not (debugging-info/undefined-expression? expression)) - (let-fluid *unparse-primitives-by-name?* #t + (parameterize* (list (cons *unparse-primitives-by-name?* #t)) (lambda () (write (unsyntax (if (invalid-subexpression? subexpression) @@ -1382,7 +1382,7 @@ it has been renamed, it will not be deleted automatically.") (subproblem/number (reduction/subproblem reduction))) port))) (write-string " " port) - (let-fluid *unparse-primitives-by-name?* #t + (parameterize* (list (cons *unparse-primitives-by-name?* #t)) (lambda () (write (unsyntax (reduction/expression reduction)) port))))) diff --git a/src/edwin/evlcom.scm b/src/edwin/evlcom.scm index 9ab7d8cf7..19ef0eca2 100644 --- a/src/edwin/evlcom.scm +++ b/src/edwin/evlcom.scm @@ -233,9 +233,10 @@ The values are printed in the typein window." (call-with-transcript-buffer (lambda (buffer) (insert-string - (let-fluid *unparse-with-maximum-readability?* #t - (lambda () - (write-to-string expression))) + (parameterize* + (list (cons *unparse-with-maximum-readability?* #t)) + (lambda () + (write-to-string expression))) (buffer-end buffer))))) (editor-eval buffer expression @@ -527,10 +528,10 @@ Set by Scheme evaluation code to update the mode line." (define (transcript-value-string value) (if (undefined-value? value) "" - (let-fluids *unparser-list-depth-limit* - (ref-variable transcript-list-depth-limit) - *unparser-list-breadth-limit* - (ref-variable transcript-list-breadth-limit) + (parameterize* (list (cons *unparser-list-depth-limit* + (ref-variable transcript-list-depth-limit)) + (cons *unparser-list-breadth-limit* + (ref-variable transcript-list-breadth-limit))) (lambda () (write-to-string value))))) diff --git a/src/edwin/filcom.scm b/src/edwin/filcom.scm index a1010cd6e..2fa542712 100644 --- a/src/edwin/filcom.scm +++ b/src/edwin/filcom.scm @@ -218,9 +218,10 @@ procedures are called." (lambda () (catch-file-errors (lambda (condition) condition #f) (lambda () - (let-fluid load/suppress-loading-message? #t - (lambda () - (load pathname '(EDWIN)))))))))))) + (parameterize* + (list (cons load/suppress-loading-message? #t)) + (lambda () + (load pathname '(EDWIN)))))))))))) (if (and (procedure? database) (procedure-arity-valid? database 1)) (database buffer) diff --git a/src/edwin/intmod.scm b/src/edwin/intmod.scm index 4a8bbf0a4..772099115 100644 --- a/src/edwin/intmod.scm +++ b/src/edwin/intmod.scm @@ -122,23 +122,23 @@ evaluated in the specified inferior REPL buffer." (detach-thread thread) thread)))) (attach-buffer-interface-port! buffer port) - (let-fluids hook/%exit inferior-repl/%exit - hook/quit inferior-repl/quit - (lambda () - (dynamic-wind - (lambda () unspecific) - (lambda () - (repl/start (make-repl #f - port - environment - #f - `((ERROR-DECISION ,error-decision)) - user-initial-prompt) - (make-init-message message))) - (lambda () - (signal-thread-event editor-thread - (lambda () - (unwind-inferior-repl-buffer buffer))))))))))) + (parameterize* (list (cons hook/%exit inferior-repl/%exit) + (cons hook/quit inferior-repl/quit)) + (lambda () + (dynamic-wind + (lambda () unspecific) + (lambda () + (repl/start (make-repl #f + port + environment + #f + `((ERROR-DECISION ,error-decision)) + user-initial-prompt) + (make-init-message message))) + (lambda () + (signal-thread-event editor-thread + (lambda () + (unwind-inferior-repl-buffer buffer))))))))))) (define (make-init-message message) (if message @@ -727,7 +727,7 @@ If this is an error, the debugger examines the error condition." (lambda (mark) (if mark (insert-string - (let-fluid *unparse-with-maximum-readability?* #t + (parameterize* (list (cons *unparse-with-maximum-readability?* #t)) (lambda () (write-to-string expression))) mark)))) diff --git a/src/edwin/prompt.scm b/src/edwin/prompt.scm index 8e5e1d95d..b3b89ea8c 100644 --- a/src/edwin/prompt.scm +++ b/src/edwin/prompt.scm @@ -978,7 +978,7 @@ it is added to the front of the command history." (set-prompt-history-strings! 'REPEAT-COMPLEX-COMMAND (map (lambda (command) - (let-fluid *unparse-with-maximum-readability?* #t + (parameterize* (list (cons *unparse-with-maximum-readability?* #t)) (lambda () (write-to-string command)))) (command-history-list))) diff --git a/src/edwin/schmod.scm b/src/edwin/schmod.scm index c2b6adc7d..140ff2198 100644 --- a/src/edwin/schmod.scm +++ b/src/edwin/schmod.scm @@ -232,8 +232,7 @@ The following commands evaluate Scheme expressions: (let ((environment (evaluation-environment #f))) (obarray-completions (if (and bound-only? - (fluid - (environment-lookup + ((environment-lookup environment '*PARSER-CANONICALIZE-SYMBOLS?*))) (string-downcase prefix) @@ -328,9 +327,10 @@ Otherwise, it is shown in the echo area." ((symbol? argl) (insert-string " . " point) (insert-string (symbol-name argl) point))))) - (let-fluid *unparse-uninterned-symbols-by-name?* #t - (lambda () - (message procedure-name ": " argl))))) + (parameterize* + (list (cons *unparse-uninterned-symbols-by-name?* #t)) + (lambda () + (message procedure-name ": " argl))))) (editor-error "Expression does not evaluate to a procedure: " (extract-string start end)))))))) diff --git a/src/ffi/build.scm b/src/ffi/build.scm index 3fd839a3e..7c740be29 100644 --- a/src/ffi/build.scm +++ b/src/ffi/build.scm @@ -83,7 +83,8 @@ USA. stringstring n) (- k 1)) " ") (let ((s - (let-fluid flonum-unparser-cutoff `(RELATIVE ,k ENGINEERING) + (parameterize* (list (cons flonum-unparser-cutoff + `(RELATIVE ,k ENGINEERING))) (lambda () (number->string (exact->inexact n)))))) (let ((regs (re-string-match "\\([0-9.]+\\)e\\([0-9]+\\)" s))) diff --git a/src/pcsample/pcsdisp.scm b/src/pcsample/pcsdisp.scm index 01bb86734..9d33c59f7 100644 --- a/src/pcsample/pcsdisp.scm +++ b/src/pcsample/pcsdisp.scm @@ -57,7 +57,7 @@ USA. (define pc-sample/code-block/status/display) (define pc-sample/interp-proc/status/display) (define pc-sample/prob-comp/status/display) -(define pc-sample/UFO/status/display) +(define pc-sample/UFO/status/display) (define (generate:pc-sample/status/displayer header-string display-proc) (lambda (#!optional subheader?) @@ -83,7 +83,7 @@ USA. (display (string-append "\n; " title-prefix-string)) (pc-sample/status/display/title-root-string) (pc-sample/status/display/header/delimiter)) - + (define-integrable (pc-sample/status/display/subheader subheader-title-string) (display (string-append "\n; " subheader-title-string "...")) (pc-sample/status/display/subheader/delimiter)) @@ -141,8 +141,9 @@ USA. (display-sample-list displayee)))))) (define (display-sample-list sample-list) ; not integrated so can play w/ it - (let-fluid *pp-default-as-code?* #T ; for now: just pp as code, but - (lambda () ; maybe opt for wizzy graphics later + ;; for now: just pp as code, but maybe opt for wizzy graphics later + (parameterize* (list (cons *pp-default-as-code?* #t) + (lambda () ; (pp sample-list)))) (define (install-displayers) @@ -179,7 +180,7 @@ USA. (thunk))) (define (pc-sample/builtin/display-acate) - (pc-sample/indexed-vector-table/display-acate + (pc-sample/indexed-vector-table/display-acate pc-sample/status/builtin-table pc-sample/builtin-table "Built-Ins" @@ -222,7 +223,7 @@ USA. (do ((index (-1+ (vector-length mumble-tbl)) (-1+ index))) ((negative? index) (if (null? disp-stack) - (string-append + (string-append "; ++++ No " mumble-string "s Sampled Yet ++++") `(,mumble-ID-fnord! ,count-acc @@ -238,7 +239,7 @@ USA. (string-append "; **** [" mumble-string " Table Uninitialized].")))) (define (pc-sample/code-block/display-acate) - (let ((BTW-string + (let ((BTW-string (string-append "\n" ";..............................................................\n" @@ -262,7 +263,7 @@ USA. (vector-map (lambda (elt) (let* ((coblx (profile-hash-table-car elt)) (datum (profile-hash-table-cdr elt)) - (count + (count (code-block-profile-datum/count datum)) (name-list (code-block/name/display-acate coblx))) @@ -291,7 +292,7 @@ USA. ,heathen-count-cell ,heathen-count-cell ) )) - (display-acated-purified-list + (display-acated-purified-list `(,@(first display-acated-p&h-lists) ,@(second display-acated-p&h-lists) ,@(third display-acated-p&h-lists) @@ -312,7 +313,7 @@ USA. ,@(sort-sample-list display-acated-purified-list)) ,(no-code-blocks-of-sort "Heathen" BTW-string 'BTW))) ((null? display-acated-purified-list) - `#((HEATHEN-FNORD! + `#((HEATHEN-FNORD! ,(cell-contents heathen-count-cell) ,@(sort-sample-list display-acated-heathen-list)) ,(no-code-blocks-of-sort "Purified" BTW-string 'BTW))) @@ -320,7 +321,7 @@ USA. `#(#((PURIFIED-FNORD! ,(cell-contents purified-count-cell) ,@(sort-sample-list display-acated-purified-list)) - (HEATHEN-FNORD! + (HEATHEN-FNORD! ,(cell-contents heathen-count-cell) ,@(sort-sample-list display-acated-heathen-list))) ,BTW-string))))))) @@ -365,7 +366,7 @@ USA. (unsyntax/truthfully/sublist 5 (if (compiled-expression? coblx) (compiled-expression/scode coblx) coblx)))) - ,(if (null? filename) + ,(if (null? filename) "[Not file-defined (i.e., interactively defined?)]" filename) ,(if (and (null? filename) (null? offset)) @@ -433,26 +434,26 @@ USA. ";~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n" "; +++ No " ID-string " Trampolines Sampled Yet +++\n" )) - + (define (pc-sample/interp-proc/display-acate) - (let ((BTW-string + (let ((BTW-string (string-append "\n" ";..............................................................\n" "; BTW: Interp-Proc Buffer Status (length . slack) = " - (write-to-string + (write-to-string (if *display-acation-status* (pc-sample/status/interp-proc-buffer/status *display-acation-status*) (pc-sample/interp-proc-buffer/status)))))) (if (interp-proc-profiling-disabled?) (string-append "; **** [Interp-Proc Profile Buffers Uninitialized]." - BTW-string) + BTW-string) (let* ((tally 0.) (display-acated-list (vector->list - (vector-map + (vector-map (lambda (elt) (let* ((lambx (profile-hash-table-car elt)) (datum (profile-hash-table-cdr elt)) @@ -597,7 +598,7 @@ USA. (else raw-display-acatee )))) ;; Cook half-baked display-acatee (cond ((pair? half-baked-display-acatee) - (set! tally + (set! tally (+ (second half-baked-display-acatee) tally)) (cddr half-baked-display-acatee)) ; de-fnord-ize ((vector? half-baked-display-acatee) @@ -646,7 +647,7 @@ USA. denom))) (flo:/ (flo:round pumped-percentage) *pc-sample/status/table/decimal-pump*))) - + (define-integrable (relevanticate numer denom interval) `#(,numer ,denom ,(make-rectangular (/ (flo:round->exact numer) (flo:round->exact denom)) diff --git a/src/runtime/advice.scm b/src/runtime/advice.scm index 81c525f56..766c4ff10 100644 --- a/src/runtime/advice.scm +++ b/src/runtime/advice.scm @@ -35,23 +35,23 @@ USA. (define (initialize-package!) (set! entry-advice-population (make-population)) (set! exit-advice-population (make-population)) - (set! advice-continuation (make-fluid #f)) - (set! the-arguments (make-fluid #f)) - (set! the-procedure (make-fluid #f)) - (set! the-result (make-fluid #f))) + (set! advice-continuation (make-parameter #f)) + (set! the-arguments (make-parameter #f)) + (set! the-procedure (make-parameter #f)) + (set! the-result (make-parameter #f))) (define the-arguments) (define the-procedure) (define the-result) (define (*args*) - (list-copy (fluid the-arguments))) + (list-copy (the-arguments))) (define (*proc*) - (fluid the-procedure)) + (the-procedure)) (define (*result*) - (fluid the-result)) + (the-result)) (define (get-advice procedure) (lambda-advice (procedure-lambda procedure))) @@ -83,7 +83,7 @@ USA. (lambda (original-body state) (call-with-current-continuation (lambda (continuation) - (let-fluid advice-continuation continuation + (parameterize* (list (cons advice-continuation continuation)) (lambda () (with-restart 'USE-VALUE "Return a value from the advised procedure." @@ -315,15 +315,15 @@ USA. ;;;; Break (define (break-entry-advice procedure arguments environment) - (let-fluids the-procedure procedure - the-arguments arguments + (parameterize* (list (cons the-procedure procedure) + (cons the-arguments arguments)) (lambda () (break-rep environment "Breakpoint on entry" procedure arguments)))) (define (break-exit-advice procedure arguments result environment) - (let-fluids the-procedure procedure - the-arguments arguments - the-result result + (parameterize* (list (cons the-procedure procedure) + (cons the-arguments arguments) + (cons the-result result)) (lambda () (break-rep environment "Breakpoint on exit" procedure arguments result))) result) @@ -334,7 +334,7 @@ USA. (apply trace-display port info))) message) environment - (fluid advice-continuation))) + (advice-continuation))) (define (break-entry procedure) (advise-entry procedure break-entry-advice)) diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index 53913213e..0ba8e8f59 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -63,7 +63,7 @@ USA. (lambda (state object) (let ((port (unparser-state/port state)) (hash-string (number->string (hash object)))) - (if (fluid *unparse-with-maximum-readability?*) + (if (*unparse-with-maximum-readability?*) (begin (write-string "#@" port) (write-string hash-string port)) diff --git a/src/runtime/debug.scm b/src/runtime/debug.scm index b89d6e9b3..892a8f200 100644 --- a/src/runtime/debug.scm +++ b/src/runtime/debug.scm @@ -162,8 +162,8 @@ USA. (stack-frame/reductions (dstate/subproblem dstate))) (define (initialize-package!) - (set! *dstate* (make-fluid 'UNBOUND)) - (set! *port* (make-fluid 'UNBOUND)) + (set! *dstate* (make-parameter 'UNBOUND)) + (set! *port* (make-parameter 'UNBOUND)) (set! command-set (make-command-set @@ -235,9 +235,9 @@ USA. (port (caddr (cadr form)))) `(DEFINE (,(car (cadr form)) #!OPTIONAL ,dstate ,port) (LET ((,dstate (IF (DEFAULT-OBJECT? ,dstate) - (FLUID *DSTATE*) + (*DSTATE*) ,dstate)) - (,port (IF (DEFAULT-OBJECT? ,port) (FLUID *PORT*) ,port))) + (,port (IF (DEFAULT-OBJECT? ,port) (*PORT*) ,port))) ,@(map (let ((free (list dstate port))) (lambda (expression) (make-syntactic-closure environment free @@ -474,7 +474,7 @@ USA. (output-to-string 50 (lambda () - (let-fluid *unparse-primitives-by-name?* true + (parameterize* (list (cons *unparse-primitives-by-name?* true)) (lambda () (write (unsyntax expression))))))) ((debugging-info/noise? expression) @@ -810,8 +810,8 @@ USA. (define *port*) (define (command/internal dstate port) - (let-fluids *dstate* dstate - *port* port + (parameterize* (list (cons *dstate* dstate) + (cons *port* port)) (lambda () (debug/read-eval-print (->environment '(RUNTIME DEBUGGER)) "the debugger" @@ -956,9 +956,12 @@ using the read-eval-print environment instead.") (string-capitalize (if reason (string-append reason "; " message) message))) (define (debugger-pp expression indentation port) - (let-fluids *unparser-list-depth-limit* debugger:list-depth-limit - *unparser-list-breadth-limit* debugger:list-breadth-limit - *unparser-string-length-limit* debugger:string-length-limit + (parameterize* (list (cons *unparser-list-depth-limit* + debugger:list-depth-limit) + (cons *unparser-list-breadth-limit* + debugger:list-breadth-limit) + (cons *unparser-string-length-limit* + debugger:string-length-limit)) (lambda () (pretty-print expression port true indentation)))) diff --git a/src/runtime/dosdir.scm b/src/runtime/dosdir.scm index 5c624f69b..94b3d6593 100644 --- a/src/runtime/dosdir.scm +++ b/src/runtime/dosdir.scm @@ -33,7 +33,7 @@ USA. (define *expand-directory-prefixes?*) (define (initialize-package!) - (set! *expand-directory-prefixes?* (make-fluid true))) + (set! *expand-directory-prefixes?* (make-parameter true))) (define (directory-read pattern #!optional sort?) (if (if (default-object? sort?) true sort?) @@ -56,9 +56,10 @@ USA. (merge-pathnames pathname directory-path)) (let ((pathnames (let ((fnames (generate-directory-pathnames directory-path))) - (let-fluid *expand-directory-prefixes?* false - (lambda () - (map ->pathname fnames)))))) + (parameterize* + (list (cons *expand-directory-prefixes?* false)) + (lambda () + (map ->pathname fnames)))))) (if (and (eq? (pathname-name pattern) 'WILD) (eq? (pathname-type pattern) 'WILD)) pathnames diff --git a/src/runtime/dospth.scm b/src/runtime/dospth.scm index 4e6c23946..cd634842b 100644 --- a/src/runtime/dospth.scm +++ b/src/runtime/dospth.scm @@ -113,7 +113,7 @@ USA. (cdr components)))))) (let ((end (string-length string))) (if (or (= 0 end) - (not (fluid *expand-directory-prefixes?*))) + (not (*expand-directory-prefixes?*))) components (case (string-ref string 0) ((#\$) diff --git a/src/runtime/dragon4.scm b/src/runtime/dragon4.scm index 8ce596a96..42ab9f72c 100644 --- a/src/runtime/dragon4.scm +++ b/src/runtime/dragon4.scm @@ -127,7 +127,7 @@ not much different to numbers within a few orders of magnitude of 1. exponent))))) (define (flonum-unparser-cutoff-args) - (let ((cutoff (fluid flonum-unparser-cutoff))) + (let ((cutoff (flonum-unparser-cutoff))) (cond ((eq? 'NORMAL cutoff) (values 'NORMAL 0 flonum-unparser:normal-output)) ((and (pair? cutoff) @@ -279,7 +279,7 @@ not much different to numbers within a few orders of magnitude of 1. (define expt-radix) (define (initialize-dragon4!) - (set! flonum-unparser-cutoff (make-fluid 'NORMAL)) + (set! flonum-unparser-cutoff (make-parameter 'NORMAL)) (set! expt-radix (let ((v (make-initialized-vector 310 (lambda (i) (expt 10 i))))) (lambda (base exponent) @@ -294,7 +294,7 @@ not much different to numbers within a few orders of magnitude of 1. (define (test) (define (try n settings . expecteds) - (let ((got (let-fluid flonum-unparser-cutoff settings + (let ((got (parameterize* (list (cons flonum-unparser-cutoff settings)) (lambda () (number->string (exact->inexact n)))))) (if (member got expecteds) diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm index 873492491..bf646a681 100644 --- a/src/runtime/dynamic.scm +++ b/src/runtime/dynamic.scm @@ -54,33 +54,19 @@ USA. (define-guarantee parameter "parameter") (define (make-parameter init #!optional converter) - (let ((converter - (if (default-object? converter) - (lambda (x) x) - converter))) - (let ((metadata (cons converter (converter init)))) - - (define (get-binding) - (or (assq metadata bindings) - metadata)) - - (define (get) - (cdr (get-binding))) - - (define (set new-value) - (let ((binding (get-binding)) - (converted (converter new-value))) - (let ((old-value (cdr binding))) - (set-cdr! binding converted) - old-value))) - - (let ((parameter - (lambda (#!optional new-value) - (if (default-object? new-value) - (get) - (set new-value))))) - (set-parameter-metadata! parameter metadata) - parameter)))) + (let* ((converter + (if (default-object? converter) + (lambda (x) x) + converter)) + (metadata (cons converter (converter init))) + (parameter + (lambda (#!optional new-value) + (let ((p (or (assq metadata bindings) metadata))) + (if (default-object? new-value) + (cdr p) + (set-cdr! p (converter new-value))))))) + (set-parameter-metadata! parameter metadata) + parameter)) (define (parameterize* new-bindings thunk) (guarantee-alist new-bindings 'parameterize*) @@ -95,35 +81,4 @@ USA. (lambda () (set! bindings (set! temp (set! bindings))) unspecific))) - (shallow-fluid-bind swap! thunk swap!)))) - -;;;; Fluids (to be eliminated) - -(define (fluid? object) - (parameter? object)) - -(define (make-fluid value) - (make-parameter value)) - -(define (fluid f) - (guarantee-parameter f 'fluid) - (f)) - -(define (set-fluid! f val) - (guarantee-parameter f 'set-fluid!) - (f val)) - -(define (let-fluid fluid value thunk) - (parameterize* (list (cons fluid value)) thunk)) - -(define (let-fluids . args) - (let loop - ((args args) - (new-bindings '())) - (if (not (pair? args)) - (error "Ill-formed let-fluids arguments:" args)) - (if (pair? (cdr args)) - (loop (cddr args) - (cons (cons (car args) (cadr args)) - new-bindings)) - (parameterize* new-bindings (car args))))) \ No newline at end of file + (shallow-fluid-bind swap! thunk swap!)))) \ No newline at end of file diff --git a/src/runtime/error.scm b/src/runtime/error.scm index 5098ff6e4..e1cd90815 100644 --- a/src/runtime/error.scm +++ b/src/runtime/error.scm @@ -225,7 +225,7 @@ USA. (define-integrable (%restarts-argument restarts operator) (cond ((eq? 'BOUND-RESTARTS restarts) - (fluid *bound-restarts*)) + (*bound-restarts*)) ((condition? restarts) (%condition/restarts restarts)) (else @@ -334,10 +334,11 @@ USA. (error:wrong-type-argument effector "effector" 'WITH-RESTART)) (if (not (or (not interactor) (procedure? interactor))) (error:wrong-type-argument interactor "interactor" 'WITH-RESTART)) - (let-fluid *bound-restarts* - (cons (%make-restart name reporter effector interactor) - (fluid *bound-restarts*)) - thunk)) + (parameterize* + (list (cons *bound-restarts* + (cons (%make-restart name reporter effector interactor) + (*bound-restarts*)))) + thunk)) (define (with-simple-restart name reporter thunk) (call-with-current-continuation @@ -382,7 +383,7 @@ USA. (define (bind-restart name reporter effector receiver) (with-restart name reporter effector #f (lambda () - (receiver (car (fluid *bound-restarts*)))))) + (receiver (car (*bound-restarts*)))))) (define (invoke-restart restart . arguments) (guarantee-restart restart 'INVOKE-RESTART) @@ -424,13 +425,13 @@ USA. (define hook/invoke-restart) (define (bound-restarts) - (let loop ((restarts (fluid *bound-restarts*))) + (let loop ((restarts (*bound-restarts*))) (if (pair? restarts) (cons (car restarts) (loop (cdr restarts))) '()))) (define (first-bound-restart) - (let ((restarts (fluid *bound-restarts*))) + (let ((restarts (*bound-restarts*))) (if (not (pair? restarts)) (error:no-such-restart #f)) (car restarts))) @@ -489,7 +490,7 @@ USA. (define (restarts-default restarts name) (cond ((or (default-object? restarts) (eq? 'BOUND-RESTARTS restarts)) - (fluid *bound-restarts*)) + (*bound-restarts*)) ((condition? restarts) (%condition/restarts restarts)) (else @@ -505,24 +506,25 @@ USA. (define (bind-default-condition-handler types handler) (guarantee-condition-types types 'BIND-DEFAULT-CONDITION-HANDLER) (guarantee-condition-handler handler 'BIND-DEFAULT-CONDITION-HANDLER) - (set-fluid! static-handler-frames - (cons (cons types handler) - (fluid static-handler-frames))) + (static-handler-frames + (cons (cons types handler) + (static-handler-frames))) unspecific) (define (bind-condition-handler types handler thunk) (guarantee-condition-types types 'BIND-CONDITION-HANDLER) (guarantee-condition-handler handler 'BIND-CONDITION-HANDLER) - (let-fluid dynamic-handler-frames - (cons (cons types handler) (fluid dynamic-handler-frames)) - thunk)) + (parameterize* + (list (cons dynamic-handler-frames + (cons (cons types handler) (dynamic-handler-frames)))) + thunk)) (define-integrable (guarantee-condition-handler object caller) (guarantee-procedure-of-arity object 1 caller)) (define (break-on-signals types) (guarantee-condition-types types 'BREAK-ON-SIGNALS) - (set-fluid! break-on-signals-types types) + (break-on-signals-types types) unspecific) (define hook/invoke-condition-handler) @@ -543,29 +545,29 @@ USA. (inner (cdr generalizations))) (and (pair? types) (outer (car types) (cdr types))))))))) - (if (let ((types (fluid break-on-signals-types))) + (if (let ((types (break-on-signals-types))) (and (pair? types) (intersect-generalizations? types))) - (let-fluid break-on-signals-types '() + (parameterize* (list (cons break-on-signals-types '())) (lambda () (breakpoint-procedure 'INHERIT "BKPT entered because of BREAK-ON-SIGNALS:" condition)))) - (do ((frames (fluid dynamic-handler-frames) (cdr frames))) + (do ((frames (dynamic-handler-frames) (cdr frames))) ((not (pair? frames))) (if (let ((types (caar frames))) (or (not (pair? types)) (intersect-generalizations? types))) - (let-fluid dynamic-handler-frames (cdr frames) + (parameterize* (list (cons dynamic-handler-frames (cdr frames))) (lambda () (hook/invoke-condition-handler (cdar frames) condition))))) - (do ((frames (fluid static-handler-frames) (cdr frames))) + (do ((frames (static-handler-frames) (cdr frames))) ((not (pair? frames))) (if (let ((types (caar frames))) (or (not (pair? types)) (intersect-generalizations? types))) - (let-fluids dynamic-handler-frames '() - static-handler-frames (cdr frames) + (parameterize* (list (cons dynamic-handler-frames '()) + (cons static-handler-frames (cdr frames))) (lambda () (hook/invoke-condition-handler (cdar frames) condition))))) unspecific))) @@ -603,17 +605,17 @@ USA. (default-handler condition))))))) (define (standard-error-handler condition) - (let ((hook (fluid standard-error-hook))) + (let ((hook (standard-error-hook))) (if hook - (let-fluid standard-error-hook #f + (parameterize* (list (cons standard-error-hook #f)) (lambda () (hook condition))))) (repl/start (push-repl 'INHERIT condition '() "error>"))) (define (standard-warning-handler condition) - (let ((hook (fluid standard-warning-hook))) + (let ((hook (standard-warning-hook))) (if hook - (let-fluid standard-warning-hook #f + (parameterize* (list (cons standard-warning-hook #f)) (lambda () (hook condition))) (let ((port (notification-output-port))) @@ -766,12 +768,12 @@ USA. (memq condition-type:error (%condition-type/generalizations type))) (define (initialize-package!) - (set! *bound-restarts* (make-fluid '())) - (set! static-handler-frames (make-fluid '())) - (set! dynamic-handler-frames (make-fluid '())) - (set! break-on-signals-types (make-fluid '())) - (set! standard-error-hook (make-fluid #f)) - (set! standard-warning-hook (make-fluid #f)) + (set! *bound-restarts* (make-parameter '())) + (set! static-handler-frames (make-parameter '())) + (set! dynamic-handler-frames (make-parameter '())) + (set! break-on-signals-types (make-parameter '())) + (set! standard-error-hook (make-parameter #f)) + (set! standard-warning-hook (make-parameter #f)) (set! hook/invoke-condition-handler default/invoke-condition-handler) ;; No eta conversion for bootstrapping and efficiency reasons. (set! hook/invoke-restart @@ -1256,8 +1258,8 @@ USA. (else (error "Unexpected value:" v))))))) (define (format-error-message message irritants port) - (let-fluids *unparser-list-depth-limit* 2 - *unparser-list-breadth-limit* 5 + (parameterize* (list (cons *unparser-list-depth-limit* 2) + (cons *unparser-list-breadth-limit* 5)) (lambda () (for-each (lambda (irritant) (if (and (pair? irritant) diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index d4d5c7937..ec7733754 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -592,10 +592,11 @@ USA. (define (load-ffi-quietly) (if (not (name->package '(FFI))) - (let ((kernel (lambda () - (let-fluid load/suppress-loading-message? #t - (lambda () - (load-option 'FFI)))))) + (let ((kernel + (lambda () + (parameterize* (list (cons load/suppress-loading-message? #t)) + (lambda () + (load-option 'FFI)))))) (if (nearest-cmdl/batch-mode?) (kernel) (with-notification (lambda (port) diff --git a/src/runtime/file-attributes.scm b/src/runtime/file-attributes.scm index efe837d0b..6d2351dc9 100644 --- a/src/runtime/file-attributes.scm +++ b/src/runtime/file-attributes.scm @@ -120,28 +120,33 @@ This file is part of MIT/GNU Scheme. (define (parse-file-attributes-item parse port) ;; Prepare the parser for first mode. - (let-fluids *parser-associate-positions?* #f - *parser-atom-delimiters* char-set/file-attributes-atom-delimiters - *parser-canonicalize-symbols?* #f - *parser-constituents* char-set/file-attributes-constituents - *parser-enable-file-attributes-parsing?* #f ; no recursion! - *parser-keyword-style* #f - *parser-radix* 10 - *parser-table* file-attributes-parser-table + (parameterize* (list (cons *parser-associate-positions?* #f) + (cons *parser-atom-delimiters* + char-set/file-attributes-atom-delimiters) + (cons *parser-canonicalize-symbols?* #f) + (cons *parser-constituents* + char-set/file-attributes-constituents) + ;; no recursion! + (cons *parser-enable-file-attributes-parsing?* + #f) + (cons *parser-keyword-style* #f) + (cons *parser-radix* 10) + (cons *parser-table* file-attributes-parser-table)) (lambda () (parse port system-global-environment)))) (define (parse-file-attributes-value parse port) ;; Prepare the parser for second mode. - (let-fluids *parser-associate-positions?* #f - *parser-atom-delimiters* char-set/atom-delimiters - *parser-canonicalize-symbols?* #f - *parser-constituents* char-set/constituents - *parser-enable-file-attributes-parsing?* #f ; no recursion! - ;; enable prefix keywords - *parser-keyword-style* 'prefix - *parser-radix* 10 - *parser-table* system-global-parser-table + (parameterize* (list (cons *parser-associate-positions?* #f) + (cons *parser-atom-delimiters* char-set/atom-delimiters) + (cons *parser-canonicalize-symbols?* #f) + (cons *parser-constituents* char-set/constituents) + ;; no recursion! + (cons *parser-enable-file-attributes-parsing?* #f) + ;; enable prefix keywords + (cons *parser-keyword-style* 'prefix) + (cons *parser-radix* 10) + (cons *parser-table* system-global-parser-table)) (lambda () (parse port system-global-environment)))) diff --git a/src/runtime/gcdemn.scm b/src/runtime/gcdemn.scm index 101fca850..1a981e0e1 100644 --- a/src/runtime/gcdemn.scm +++ b/src/runtime/gcdemn.scm @@ -68,7 +68,7 @@ USA. (define (add-gc-daemon!/no-restore daemon) (add-gc-daemon! (lambda () - (if (not (fluid *within-restore-window?*)) + (if (not (*within-restore-window?*)) (daemon))))) ;;; SECONDARY-GC-DAEMONS are executed rarely. Their purpose is to diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 117b8153a..9194b52cb 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -94,9 +94,9 @@ USA. ((#x00020100 #x0004030000020100) #f) (else (error "Unable to determine endianness of host.")))) (add-secondary-gc-daemon! clean-obarray) - (set! hook/exit (make-fluid default/exit)) - (set! hook/%exit (make-fluid default/%exit)) - (set! hook/quit (make-fluid default/quit)) + (set! hook/exit (make-parameter default/exit)) + (set! hook/%exit (make-parameter default/%exit)) + (set! hook/quit (make-parameter default/quit)) ;; Kludge until the next released version, to avoid a bootstrapping ;; failure. (set! ephemeron-type (microcode-type 'EPHEMERON)) @@ -208,7 +208,7 @@ USA. (wait-loop))))) (define (exit #!optional integer) - ((fluid hook/exit) (if (default-object? integer) #f integer))) + ((hook/exit) (if (default-object? integer) #f integer))) (define (default/exit integer) (if (prompt-for-confirmation "Kill Scheme") @@ -218,7 +218,7 @@ USA. (define hook/%exit) (define (%exit #!optional integer) - ((fluid hook/%exit) integer)) + ((hook/%exit) integer)) (define (default/%exit #!optional integer) (event-distributor/invoke! event:before-exit) @@ -228,7 +228,7 @@ USA. ((ucode-primitive exit-with-value 1) integer))) (define (quit) - ((fluid hook/quit))) + ((hook/quit))) (define (%quit) (with-absolutely-no-interrupts (ucode-primitive halt)) diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm index 0e373884c..48ad7a655 100644 --- a/src/runtime/infutl.scm +++ b/src/runtime/infutl.scm @@ -37,7 +37,7 @@ USA. (,lambda-tag:internal-lexpr . LAMBDA) (,lambda-tag:let . LET) (,lambda-tag:fluid-let . FLUID-LET))) - (set! directory-rewriting-rules (make-fluid '())) + (set! directory-rewriting-rules (make-parameter '())) (set! wrappers-with-memoized-debugging-info (make-serial-population)) (add-secondary-gc-daemon! discard-debugging-info!)) @@ -213,29 +213,30 @@ USA. (define directory-rewriting-rules) (define (with-directory-rewriting-rule match replace thunk) - (let-fluid directory-rewriting-rules - (cons (cons (pathname-as-directory (merge-pathnames match)) - replace) - (fluid directory-rewriting-rules)) - thunk)) + (parameterize* + (list (cons directory-rewriting-rules + (cons (cons (pathname-as-directory (merge-pathnames match)) + replace) + (directory-rewriting-rules)))) + thunk)) (define (add-directory-rewriting-rule! match replace) (let ((match (pathname-as-directory (merge-pathnames match)))) (let ((rule - (list-search-positive (fluid directory-rewriting-rules) + (list-search-positive (directory-rewriting-rules) (lambda (rule) (equal? (pathname-directory (car rule)) (pathname-directory match)))))) (if rule (set-cdr! rule replace) - (set-fluid! directory-rewriting-rules - (cons (cons match replace) - (fluid directory-rewriting-rules)))))) + (directory-rewriting-rules + (cons (cons match replace) + (directory-rewriting-rules)))))) unspecific) (define (rewrite-directory pathname) (let ((rule - (list-search-positive (fluid directory-rewriting-rules) + (list-search-positive (directory-rewriting-rules) (lambda (rule) (directory-prefix? (pathname-directory pathname) (pathname-directory (car rule))))))) diff --git a/src/runtime/load.scm b/src/runtime/load.scm index 1c88ee99d..b39be6422 100644 --- a/src/runtime/load.scm +++ b/src/runtime/load.scm @@ -34,13 +34,13 @@ 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)) - (set! *write-notifications?* (make-fluid #t)) - (set! *load-init-file?* (make-fluid #t)) + (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)) (initialize-command-line-parsers) (set! hook/process-command-line default/process-command-line) (add-event-receiver! event:after-restart process-command-line)) @@ -76,7 +76,7 @@ USA. (define (load-1 pathname environment purify?) (receive (pathname* loader notifier) (choose-load-method pathname) (if pathname* - (maybe-notify (fluid load/suppress-loading-message?) + (maybe-notify (load/suppress-loading-message?) (loader environment purify?) notifier) (load-failure load-1 pathname environment purify?)))) @@ -228,11 +228,11 @@ USA. (define (maybe-notify suppress-notifications? loader notifier) (let ((notify? (if (if (default-object? suppress-notifications?) - (fluid load/suppress-loading-message?) + (load/suppress-loading-message?) suppress-notifications?) #f - (fluid *write-notifications?*)))) - (let-fluid *write-notifications?* notify? + (*write-notifications?*)))) + (parameterize* (list (cons *write-notifications?* notify?)) (lambda () (if notify? (notifier loader) @@ -254,11 +254,11 @@ USA. (thunk))) (define (with-eval-unit uri thunk) - (let-fluid *eval-unit* (->absolute-uri uri 'WITH-EVAL-UNIT) + (parameterize* (list (cons *eval-unit* (->absolute-uri uri 'WITH-EVAL-UNIT))) thunk)) (define (current-eval-unit #!optional error?) - (let ((unit (fluid *eval-unit*))) + (let ((unit (*eval-unit*))) (if (and (not unit) (if (default-object? error?) #t error?)) (error condition-type:not-loading)) @@ -269,35 +269,35 @@ USA. (error condition-type:not-loading))) (define (current-load-environment) - (let ((env (fluid *current-load-environment*))) + (let ((env (*current-load-environment*))) (if (eq? env 'NONE) (nearest-repl/environment) env))) (define (set-load-environment! environment) (guarantee-environment environment 'SET-LOAD-ENVIRONMENT!) - (if (not (eq? (fluid *current-load-environment*) 'NONE)) + (if (not (eq? (*current-load-environment*) 'NONE)) (begin - (set-fluid! *current-load-environment* environment) + (*current-load-environment* environment) unspecific))) (define (with-load-environment environment thunk) (guarantee-environment environment 'WITH-LOAD-ENVIRONMENT) - (let-fluid *current-load-environment* environment + (parameterize* (list (cons *current-load-environment* environment)) thunk)) (define (load/push-hook! hook) - (if (not (fluid load/loading?)) (error condition-type:not-loading)) - (set-fluid! load/after-load-hooks (cons hook (fluid load/after-load-hooks))) + (if (not (load/loading?)) (error condition-type:not-loading)) + (load/after-load-hooks (cons hook (load/after-load-hooks))) unspecific) (define (handle-load-hooks thunk) (receive (result hooks) - (let-fluids load/loading? #t - load/after-load-hooks '() + (parameterize* (list (cons load/loading? #t) + (cons load/after-load-hooks '())) (lambda () (let ((result (thunk))) - (values result (reverse (fluid load/after-load-hooks)))))) + (values result (reverse (load/after-load-hooks)))))) (for-each (lambda (hook) (hook)) hooks) result)) @@ -506,13 +506,13 @@ USA. (if unused-command-line (begin (set! *unused-command-line*) - (let-fluid *load-init-file?* #t + (parameterize* (list (cons *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 (fluid *load-init-file?*) (load-init-file))))) + (if (*load-init-file?*) (load-init-file))))) (begin (set! *unused-command-line* #f) (load-init-file))))) @@ -662,7 +662,7 @@ ADDITIONAL OPTIONS supported by this band:\n") (set! *command-line-parsers* '()) (simple-command-line-parser "no-init-file" (lambda () - (set-fluid! *load-init-file?* #f) + (*load-init-file?* #f) unspecific) "Inhibits automatic loading of the ~/.scheme.init file.") (set! generate-suspend-file? #f) @@ -683,7 +683,8 @@ ADDITIONAL OPTIONS supported by this band:\n") (lambda (arg) (run-in-nearest-repl (lambda (repl) - (let-fluid load/suppress-loading-message? (cmdl/batch-mode? repl) + (parameterize* (list (cons load/suppress-loading-message? + (cmdl/batch-mode? repl))) (lambda () (load arg (repl/environment repl))))))) "Loads the argument files as if in the REPL." diff --git a/src/runtime/ntdir.scm b/src/runtime/ntdir.scm index 120bb432f..4fc60ff49 100644 --- a/src/runtime/ntdir.scm +++ b/src/runtime/ntdir.scm @@ -32,7 +32,7 @@ USA. (define *expand-directory-prefixes?*) (define (initialize-package!) - (set! *expand-directory-prefixes?* (make-fluid #t))) + (set! *expand-directory-prefixes?* (make-parameter #t))) (define (directory-read pattern #!optional sort? full?) (let ((sort? (if (default-object? sort?) #t sort?)) @@ -57,7 +57,7 @@ USA. (lambda (pathname) (merge-pathnames pathname directory-path))) (let ((fnames (generate-directory-pathnames pattern))) - (let-fluid *expand-directory-prefixes?* #f + (parameterize* (list (cons *expand-directory-prefixes?* #f)) (lambda () (map ->pathname fnames))))))) @@ -78,7 +78,7 @@ USA. (cons (merge-pathnames (car entry) directory-path) (cdr entry)))) (let ((entries (generate-directory-entries pattern))) - (let-fluid *expand-directory-prefixes?* #f + (parameterize* (list (cons *expand-directory-prefixes?* #f)) (lambda () (map (lambda (entry) (cons (->pathname (car entry)) (cdr entry))) entries))))))) diff --git a/src/runtime/option.scm b/src/runtime/option.scm index a97bb7b0f..8da212b4e 100644 --- a/src/runtime/option.scm +++ b/src/runtime/option.scm @@ -46,29 +46,29 @@ USA. (define (search-parent pathname) (call-with-values (lambda () - (let-fluids *options* '() - *parent* #f - load/suppress-loading-message? #t + (parameterize* (list (cons *options* '()) + (cons *parent* #f) + (cons load/suppress-loading-message? #t)) (lambda () (load pathname (make-load-environment)) - (values (fluid *options*) (fluid *parent*))))) + (values (*options*) (*parent*))))) find-option)) (define (make-load-environment) (let ((e (extend-top-level-environment system-global-environment))) - (environment-define e '*PARSER-CANONICALIZE-SYMBOLS?* (make-fluid #t)) + (environment-define e '*PARSER-CANONICALIZE-SYMBOLS?* (make-parameter #t)) e)) (if (memq name loaded-options) name - (find-option (fluid *options*) (fluid *parent*))))) + (find-option (*options*) (*parent*))))) (define (define-load-option name . loaders) - (set-fluid! *options* (cons (cons name loaders) (fluid *options*))) + (*options* (cons (cons name loaders) (*options*))) unspecific) (define (further-load-options place) - (set-fluid! *parent* place) + (*parent* place) unspecific) (define (initial-load-options) @@ -99,8 +99,8 @@ USA. (define *initial-options-file* #f) (define (initialize-package!) - (set! *options* (make-fluid '())) - (set! *parent* (make-fluid initial-load-options))) + (set! *options* (make-parameter '())) + (set! *parent* (make-parameter initial-load-options))) (define (dummy-option-loader) unspecific) diff --git a/src/runtime/os2dir.scm b/src/runtime/os2dir.scm index adee94b0e..10b04bc86 100644 --- a/src/runtime/os2dir.scm +++ b/src/runtime/os2dir.scm @@ -32,7 +32,7 @@ USA. (define *expand-directory-prefixes?*) (define (initialize-package!) - (set! *expand-directory-prefixes?* (make-fluid #t))) + (set! *expand-directory-prefixes?* (make-parameter #t))) (define (directory-read pattern #!optional sort?) (if (if (default-object? sort?) #t sort?) @@ -45,7 +45,7 @@ USA. (lambda (pathname) (merge-pathnames pathname directory-path))) (let ((fnames (generate-directory-pathnames pattern))) - (let-fluid *expand-directory-prefixes?* #f + (parameterize* (list (cons *expand-directory-prefixes?* #f)) (lambda () (map ->pathname fnames))))))) diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm index 1bd81f966..45de6b379 100644 --- a/src/runtime/parse.scm +++ b/src/runtime/parse.scm @@ -133,22 +133,22 @@ USA. (define char-set/number-leaders) (define (initialize-package!) - (set! *parser-associate-positions?* (make-fluid #f)) - (set! *parser-atom-delimiters* (make-fluid 'UNBOUND)) - (set! *parser-canonicalize-symbols?* (make-fluid #t)) - (set! *parser-constituents* (make-fluid 'UNBOUND)) - (set! *parser-enable-file-attributes-parsing?* (make-fluid #t)) - (set! *parser-keyword-style* (make-fluid #f)) - (set! *parser-radix* (make-fluid 10)) - (set! *parser-table* (make-fluid 'UNBOUND)) - (set! runtime-parser-associate-positions? (make-fluid #f)) - (set! runtime-parser-atom-delimiters (make-fluid 'UNBOUND)) - (set! runtime-parser-canonicalize-symbols? (make-fluid #t)) - (set! runtime-parser-constituents (make-fluid 'UNBOUND)) - (set! runtime-parser-enable-file-attributes-parsing? (make-fluid #t)) - (set! runtime-parser-keyword-style (make-fluid #f)) - (set! runtime-parser-radix (make-fluid 10)) - (set! runtime-parser-table (make-fluid 'UNBOUND)) + (set! *parser-associate-positions?* (make-parameter #f)) + (set! *parser-atom-delimiters* (make-parameter 'UNBOUND)) + (set! *parser-canonicalize-symbols?* (make-parameter #t)) + (set! *parser-constituents* (make-parameter 'UNBOUND)) + (set! *parser-enable-file-attributes-parsing?* (make-parameter #t)) + (set! *parser-keyword-style* (make-parameter #f)) + (set! *parser-radix* (make-parameter 10)) + (set! *parser-table* (make-parameter 'UNBOUND)) + (set! runtime-parser-associate-positions? (make-parameter #f)) + (set! runtime-parser-atom-delimiters (make-parameter 'UNBOUND)) + (set! runtime-parser-canonicalize-symbols? (make-parameter #t)) + (set! runtime-parser-constituents (make-parameter 'UNBOUND)) + (set! runtime-parser-enable-file-attributes-parsing? (make-parameter #t)) + (set! runtime-parser-keyword-style (make-parameter #f)) + (set! runtime-parser-radix (make-parameter 10)) + (set! runtime-parser-table (make-parameter 'UNBOUND)) (let* ((constituents (char-set-difference char-set:graphic char-set:whitespace)) @@ -207,12 +207,12 @@ USA. (set! char-set/atom-delimiters atom-delimiters) (set! char-set/symbol-quotes symbol-quotes) (set! char-set/number-leaders number-leaders) - (set-fluid! *parser-atom-delimiters* atom-delimiters) - (set-fluid! *parser-constituents* constituents) - (set-fluid! runtime-parser-atom-delimiters atom-delimiters) - (set-fluid! runtime-parser-constituents constituents)) - (set-fluid! *parser-table* system-global-parser-table) - (set-fluid! runtime-parser-table system-global-parser-table) + (*parser-atom-delimiters* atom-delimiters) + (*parser-constituents* constituents) + (runtime-parser-atom-delimiters atom-delimiters) + (runtime-parser-constituents constituents)) + (*parser-table* system-global-parser-table) + (runtime-parser-table system-global-parser-table) (set! hashed-object-interns (make-strong-eq-hash-table)) (initialize-condition-types!)) @@ -812,14 +812,14 @@ USA. (begin (guarantee-environment environment #f) environment))) - (atom-delimiters (fluid (repl-environment-value - environment '*PARSER-ATOM-DELIMITERS*))) - (constituents (fluid (repl-environment-value environment - '*PARSER-CONSTITUENTS*)))) + (atom-delimiters + ((repl-environment-value environment '*PARSER-ATOM-DELIMITERS*))) + (constituents + ((repl-environment-value environment '*PARSER-CONSTITUENTS*)))) (guarantee-char-set atom-delimiters #f) (guarantee-char-set constituents #f) - (make-db (fluid (repl-environment-value environment - '*PARSER-ASSOCIATE-POSITIONS?*)) + (make-db ((repl-environment-value environment + '*PARSER-ASSOCIATE-POSITIONS?*)) atom-delimiters (overridable-value port environment '*PARSER-CANONICALIZE-SYMBOLS?*) @@ -827,8 +827,8 @@ USA. (overridable-value port environment '*PARSER-ENABLE-FILE-ATTRIBUTES-PARSING?*) (overridable-value port environment '*PARSER-KEYWORD-STYLE*) - (fluid (repl-environment-value environment '*PARSER-RADIX*)) - (fluid (repl-environment-value environment '*PARSER-TABLE*)) + ((repl-environment-value environment '*PARSER-RADIX*)) + ((repl-environment-value environment '*PARSER-TABLE*)) (make-shared-objects) (port/operation port 'DISCRETIONARY-WRITE-CHAR) (position-operation port environment) @@ -852,13 +852,12 @@ USA. (let* ((nope "no-overridden-value") (v (port/get-property port name nope))) (if (eq? v nope) - (fluid (repl-environment-value environment name)) + ((repl-environment-value environment name)) v))) (define (position-operation port environment) (let ((default (lambda (port) port #f))) - (if (fluid (repl-environment-value environment - '*PARSER-ASSOCIATE-POSITIONS?*)) + (if ((repl-environment-value environment '*PARSER-ASSOCIATE-POSITIONS?*)) (or (port/operation port 'POSITION) default) default))) diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm index ff1b0e0ca..42a8c25be 100644 --- a/src/runtime/pathnm.scm +++ b/src/runtime/pathnm.scm @@ -328,7 +328,7 @@ these rules: (define (uri->pathname uri #!optional error?) (let ((uri (->uri uri (and error? 'URI->PATHNAME))) - (defaults (fluid *default-pathname-defaults*)) + (defaults (*default-pathname-defaults*)) (finish (lambda (device path keyword) (receive (directory name type) @@ -389,7 +389,7 @@ these rules: (pathname-host (if (and (not (default-object? defaults)) defaults) defaults - (fluid *default-pathname-defaults*)))))) + (*default-pathname-defaults*)))))) (cond ((string? namestring) ((host-type/operation/parse-namestring (host/type host)) namestring host)) @@ -422,7 +422,7 @@ these rules: (let ((defaults (if (and (not (default-object? defaults)) defaults) (->pathname defaults) - (fluid *default-pathname-defaults*)))) + (*default-pathname-defaults*)))) (let ((pathname (enough-pathname pathname defaults))) (let ((namestring (pathname->namestring pathname))) (if (host=? (%pathname-host pathname) (%pathname-host defaults)) @@ -442,7 +442,7 @@ these rules: (let* ((defaults (if (and (not (default-object? defaults)) defaults) (->pathname defaults) - (fluid *default-pathname-defaults*))) + (*default-pathname-defaults*))) (pathname (pathname-arg pathname defaults 'MERGE-PATHNAMES))) (make-pathname (or (%pathname-host pathname) (%pathname-host defaults)) @@ -472,7 +472,7 @@ these rules: (let* ((defaults (if (and (not (default-object? defaults)) defaults) (->pathname defaults) - (fluid *default-pathname-defaults*))) + (*default-pathname-defaults*))) (pathname (pathname-arg pathname defaults 'ENOUGH-PATHNAME))) (let ((usual (lambda (component default) @@ -634,18 +634,18 @@ these rules: 'with-system-library-directories directories)))) - (let-fluid library-directory-path - (append (map existing-directory directories) - (fluid library-directory-path)) + (parameterize* (list (cons library-directory-path + (append (map existing-directory directories) + (library-directory-path)))) thunk)) (define (%find-library-directory) (pathname-simplify - (or (find-matching-item (fluid library-directory-path) file-directory?) + (or (find-matching-item (library-directory-path) file-directory?) (error "Can't find library directory.")))) (define (%find-library-file pathname) - (let loop ((path (fluid library-directory-path))) + (let loop ((path (library-directory-path))) (and (pair? path) (let ((p (merge-pathnames pathname (car path)))) (if (file-exists? p) @@ -717,9 +717,9 @@ these rules: (set! host-types types) (set! local-host (make-host host-type #f)))) (set! *default-pathname-defaults* - (make-fluid (make-pathname local-host #f #f #f #f #f))) + (make-parameter (make-pathname local-host #f #f #f #f #f))) (set! library-directory-path - (make-fluid + (make-parameter (map pathname-as-directory (vector->list ((ucode-primitive microcode-library-path 0)))))) unspecific) diff --git a/src/runtime/port.scm b/src/runtime/port.scm index a5e357c56..2b61ad00d 100644 --- a/src/runtime/port.scm +++ b/src/runtime/port.scm @@ -792,76 +792,74 @@ USA. (define *interaction-i/o-port*) (define (initialize-package!) - (set! *current-input-port* (make-fluid #f)) - (set! *current-output-port* (make-fluid #f)) - (set! *notification-output-port* (make-fluid #f)) - (set! *trace-output-port* (make-fluid #f)) - (set! *interaction-i/o-port* (make-fluid #f))) + (set! *current-input-port* (make-parameter #f)) + (set! *current-output-port* (make-parameter #f)) + (set! *notification-output-port* (make-parameter #f)) + (set! *trace-output-port* (make-parameter #f)) + (set! *interaction-i/o-port* (make-parameter #f))) (define (current-input-port) - (or (fluid *current-input-port*) (nearest-cmdl/port))) + (or (*current-input-port*) (nearest-cmdl/port))) (define (set-current-input-port! port) - (set-fluid! *current-input-port* - (guarantee-input-port port 'SET-CURRENT-INPUT-PORT!)) + (*current-input-port* (guarantee-input-port port 'SET-CURRENT-INPUT-PORT!)) unspecific) (define (with-input-from-port port thunk) - (let-fluid - *current-input-port* (guarantee-input-port port 'WITH-INPUT-FROM-PORT) - thunk)) + (parameterize* (list (cons *current-input-port* + (guarantee-input-port port 'WITH-INPUT-FROM-PORT))) + thunk)) (define (current-output-port) - (or (fluid *current-output-port*) (nearest-cmdl/port))) + (or (*current-output-port*) (nearest-cmdl/port))) (define (set-current-output-port! port) - (set-fluid! *current-output-port* - (guarantee-output-port port 'SET-CURRENT-OUTPUT-PORT!)) + (*current-output-port* (guarantee-output-port port 'SET-CURRENT-OUTPUT-PORT!)) unspecific) (define (with-output-to-port port thunk) - (let-fluid - *current-output-port* (guarantee-output-port port 'WITH-OUTPUT-TO-PORT) - thunk)) + (parameterize* (list (cons *current-output-port* + (guarantee-output-port port 'WITH-OUTPUT-TO-PORT))) + thunk)) (define (notification-output-port) - (or (fluid *notification-output-port*) (nearest-cmdl/port))) + (or (*notification-output-port*) (nearest-cmdl/port))) (define (set-notification-output-port! port) - (set-fluid! *notification-output-port* - (guarantee-output-port port 'SET-NOTIFICATION-OUTPUT-PORT!)) + (*notification-output-port* + (guarantee-output-port port 'SET-NOTIFICATION-OUTPUT-PORT!)) unspecific) (define (with-notification-output-port port thunk) - (let-fluid - *notification-output-port* - (guarantee-output-port port 'WITH-NOTIFICATION-OUTPUT-PORT) + (parameterize* + (list (cons *notification-output-port* + (guarantee-output-port port 'WITH-NOTIFICATION-OUTPUT-PORT))) thunk)) (define (trace-output-port) - (or (fluid *trace-output-port*) (nearest-cmdl/port))) + (or (*trace-output-port*) (nearest-cmdl/port))) (define (set-trace-output-port! port) - (set-fluid! *trace-output-port* - (guarantee-output-port port 'SET-TRACE-OUTPUT-PORT!)) + (*trace-output-port* (guarantee-output-port port 'SET-TRACE-OUTPUT-PORT!)) unspecific) (define (with-trace-output-port port thunk) - (let-fluid - *trace-output-port* (guarantee-output-port port 'WITH-TRACE-OUTPUT-PORT) + (parameterize* + (list (cons *trace-output-port* + (guarantee-output-port port 'WITH-TRACE-OUTPUT-PORT))) thunk)) (define (interaction-i/o-port) - (or (fluid *interaction-i/o-port*) (nearest-cmdl/port))) + (or (*interaction-i/o-port*) (nearest-cmdl/port))) (define (set-interaction-i/o-port! port) - (set-fluid! *interaction-i/o-port* - (guarantee-i/o-port port 'SET-INTERACTION-I/O-PORT!)) + (*interaction-i/o-port* (guarantee-i/o-port port 'SET-INTERACTION-I/O-PORT!)) unspecific) (define (with-interaction-i/o-port port thunk) - (let-fluid - *interaction-i/o-port* (guarantee-i/o-port port 'WITH-INTERACTION-I/O-PORT) + (parameterize* + (list (cons *interaction-i/o-port* + (guarantee-i/o-port port 'WITH-INTERACTION-I/O-PORT))) thunk)) (define standard-port-accessors diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index 77fe2b456..dfb966017 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -30,19 +30,19 @@ USA. (declare (usual-integrations)) (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-named-lambda->define?* (make-parameter #f)) + (set! *pp-primitives-by-name* (make-parameter #t)) + (set! *pp-uninterned-symbols-by-name* (make-parameter #t)) + (set! *pp-no-highlights?* (make-parameter #t)) + (set! *pp-save-vertical-space?* (make-parameter #f)) + (set! *pp-lists-as-tables?* (make-parameter #t)) + (set! *pp-forced-x-size* (make-parameter #f)) + (set! *pp-avoid-circularity?* (make-parameter #f)) + (set! *pp-default-as-code?* (make-parameter #t)) + (set! *pp-auto-highlighter* (make-parameter #f)) + (set! *pp-arity-dispatched-procedure-style* (make-parameter 'FULL)) + (set! x-size (make-parameter #f)) + (set! output-port (make-parameter #f)) (set! pp-description (make-generic-procedure 1 'PP-DESCRIPTION)) (set-generic-procedure-default-generator! pp-description (lambda (generic tags) @@ -54,7 +54,7 @@ USA. (set! print-let-expression (special-printer kernel/print-let-expression)) (set! print-case-expression (special-printer kernel/print-case-expression)) (set! code-dispatch-list - (make-fluid + (make-parameter `((COND . ,forced-indentation) (CASE . ,print-case-expression) (IF . ,forced-indentation) @@ -68,8 +68,8 @@ USA. (DEFINE-INTEGRABLE . ,print-procedure) (LAMBDA . ,print-procedure) (NAMED-LAMBDA . ,print-procedure)))) - (set! dispatch-list (make-fluid (fluid code-dispatch-list))) - (set! dispatch-default (make-fluid print-combination)) + (set! dispatch-list (make-parameter (code-dispatch-list))) + (set! dispatch-default (make-parameter print-combination)) (set! cocked-object (generate-uninterned-symbol)) unspecific) @@ -129,7 +129,7 @@ USA. (define (unsyntax-entity object) (define (unsyntax-entry procedure) - (case (fluid *pp-arity-dispatched-procedure-style*) + (case (*pp-arity-dispatched-procedure-style*) ((FULL) (unsyntax-entity procedure)) ((NAMED) (let ((text (unsyntax-entity procedure))) @@ -166,7 +166,7 @@ USA. (define (pretty-print object #!optional port as-code? indentation) (let ((as-code? (if (default-object? as-code?) - (let ((default (fluid *pp-default-as-code?*))) + (let ((default (*pp-default-as-code?*))) (if (boolean? default) default (not (scode-constant? object)))) @@ -178,9 +178,9 @@ USA. (if (and as-code? (pair? sexp) (eq? (car sexp) 'NAMED-LAMBDA) - (fluid *pp-named-lambda->define?*)) + (*pp-named-lambda->define?*)) (if (and (eq? 'LAMBDA - (fluid *pp-named-lambda->define?*)) + (*pp-named-lambda->define?*)) (pair? (cdr sexp)) (pair? (cadr sexp))) `(LAMBDA ,(cdadr sexp) ,@(cddr sexp)) @@ -212,7 +212,7 @@ USA. (lambda (s) (if (string? s) (*unparse-string s) - (s (fluid output-port)))))) + (s (output-port)))))) (print-string (pph/start-string pph)) (thunk) (print-string (pph/end-string pph)))) @@ -230,17 +230,18 @@ USA. 0))) (define (pp-top-level expression port as-code? indentation list-depth) - (let-fluids x-size (- (or (fluid *pp-forced-x-size*) - (output-port/x-size port)) 1) - output-port port - *unparse-uninterned-symbols-by-name?* - (fluid *pp-uninterned-symbols-by-name*) - *unparse-abbreviate-quotations?* - (or as-code? - (fluid *unparse-abbreviate-quotations?*)) + (parameterize* (list (cons x-size + (- (or (*pp-forced-x-size*) + (output-port/x-size port)) 1)) + (cons output-port port) + (cons *unparse-uninterned-symbols-by-name?* + (*pp-uninterned-symbols-by-name*)) + (cons *unparse-abbreviate-quotations?* + (or as-code? + (*unparse-abbreviate-quotations?*)))) (lambda () (let* ((numerical-walk - (if (fluid *pp-avoid-circularity?*) + (if (*pp-avoid-circularity?*) numerical-walk-avoid-circularities numerical-walk)) (node (numerical-walk expression list-depth))) @@ -255,10 +256,10 @@ USA. (define output-port) (define-integrable (*unparse-char char) - (output-port/write-char (fluid output-port) char)) + (output-port/write-char (output-port) char)) (define-integrable (*unparse-string string) - (output-port/write-string (fluid output-port) string)) + (output-port/write-string (output-port) string)) (define-integrable (*unparse-open) (*unparse-char #\()) @@ -273,17 +274,17 @@ USA. (*unparse-char #\newline)) (define (print-non-code-node node column depth) - (let-fluids dispatch-list '() - dispatch-default - (if (fluid *pp-lists-as-tables?*) - print-data-table - print-data-column) + (parameterize* (list (cons dispatch-list '()) + (cons dispatch-default + (if (*pp-lists-as-tables?*) + print-data-table + print-data-column))) (lambda () (print-node node column depth)))) (define (print-code-node node column depth) - (let-fluids dispatch-list code-dispatch-list - dispatch-default print-combination + (parameterize* (list (cons dispatch-list code-dispatch-list) + (cons dispatch-default print-combination)) (lambda () (print-node node column depth)))) @@ -307,7 +308,7 @@ USA. (let ((new-column (+ column (string-length (prefix-node-prefix node)))) (subnode (prefix-node-subnode node))) - (if (null? (fluid dispatch-list)) + (if (null? (dispatch-list)) (print-node subnode new-column depth) (print-non-code-node subnode new-column depth)))) ((highlighted-node? node) @@ -316,8 +317,7 @@ USA. (lambda () (let ((handler (let ((as-code? (pph/as-code? highlight)) - (currently-as-code? (not (null? (fluid - dispatch-list))))) + (currently-as-code? (not (null? (dispatch-list))))) (cond ((or (eq? as-code? 'DEFAULT) (eq? as-code? currently-as-code?)) print-node) @@ -332,19 +332,19 @@ USA. (*unparse-string node)))) (define (print-list-node node column depth) - (if (and (fluid *pp-save-vertical-space?*) + (if (and (*pp-save-vertical-space?*) (fits-within? node column depth)) (print-guaranteed-list-node node) (let* ((subnodes (node-subnodes node)) (association (and (not (null? (cdr subnodes))) - (assq (unhighlight (car subnodes)) (fluid dispatch-list))))) + (assq (unhighlight (car subnodes)) (dispatch-list))))) (if (and (not association) (fits-within? node column depth)) (print-guaranteed-list-node node) ((if association (cdr association) - (fluid dispatch-default)) + (dispatch-default)) subnodes column depth))))) (define (print-guaranteed-node node) @@ -410,7 +410,7 @@ USA. (define (default) (print-column nodes column depth)) - (let* ((available-space (- (fluid x-size) column)) + (let* ((available-space (- (x-size) column)) (n-nodes (length nodes)) (max-cols (quotient (+ n-nodes 1) 2))) @@ -617,7 +617,7 @@ USA. ;;;; Alignment (define-integrable (fits-within? node column depth) - (> (- (fluid x-size) depth) + (> (- (x-size) depth) (+ column (node-size node)))) ;;; Fits if each node fits when stacked vertically at the given column. @@ -626,7 +626,7 @@ USA. (let loop ((nodes nodes)) (if (null? (cdr nodes)) (fits-within? (car nodes) column depth) - (and (> (fluid x-size) + (and (> (x-size) (+ column (node-size (car nodes)))) (loop (cdr nodes)))))) @@ -635,7 +635,7 @@ USA. (define (two-on-first-line? nodes column depth) (let ((column (+ column (+ 1 (node-size (car nodes)))))) - (and (> (fluid x-size) column) + (and (> (x-size) column) (fits-as-column? (cdr nodes) column depth)))) ;;; Starts a new line with the specified indentation. @@ -662,7 +662,7 @@ USA. (walk-custom unparser object list-depth) (walk-pair object list-depth)))))) ((symbol? object) - (if (or (fluid *pp-uninterned-symbols-by-name*) + (if (or (*pp-uninterned-symbols-by-name*) (interned-symbol? object)) object (walk-custom unparse-object object list-depth))) @@ -686,7 +686,7 @@ USA. (walk-pair (vector->list object) list-depth)))))) ((primitive-procedure? object) - (if (fluid *pp-primitives-by-name*) + (if (*pp-primitives-by-name*) (primitive-procedure-name object) (walk-custom unparse-object object list-depth))) (else @@ -699,7 +699,7 @@ USA. ;; otherwise we would get infinite recursion when the `unwrapped' ;; object REST is re-auto-highlighted by the test below. - (cond ((let ((highlighter (fluid *pp-auto-highlighter*))) + (cond ((let ((highlighter (*pp-auto-highlighter*))) (and highlighter (not (pretty-printer-highlight? object)) (highlighter object))) @@ -718,14 +718,14 @@ USA. object)))) (define (walk-pair pair list-depth) - (if (let ((limit (fluid *unparser-list-depth-limit*))) + (if (let ((limit (*unparser-list-depth-limit*))) (and limit (>= list-depth limit) (no-highlights? pair))) "..." (let ((list-depth (+ list-depth 1))) (let loop ((pair pair) (list-breadth 0)) - (cond ((let ((limit (fluid *unparser-list-breadth-limit*))) + (cond ((let ((limit (*unparser-list-breadth-limit*))) (and limit (>= list-breadth limit) (no-highlights? pair))) @@ -743,8 +743,7 @@ USA. (make-list-node "." (make-singleton-list-node - (if (let ((limit - (fluid *unparser-list-breadth-limit*))) + (if (let ((limit (*unparser-list-breadth-limit*))) (and limit (>= list-breadth limit) (no-highlights? pair))) @@ -753,7 +752,7 @@ USA. list-depth))))))))))))) (define-integrable (no-highlights? object) - (or (fluid *pp-no-highlights?*) + (or (*pp-no-highlights?*) (not (partially-highlighted? object)))) (define (partially-highlighted? object) @@ -769,15 +768,15 @@ USA. (define (walk-highlighted-object object list-depth numerical-walk) (let ((dl (pph/depth-limit object))) - (let-fluids *unparser-list-breadth-limit* - (let ((bl (pph/breadth-limit object))) - (if (eq? bl 'DEFAULT) - (fluid *unparser-list-breadth-limit*) - bl)) - *unparser-list-depth-limit* - (if (eq? dl 'DEFAULT) - (fluid *unparser-list-depth-limit*) - dl) + (parameterize* (list (cons *unparser-list-breadth-limit* + (let ((bl (pph/breadth-limit object))) + (if (eq? bl 'DEFAULT) + (*unparser-list-breadth-limit*) + bl))) + (cons *unparser-list-depth-limit* + (if (eq? dl 'DEFAULT) + (*unparser-list-depth-limit*) + dl))) (lambda () (numerical-walk (pph/object object) (if (eq? dl 'DEFAULT) @@ -828,7 +827,7 @@ USA. (walk-pair-terminating object half-pointer/queue list-depth)))))) ((symbol? object) - (if (or (fluid *pp-uninterned-symbols-by-name*) + (if (or (*pp-uninterned-symbols-by-name*) (interned-symbol? object)) object (walk-custom unparse-object object list-depth))) @@ -851,7 +850,7 @@ USA. (vector->list object) half-pointer/queue list-depth)))))) ((primitive-procedure? object) - (if (fluid *pp-primitives-by-name*) + (if (*pp-primitives-by-name*) (primitive-procedure-name object) (walk-custom unparse-object object list-depth))) (else @@ -860,7 +859,7 @@ USA. ;;; The following two procedures walk lists and vectors, respectively. (define (walk-pair-terminating pair half-pointer/queue list-depth) - (if (let ((limit (fluid *unparser-list-depth-limit*))) + (if (let ((limit (*unparser-list-depth-limit*))) (and limit (>= list-depth limit) (no-highlights? pair))) @@ -868,7 +867,7 @@ USA. (let ((list-depth (+ list-depth 1))) (let loop ((pair pair) (list-breadth 0) (half-pointer/queue half-pointer/queue)) - (cond ((let ((limit (fluid *unparser-list-breadth-limit*))) + (cond ((let ((limit (*unparser-list-breadth-limit*))) (and limit (>= list-breadth limit) (no-highlights? pair))) @@ -911,7 +910,7 @@ USA. "." (make-singleton-list-node (if - (let ((limit (fluid *unparser-list-breadth-limit*))) + (let ((limit (*unparser-list-breadth-limit*))) (and limit (>= list-breadth limit) (no-highlights? pair))) @@ -928,14 +927,14 @@ USA. half-pointer/queue list-depth))))))))))))))) (define (walk-vector-terminating pair half-pointer/queue list-depth) - (if (let ((limit (fluid *unparser-list-depth-limit*))) + (if (let ((limit (*unparser-list-depth-limit*))) (and limit (>= list-depth limit) (no-highlights? pair))) "..." (let ((list-depth (+ list-depth 1))) (let loop ((pair pair) (list-breadth 0)) - (cond ((let ((limit (fluid *unparser-list-breadth-limit*))) + (cond ((let ((limit (*unparser-list-breadth-limit*))) (and limit (>= list-breadth limit) (no-highlights? pair))) @@ -968,7 +967,7 @@ USA. "." (make-singleton-list-node (if (let ((limit - (fluid *unparser-list-breadth-limit*))) + (*unparser-list-breadth-limit*))) (and limit (>= list-breadth limit) (no-highlights? pair))) @@ -1028,7 +1027,7 @@ USA. (constructor make-queue (#!optional cons-cell past-cdrs))) - (cons-cell (let* ((new-vector (make-fluid-vector)) + (cons-cell (let* ((new-vector (make-parameter-vector)) (pointer (cons 0 new-vector))) (cons pointer pointer))) (past-cdrs 0)) @@ -1041,7 +1040,7 @@ USA. (define virtual-fluid-vector-length (-1+ default-fluid-vector-length)) (define (fluid-vector-extend fluid-vector) - (define new-fluid-vector (make-fluid-vector)) + (define new-fluid-vector (make-parameter-vector)) (vector-set! fluid-vector virtual-fluid-vector-length new-fluid-vector) new-fluid-vector) @@ -1051,7 +1050,7 @@ USA. (vector-set! fluid-vector index object) (fluid-vector-set! tail (- index virtual-fluid-vector-length) object))) -(define (make-fluid-vector) +(define (make-parameter-vector) (make-vector default-fluid-vector-length #f)) ;;; The actual queue constructors/extractors @@ -1158,7 +1157,7 @@ USA. (write symbol port))))) (define (*unparse-symbol symbol) - (write symbol (fluid output-port))) + (write symbol (output-port))) (define-structure (prefix-node (conc-name prefix-node-) diff --git a/src/runtime/prgcop.scm b/src/runtime/prgcop.scm index 5aeef2ec0..d80984128 100644 --- a/src/runtime/prgcop.scm +++ b/src/runtime/prgcop.scm @@ -33,8 +33,8 @@ USA. (object-new-type primitive-object-new-type 2)) (define (initialize-package!) - (set! *copy-constants?* (make-fluid 'UNBOUND)) - (set! *object-copies* (make-fluid 'UNBOUND)) + (set! *copy-constants?* (make-parameter 'UNBOUND)) + (set! *object-copies* (make-parameter 'UNBOUND)) (set! copier/scode-walker (make-scode-walker copy-constant @@ -66,10 +66,10 @@ USA. (list '*OBJECT-COPIES*)) (define-integrable (object-association object) - (assq object (cdr (fluid *object-copies*)))) + (assq object (cdr (*object-copies*)))) (define (add-association! object other) - (let* ((table (fluid *object-copies*)) + (let* ((table (*object-copies*)) (place (assq object (cdr table)))) (cond ((not place) (set-cdr! table (cons (cons object other) (cdr table)))) @@ -83,12 +83,12 @@ USA. ;; do not have enough information to determine what the ;; variable name was. The original block can be used for ;; this, but it may as well be copied then. - (let-fluids *copy-constants?* - (if (default-object? copy-constants?) - *default/copy-constants?* - copy-constants?) - *object-copies* - (make-object-association-table) + (parameterize* (list (cons *copy-constants?* + (if (default-object? copy-constants?) + *default/copy-constants?* + copy-constants?)) + (cons *object-copies* + (make-object-association-table))) (lambda () (copy-object exp)))) @@ -103,7 +103,7 @@ USA. (%copy-compiled-code-address obj)) ((compiled-code-block? obj) (%copy-compiled-code-block obj)) - ((not (fluid *copy-constants?*)) + ((not (*copy-constants?*)) obj) (else (%copy-constant obj)))) diff --git a/src/runtime/random.scm b/src/runtime/random.scm index 980d81f83..68310b072 100644 --- a/src/runtime/random.scm +++ b/src/runtime/random.scm @@ -381,7 +381,7 @@ USA. (error:wrong-type-argument state "random state" procedure)) state) (let ((state (if *random-state* - (fluid *random-state*) + (*random-state*) ;; For early in the cold-load... default-random-source))) (if (not (random-state? state)) @@ -412,10 +412,10 @@ USA. unspecific) (define (finalize-random-state-type!) - (set! *random-state* (make-fluid default-random-source)) + (set! *random-state* (make-parameter default-random-source)) (add-event-receiver! event:after-restart (lambda () - (let ((state (fluid *random-state*))) + (let ((state (*random-state*))) (random-source-randomize! state) (if (not (eq? default-random-source state)) (random-source-randomize! default-random-source))))) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 3b549f19b..46298a107 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -33,8 +33,8 @@ USA. (define repl:write-result-hash-numbers? #t) (define (initialize-package!) - (set! *nearest-cmdl* (make-fluid #f)) - (set! standard-breakpoint-hook (make-fluid #f)) + (set! *nearest-cmdl* (make-parameter #f)) + (set! standard-breakpoint-hook (make-parameter #f)) (set! hook/repl-read default/repl-read) (set! hook/repl-eval default/repl-eval) (set! hook/repl-write default/repl-write) @@ -116,22 +116,23 @@ USA. (let ((port (cmdl/port cmdl))) (let ((thunk (lambda () - (let-fluids - *current-input-port* #f - *current-output-port* #f - *notification-output-port* #f - *trace-output-port* #f - *interaction-i/o-port* #f - *working-directory-pathname* (fluid *working-directory-pathname*) - *nearest-cmdl* cmdl - standard-error-hook #f - standard-warning-hook #f - standard-breakpoint-hook #f - *default-pathname-defaults* (fluid *default-pathname-defaults*) - dynamic-handler-frames '() - *bound-restarts* (if (cmdl/parent cmdl) - (fluid *bound-restarts*) - '()) + (parameterize* + (list (cons *current-input-port* #f) + (cons *current-output-port* #f) + (cons *notification-output-port* #f) + (cons *trace-output-port* #f) + (cons *interaction-i/o-port* #f) + (cons *working-directory-pathname* + (*working-directory-pathname*)) + (cons *nearest-cmdl* cmdl) + (cons standard-error-hook #f) + (cons standard-warning-hook #f) + (cons standard-breakpoint-hook #f) + (cons *default-pathname-defaults* + (*default-pathname-defaults*)) + (cons dynamic-handler-frames '()) + (cons *bound-restarts* + (if (cmdl/parent cmdl) (*bound-restarts*) '()))) (lambda () (let loop ((message message)) (loop @@ -203,24 +204,24 @@ USA. (define *nearest-cmdl*) (define (nearest-cmdl) - (let ((cmdl (fluid *nearest-cmdl*))) + (let ((cmdl (*nearest-cmdl*))) (if (not cmdl) (error "NEAREST-CMDL: no cmdl")) cmdl)) (define (nearest-cmdl/port) - (let ((cmdl (fluid *nearest-cmdl*))) + (let ((cmdl (*nearest-cmdl*))) (if cmdl (cmdl/port cmdl) console-i/o-port))) (define (nearest-cmdl/level) - (let ((cmdl (fluid *nearest-cmdl*))) + (let ((cmdl (*nearest-cmdl*))) (if cmdl (cmdl/level cmdl) 0))) (define (nearest-cmdl/batch-mode?) - (let ((cmdl (fluid *nearest-cmdl*))) + (let ((cmdl (*nearest-cmdl*))) (if cmdl (cmdl/batch-mode? cmdl) #f))) @@ -543,9 +544,9 @@ USA. (or message (and condition (cmdl-message/strings - (let-fluids *unparser-list-depth-limit* 25 - *unparser-list-breadth-limit* 100 - *unparser-string-length-limit* 500 + (parameterize* (list (cons *unparser-list-depth-limit* 25) + (cons *unparser-list-breadth-limit* 100) + (cons *unparser-string-length-limit* 500)) (lambda () (condition/report-string condition)))))) (and condition @@ -946,9 +947,9 @@ USA. unspecific) (define (standard-breakpoint-handler condition) - (let ((hook (fluid standard-breakpoint-hook))) + (let ((hook (standard-breakpoint-hook))) (if hook - (let-fluid standard-breakpoint-hook #f + (parameterize* (list (cons standard-breakpoint-hook #f)) (lambda () (hook condition))))) (repl/start (push-repl (breakpoint/environment condition) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index f59e2fcfd..486a98b67 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4578,12 +4578,6 @@ USA. (files "dynamic") (parent (runtime)) (export () - fluid? - make-fluid - fluid - set-fluid! - let-fluid - let-fluids parameter? make-parameter parameterize*) diff --git a/src/runtime/savres.scm b/src/runtime/savres.scm index 395f9d053..0f9c13faa 100644 --- a/src/runtime/savres.scm +++ b/src/runtime/savres.scm @@ -45,7 +45,7 @@ USA. (define *within-restore-window?*) (define (initialize-package!) - (set! *within-restore-window?* (make-fluid #f))) + (set! *within-restore-window?* (make-parameter #f))) (define (disk-save filename #!optional id) (let ((filename (->namestring (merge-pathnames filename))) @@ -81,7 +81,7 @@ USA. (lambda () (set! time-world-saved time) (set! time-world-restored (get-universal-time)) - (let-fluid *within-restore-window?* #t + (parameterize* (list (cons *within-restore-window?* #t)) (lambda () (event-distributor/invoke! event:after-restore))) (start-thread-timer) diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm index b2f434ed0..1f7897ac6 100644 --- a/src/runtime/stack-sample.scm +++ b/src/runtime/stack-sample.scm @@ -84,7 +84,7 @@ (define event-return-address 'UNINITIALIZED) (define (initialize-package!) - (set! stack-sampling-return-address (make-fluid #f)) + (set! stack-sampling-return-address (make-parameter #f)) (let ((blocked? (block-thread-events))) (signal-thread-event (current-thread) (lambda () @@ -164,7 +164,7 @@ (define stack-sampling-return-address) (define (stack-sampling-stack-frame? stack-frame) - (let ((return-address (fluid stack-sampling-return-address))) + (let ((return-address (stack-sampling-return-address))) (and (compiled-return-address? return-address) (eq? stack-frame-type/compiled-return-address (stack-frame/type stack-frame)) @@ -180,9 +180,10 @@ (let ((stack-frame (continuation/first-subproblem continuation))) (if (eq? stack-frame-type/compiled-return-address (stack-frame/type stack-frame)) - (let-fluid stack-sampling-return-address - (stack-frame/return-address stack-frame) - thunk) + (parameterize* + (list (cons stack-sampling-return-address + (stack-frame/return-address stack-frame))) + thunk) (thunk))))))) ;;;; Profile Data @@ -396,11 +397,11 @@ (define (profile-pp expression output-port) ;; Random parametrization. - (let-fluids *unparser-list-breadth-limit* 5 - *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 + (parameterize* (list (cons *unparser-list-breadth-limit* 5) + (cons *unparser-list-depth-limit* 3) + (cons *unparser-string-length-limit* 40) + (cons *unparse-primitives-by-name?* #t) + (cons *pp-save-vertical-space?* #t) + (cons *pp-default-as-code?* #t)) (lambda () (pp expression output-port)))) \ No newline at end of file diff --git a/src/runtime/structure-parser.scm b/src/runtime/structure-parser.scm index da05d5fc6..ba54f28fc 100644 --- a/src/runtime/structure-parser.scm +++ b/src/runtime/structure-parser.scm @@ -82,7 +82,7 @@ USA. ;;;; Compiler (define (compile-top-level pattern caller-context env) - (let-fluid name-counters (make-strong-eq-hash-table) + (parameterize* (list (cons name-counters (make-strong-eq-hash-table))) (lambda () (optimize-result (compile-pattern pattern caller-context env))))) @@ -777,7 +777,7 @@ USA. (define (call-with-new-names names procedure) (apply procedure (map (lambda (name) - (let* ((t (fluid name-counters)) + (let* ((t (name-counters)) (n (hash-table-ref/default t name 0))) (hash-table-set! t name (+ n 1)) (symbol name '. n))) @@ -786,7 +786,7 @@ USA. (define name-counters) (define (initialize-package!) - (set! name-counters (make-fluid unspecific))) + (set! name-counters (make-parameter unspecific))) ;;;; Optimizer diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index 7f9fb374e..e16293a67 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -117,7 +117,7 @@ USA. (do () (#f) (with-simple-restart 'ABORT "Return to SLIME top-level." (lambda () - (let-fluid *top-level-restart* (find-restart 'ABORT) + (parameterize* (list (cons *top-level-restart* (find-restart 'ABORT))) (lambda () (process-one-message socket 0))))))) @@ -130,13 +130,13 @@ USA. (set-repl/environment! (nearest-repl) environment)) (define (top-level-abort) - (invoke-restart (fluid *top-level-restart*))) + (invoke-restart (*top-level-restart*))) (define (bound-restarts-for-emacs) (let loop ((restarts (bound-restarts))) (if (pair? restarts) (cons (car restarts) - (if (eq? (car restarts) (fluid *top-level-restart*)) + (if (eq? (car restarts) (*top-level-restart*)) '() (loop (cdr restarts)))) '()))) @@ -224,8 +224,8 @@ USA. (define *index*) (define (emacs-rex socket sexp pstring id) - (let-fluids *buffer-pstring* pstring - *index* id + (parameterize* (list (cons *buffer-pstring* pstring) + (cons *index* id)) (lambda () (eval (cons* (car sexp) socket (map quote-special (cdr sexp))) swank-env)))) @@ -236,11 +236,11 @@ USA. (the-environment)) (define (buffer-env) - (pstring->env (fluid *buffer-pstring*))) + (pstring->env (*buffer-pstring*))) (define (pstring->env pstring) (cond ((or (not (string? pstring)) - (let ((buffer-pstring (fluid *buffer-pstring*))) + (let ((buffer-pstring (*buffer-pstring*))) (or (not (string? buffer-pstring)) (string-ci=? buffer-pstring "COMMON-LISP-USER")))) (get-current-environment)) @@ -316,10 +316,10 @@ USA. (define repl-port-type) (define (initialize-package!) - (set! *top-level-restart* (make-fluid unspecific)) - (set! *sldb-state* (make-fluid #f)) - (set! *index* (make-fluid unspecific)) - (set! *buffer-pstring* (make-fluid unspecific)) + (set! *top-level-restart* (make-parameter unspecific)) + (set! *sldb-state* (make-parameter #f)) + (set! *index* (make-parameter unspecific)) + (set! *buffer-pstring* (make-parameter unspecific)) (set! repl-port-type (make-port-type `((WRITE-CHAR @@ -657,17 +657,18 @@ swank:xref (define *sldb-state*) (define (invoke-sldb socket level condition) - (let-fluid *sldb-state* - (make-sldb-state condition (bound-restarts-for-emacs)) - (lambda () - (dynamic-wind - (lambda () #f) - (lambda () - (write-message `(:debug 0 ,level ,@(sldb-info (fluid *sldb-state*) 0 20)) - socket) - (sldb-loop level socket)) - (lambda () - (write-message `(:debug-return 0 ,(- level 1) 'NIL) socket)))))) + (parameterize* + (list (cons *sldb-state* + (make-sldb-state condition (bound-restarts-for-emacs)))) + (lambda () + (dynamic-wind + (lambda () #f) + (lambda () + (write-message `(:debug 0 ,level ,@(sldb-info (*sldb-state*) 0 20)) + socket) + (sldb-loop level socket)) + (lambda () + (write-message `(:debug-return 0 ,(- level 1) 'NIL) socket)))))) (define (sldb-loop level socket) (write-message `(:debug-activate 0 ,level) socket) @@ -685,7 +686,7 @@ swank:xref (sldb-restarts rs) (sldb-backtrace c start end) ;;'((0 "dummy frame")) - (list (fluid *index*))))) + (list (*index*))))) (define (sldb-restarts restarts) (map (lambda (r) @@ -700,24 +701,24 @@ swank:xref (define (swank:sldb-abort socket . args) socket args - (abort (sldb-state.restarts (fluid *sldb-state*)))) + (abort (sldb-state.restarts (*sldb-state*)))) (define (swank:sldb-continue socket . args) socket args - (continue (sldb-state.restarts (fluid *sldb-state*)))) + (continue (sldb-state.restarts (*sldb-state*)))) (define (swank:invoke-nth-restart-for-emacs socket sldb-level n) sldb-level - (write-message `(:return (:abort "NIL") ,(fluid *index*)) socket) - (invoke-restart (list-ref (sldb-state.restarts (fluid *sldb-state*)) n))) + (write-message `(:return (:abort "NIL") ,(*index*)) socket) + (invoke-restart (list-ref (sldb-state.restarts (*sldb-state*)) n))) (define (swank:debugger-info-for-emacs socket from to) socket - (sldb-info (fluid *sldb-state*) from to)) + (sldb-info (*sldb-state*) from to)) (define (swank:backtrace socket from to) socket - (sldb-backtrace (sldb-state.condition (fluid *sldb-state*)) from to)) + (sldb-backtrace (sldb-state.condition (*sldb-state*)) from to)) (define (sldb-backtrace condition from to) (sldb-backtrace-aux (condition/continuation condition) from to)) @@ -759,7 +760,7 @@ swank:xref (cond ((debugging-info/compiled-code? expression) (write-string ";unknown compiled code" port)) ((not (debugging-info/undefined-expression? expression)) - (let-fluid *unparse-primitives-by-name?* #t + (parameterize* (list (cons *unparse-primitives-by-name?* #t)) (lambda () (write (unsyntax @@ -812,7 +813,7 @@ swank:xref (define (sldb-get-frame index) (stream-ref (continuation->frames (condition/continuation - (sldb-state.condition (fluid *sldb-state*)))) + (sldb-state.condition (*sldb-state*)))) index)) (define (frame-var-value frame var) @@ -835,8 +836,7 @@ swank:xref (define (all-completions prefix environment) (let ((prefix - (if (fluid (environment-lookup environment - '*PARSER-CANONICALIZE-SYMBOLS?*)) + (if ((environment-lookup environment '*PARSER-CANONICALIZE-SYMBOLS?*)) (string-downcase prefix) prefix)) (completions '())) @@ -1112,9 +1112,9 @@ swank:xref (define (pprint-to-string o) (call-with-output-string (lambda (p) - (let-fluids *unparser-list-breadth-limit* 10 - *unparser-list-depth-limit* 4 - *unparser-string-length-limit* 100 + (parameterize* (list (cons *unparser-list-breadth-limit* 10) + (cons *unparser-list-depth-limit* 4) + (cons *unparser-string-length-limit* 100)) (lambda () (pp o p)))))) diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm index aa0de7ba7..7b9f879bf 100644 --- a/src/runtime/syntax-output.scm +++ b/src/runtime/syntax-output.scm @@ -404,7 +404,7 @@ USA. (define *rename-database*) (define (initialize-package!) - (set! *rename-database* (make-fluid 'UNBOUND))) + (set! *rename-database* (make-parameter 'UNBOUND))) (define-structure (rename-database (constructor initial-rename-database ()) (conc-name rename-database/)) @@ -415,14 +415,14 @@ USA. (define (make-rename-id) (delay - (let* ((renames (fluid *rename-database*)) + (let* ((renames (*rename-database*)) (n (+ (rename-database/frame-number renames) 1))) (set-rename-database/frame-number! renames n) n))) (define (rename-identifier identifier rename-id) (let ((key (cons identifier rename-id)) - (renames (fluid *rename-database*))) + (renames (*rename-database*))) (let ((mapping-table (rename-database/mapping-table renames))) (or (hash-table/get mapping-table key #f) (let ((mapped-identifier @@ -459,7 +459,7 @@ USA. (define (unmap-identifier identifier) (let ((entry (hash-table/get (rename-database/unmapping-table - (fluid *rename-database*)) + (*rename-database*)) identifier #f))) (if entry @@ -472,7 +472,7 @@ USA. (define (finalize-mapped-identifier identifier) (let ((entry (hash-table/get (rename-database/unmapping-table - (fluid *rename-database*)) + (*rename-database*)) identifier #f))) (if entry @@ -491,7 +491,7 @@ USA. (symbol "." symbol-to-map "." frame-number)) (define (map-uninterned-identifier identifier frame-number) - (let ((table (rename-database/id-table (fluid *rename-database*))) + (let ((table (rename-database/id-table (*rename-database*))) (symbol (identifier->symbol identifier))) (let ((alist (hash-table/get table symbol '()))) (let ((entry (assv frame-number alist))) diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index 295df0be7..7ffd5eb8f 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -49,7 +49,7 @@ USA. (define (syntax* forms environment) (guarantee-list forms 'SYNTAX*) (let ((senv (->syntactic-environment environment 'SYNTAX*))) - (let-fluid *rename-database* (initial-rename-database) + (parameterize* (list (cons *rename-database* (initial-rename-database))) (lambda () (output/post-process-expression (if (syntactic-environment/top-level? senv) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index e27db6499..f86953c08 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -126,7 +126,7 @@ USA. (define (initialize-high!) ;; Called later in the cold load, when more of the runtime is initialized. - (set! root-continuation-default (make-fluid #f)) + (set! root-continuation-default (make-parameter #f)) (initialize-error-conditions!) (reset-threads-high!) (record-start-times! first-running-thread) @@ -207,7 +207,7 @@ USA. "continuation or #f" create-thread)) (let ((root-continuation - (or root-continuation (fluid root-continuation-default)))) + (or root-continuation (root-continuation-default)))) (call-with-current-continuation (lambda (return) (%within-continuation root-continuation #t @@ -234,14 +234,14 @@ USA. (shallow-fluid-bind swap! thunk swap!)))) (define (create-thread-continuation) - (fluid root-continuation-default)) + (root-continuation-default)) (define (with-create-thread-continuation continuation thunk) (if (not (continuation? continuation)) (error:wrong-type-argument continuation "continuation" with-create-thread-continuation)) - (let-fluid root-continuation-default continuation + (parameterize* (list (cons root-continuation-default continuation)) thunk)) (define (current-thread) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index a9990f49e..c21bcb700 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -34,32 +34,32 @@ USA. (char-set-union char-set:not-graphic (char-set #\" #\\))) (set! hook/interned-symbol unparse-symbol) (set! hook/procedure-unparser #f) - (set! *unparser-radix* (make-fluid 10)) - (set! *unparser-list-breadth-limit* (make-fluid #f)) - (set! *unparser-list-depth-limit* (make-fluid #f)) - (set! *unparser-string-length-limit* (make-fluid #f)) - (set! *unparse-primitives-by-name?* (make-fluid #f)) - (set! *unparse-uninterned-symbols-by-name?* (make-fluid #f)) - (set! *unparse-with-maximum-readability?* (make-fluid #f)) - (set! *unparse-compound-procedure-names?* (make-fluid #t)) - (set! *unparse-with-datum?* (make-fluid #f)) - (set! *unparse-abbreviate-quotations?* (make-fluid #f)) - (set! *unparse-streams?* (make-fluid #t)) + (set! *unparser-radix* (make-parameter 10)) + (set! *unparser-list-breadth-limit* (make-parameter #f)) + (set! *unparser-list-depth-limit* (make-parameter #f)) + (set! *unparser-string-length-limit* (make-parameter #f)) + (set! *unparse-primitives-by-name?* (make-parameter #f)) + (set! *unparse-uninterned-symbols-by-name?* (make-parameter #f)) + (set! *unparse-with-maximum-readability?* (make-parameter #f)) + (set! *unparse-compound-procedure-names?* (make-parameter #t)) + (set! *unparse-with-datum?* (make-parameter #f)) + (set! *unparse-abbreviate-quotations?* (make-parameter #f)) + (set! *unparse-streams?* (make-parameter #t)) (set! system-global-unparser-table (make-system-global-unparser-table)) - (set! *unparser-table* (make-fluid system-global-unparser-table)) - (set! *default-unparser-state* (make-fluid #f)) + (set! *unparser-table* (make-parameter system-global-unparser-table)) + (set! *default-unparser-state* (make-parameter #f)) (set! non-canon-symbol-quoted (char-set-union char-set/atom-delimiters char-set/symbol-quotes)) (set! canon-symbol-quoted (char-set-union non-canon-symbol-quoted char-set:upper-case)) - (set! *unparsing-within-brackets* (make-fluid #f)) - (set! *list-depth* (make-fluid #f)) - (set! *output-port* (make-fluid #f)) - (set! *slashify?* (make-fluid #f)) - (set! *environment* (make-fluid #f)) - (set! *dispatch-table* (make-fluid #f)) + (set! *unparsing-within-brackets* (make-parameter #f)) + (set! *list-depth* (make-parameter #f)) + (set! *output-port* (make-parameter #f)) + (set! *slashify?* (make-parameter #f)) + (set! *environment* (make-parameter #f)) + (set! *dispatch-table* (make-parameter #f)) unspecific) (define *unparser-radix*) @@ -146,7 +146,7 @@ USA. (define (with-current-unparser-state state procedure) (guarantee-unparser-state state 'WITH-CURRENT-UNPARSER-STATE) - (let-fluid *default-unparser-state* state + (parameterize* (list (cons *default-unparser-state* state)) (lambda () (procedure (unparser-state/port state))))) @@ -169,7 +169,7 @@ USA. (unparser-state/environment state))) (define (unparse-object/top-level object port slashify? environment) - (let ((state (fluid *default-unparser-state*))) + (let ((state (*default-unparser-state*))) (unparse-object/internal object port @@ -187,22 +187,23 @@ USA. environment))))) (define (unparse-object/internal object port list-depth slashify? environment) - (let-fluids *list-depth* list-depth - *output-port* port - *slashify?* slashify? - *environment* environment - *dispatch-table* (unparser-table/dispatch-vector - (let ((table (fluid *unparser-table*))) - (guarantee-unparser-table table #f) - table)) + (parameterize* (list (cons *list-depth* list-depth) + (cons *output-port* port) + (cons *slashify?* slashify?) + (cons *environment* environment) + (cons *dispatch-table* + (unparser-table/dispatch-vector + (let ((table (*unparser-table*))) + (guarantee-unparser-table table #f) + table)))) (lambda () (*unparse-object object)))) (define-integrable (invoke-user-method method object) - (method (make-unparser-state (fluid *output-port*) - (fluid *list-depth*) - (fluid *slashify?*) - (fluid *environment*)) + (method (make-unparser-state (*output-port*) + (*list-depth*) + (*slashify?*) + (*environment*)) object)) (define *list-depth*) @@ -211,7 +212,7 @@ USA. (define *dispatch-table*) (define (*unparse-object object) - ((vector-ref (fluid *dispatch-table*) + ((vector-ref (*dispatch-table*) ((ucode-primitive primitive-object-type 1) object)) object)) @@ -220,13 +221,13 @@ USA. (define *output-port*) (define-integrable (*unparse-char char) - (output-port/write-char (fluid *output-port*) char)) + (output-port/write-char (*output-port*) char)) (define-integrable (*unparse-string string) - (output-port/write-string (fluid *output-port*) string)) + (output-port/write-string (*output-port*) string)) (define-integrable (*unparse-substring string start end) - (output-port/write-substring (fluid *output-port*) string start end)) + (output-port/write-substring (*output-port*) string start end)) (define-integrable (*unparse-datum object) (*unparse-hex (object-datum object))) @@ -251,37 +252,38 @@ USA. (define within-brackets-list-depth-limit 3) (define (*unparse-with-brackets name object thunk) - (if (or (and (fluid *unparse-with-maximum-readability?*) object) - (fluid *unparsing-within-brackets*)) + (if (or (and (*unparse-with-maximum-readability?*) object) + (*unparsing-within-brackets*)) (*unparse-readable-hash object) - (let-fluids - *unparsing-within-brackets* #t - *unparser-list-breadth-limit* (if (fluid *unparser-list-breadth-limit*) - (min (fluid *unparser-list-breadth-limit*) - within-brackets-list-breadth-limit) - within-brackets-list-breadth-limit) - *unparser-list-depth-limit* (if (fluid *unparser-list-depth-limit*) - (min (fluid *unparser-list-depth-limit*) - within-brackets-list-depth-limit) - within-brackets-list-depth-limit) - (lambda () - (*unparse-string "#[") - (if (string? name) - (*unparse-string name) - (*unparse-object name)) - (if object - (begin - (*unparse-char #\space) - (*unparse-hash object))) - (if thunk - (begin - (*unparse-char #\space) - (limit-unparse-depth thunk)) - (if (fluid *unparse-with-datum?*) - (begin - (*unparse-char #\space) - (*unparse-datum object)))) - (*unparse-char #\]))))) + (parameterize* (list (cons *unparsing-within-brackets* #t) + (cons *unparser-list-breadth-limit* + (if (*unparser-list-breadth-limit*) + (min (*unparser-list-breadth-limit*) + within-brackets-list-breadth-limit) + within-brackets-list-breadth-limit)) + (cons *unparser-list-depth-limit* + (if (*unparser-list-depth-limit*) + (min (*unparser-list-depth-limit*) + within-brackets-list-depth-limit) + within-brackets-list-depth-limit))) + (lambda () + (*unparse-string "#[") + (if (string? name) + (*unparse-string name) + (*unparse-object name)) + (if object + (begin + (*unparse-char #\space) + (*unparse-hash object))) + (if thunk + (begin + (*unparse-char #\space) + (limit-unparse-depth thunk)) + (if (*unparse-with-datum?*) + (begin + (*unparse-char #\space) + (*unparse-datum object)))) + (*unparse-char #\]))))) ;;;; Unparser Methods @@ -354,7 +356,7 @@ USA. (define hook/interned-symbol) (define (unparse/uninterned-symbol symbol) - (if (fluid *unparse-uninterned-symbols-by-name?*) + (if (*unparse-uninterned-symbols-by-name?*) (unparse-symbol symbol) (*unparse-with-brackets 'UNINTERNED-SYMBOL symbol (lambda () @@ -366,8 +368,7 @@ USA. (unparse-symbol-name (symbol-name symbol)))) (define (unparse-keyword-name s) - (case (fluid (repl-environment-value (fluid *environment*) - '*PARSER-KEYWORD-STYLE*)) + (case ((repl-environment-value (*environment*) '*PARSER-KEYWORD-STYLE*)) ((PREFIX) (*unparse-char #\:) (unparse-symbol-name s)) @@ -382,8 +383,8 @@ USA. (define (unparse-symbol-name s) (if (or (string-find-next-char-in-set s - (if (fluid (repl-environment-value (fluid *environment*) - '*PARSER-CANONICALIZE-SYMBOLS?*)) + (if ((repl-environment-value (*environment*) + '*PARSER-CANONICALIZE-SYMBOLS?*)) canon-symbol-quoted non-canon-symbol-quoted)) (fix:= (string-length s) 0) @@ -416,8 +417,7 @@ USA. (char=? (string-ref string 0) #\#)) (define (looks-like-keyword? string) - (case (fluid (repl-environment-value (fluid *environment*) - '*PARSER-KEYWORD-STYLE*)) + (case ((repl-environment-value (*environment*) '*PARSER-KEYWORD-STYLE*)) ((PREFIX) (char=? (string-ref string 0) #\:)) ((SUFFIX) @@ -425,7 +425,7 @@ USA. (else #f))) (define (unparse/character character) - (if (or (fluid *slashify?*) + (if (or (*slashify?*) (not (char-ascii? character))) (begin (*unparse-string "#\\") @@ -433,10 +433,10 @@ USA. (*unparse-char character))) (define (unparse/string string) - (if (fluid *slashify?*) + (if (*slashify?*) (let ((end (string-length string))) (let ((end* - (let ((limit (fluid *unparser-string-length-limit*))) + (let ((limit (*unparser-string-length-limit*))) (if limit (min limit end) end)))) @@ -525,7 +525,7 @@ USA. (let loop ((index 1)) (cond ((fix:= index length) (*unparse-char #\))) - ((let ((limit (fluid *unparser-list-breadth-limit*))) + ((let ((limit (*unparser-list-breadth-limit*))) (and limit (>= index limit))) (*unparse-string " ...)")) (else @@ -543,7 +543,7 @@ USA. (map-reference-trap (lambda () (vector-ref vector index)))) (define (unparse/record record) - (if (fluid *unparse-with-maximum-readability?*) + (if (*unparse-with-maximum-readability?*) (*unparse-readable-hash record) (invoke-user-method unparse-record record))) @@ -552,7 +552,7 @@ USA. => (lambda (prefix) (unparse-list/prefix-pair prefix pair))) ((unparse-list/unparser pair) => (lambda (method) (invoke-user-method method pair))) - ((and (fluid *unparse-streams?*) (stream-pair? pair)) + ((and (*unparse-streams?*) (stream-pair? pair)) (unparse-list/stream-pair pair)) (else (unparse-list pair)))) @@ -566,10 +566,10 @@ USA. (*unparse-char #\))))) (define (limit-unparse-depth kernel) - (let ((limit (fluid *unparser-list-depth-limit*))) + (let ((limit (*unparser-list-depth-limit*))) (if limit - (let ((depth (fluid *list-depth*))) - (let-fluid *list-depth* (1+ depth) + (let ((depth (*list-depth*))) + (parameterize* (list (cons *list-depth* (1+ depth))) (lambda () (if (> (1+ depth) limit) (*unparse-string "...") @@ -586,7 +586,7 @@ USA. (begin (*unparse-char #\space) (*unparse-object (safe-car l)) - (if (let ((limit (fluid *unparser-list-breadth-limit*))) + (if (let ((limit (*unparser-list-breadth-limit*))) (and limit (>= n limit) (pair? (safe-cdr l)))) @@ -610,7 +610,7 @@ USA. (*unparse-object (safe-car (safe-cdr pair)))) (define (unparse-list/prefix-pair? object) - (and (fluid *unparse-abbreviate-quotations?*) + (and (*unparse-abbreviate-quotations?*) (pair? (safe-cdr object)) (null? (safe-cdr (safe-cdr object))) (case (safe-car object) @@ -639,7 +639,7 @@ USA. ((stream-pair? value) (*unparse-char #\space) (*unparse-object (safe-car value)) - (if (let ((limit (fluid *unparser-list-breadth-limit*))) + (if (let ((limit (*unparser-list-breadth-limit*))) (and limit (>= n limit))) (*unparse-string " ...") @@ -674,7 +674,7 @@ USA. (unparse-procedure procedure (lambda () (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure - (and (fluid *unparse-compound-procedure-names?*) + (and (*unparse-compound-procedure-names?*) (lambda-components* (procedure-lambda procedure) (lambda (name required optional rest body) required optional rest body @@ -687,9 +687,9 @@ USA. (let ((unparse-name (lambda () (*unparse-object (primitive-procedure-name procedure))))) - (cond ((fluid *unparse-primitives-by-name?*) + (cond ((*unparse-primitives-by-name?*) (unparse-name)) - ((fluid *unparse-with-maximum-readability?*) + ((*unparse-with-maximum-readability?*) (*unparse-readable-hash procedure)) (else (*unparse-with-brackets 'PRIMITIVE-PROCEDURE #f @@ -771,7 +771,7 @@ USA. (*unparse-string prefix)) radix) 10)))) - (case (fluid *unparser-radix*) + (case (*unparser-radix*) ((2) (prefix "#b" 2 2)) ((8) (prefix "#o" 8 8)) ((16) (prefix "#x" 10 16)) @@ -787,7 +787,7 @@ USA. (*unparse-with-brackets "floating-vector" v (and (not (zero? length)) (lambda () - (let ((limit (let ((limit (fluid *unparser-list-breadth-limit*))) + (let ((limit (let ((limit (*unparser-list-breadth-limit*))) (if (not limit) length (min length limit))))) @@ -820,7 +820,7 @@ USA. (compiled-procedure/name proc)) => named-arity-dispatched-procedure) (else (plain 'ARITY-DISPATCHED-PROCEDURE))))) - ((fluid *unparse-with-maximum-readability?*) + ((*unparse-with-maximum-readability?*) (*unparse-readable-hash entity)) ((record? (%entity-extra entity)) ;; Kludge to make the generic dispatch mechanism work. @@ -845,7 +845,7 @@ USA. (*unparse-object (promise-value promise))) (lambda () (*unparse-string "(unevaluated)") - (if (fluid *unparse-with-datum?*) + (if (*unparse-with-datum?*) (begin (*unparse-char #\space) (*unparse-datum promise))))))) \ No newline at end of file diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm index 9a3aec651..7c7e3aa3b 100644 --- a/src/runtime/unsyn.scm +++ b/src/runtime/unsyn.scm @@ -30,7 +30,7 @@ USA. (declare (usual-integrations)) (define (initialize-package!) - (set! substitutions (make-fluid '())) + (set! substitutions (make-parameter '())) (set! unsyntaxer/scode-walker (make-scode-walker unsyntax-constant `((ACCESS ,unsyntax-ACCESS-object) @@ -69,7 +69,7 @@ USA. (define (unsyntax-with-substitutions scode alist) (if (not (alist? alist)) (error:wrong-type-argument alist "alist" 'UNSYNTAX-WITH-SUBSTITUTIONS)) - (let-fluid substitutions alist + (parameterize* (list (cons substitutions alist)) (lambda () (unsyntax scode)))) @@ -80,7 +80,7 @@ USA. (thunk)))) (define-integrable (has-substitution? object) - (let ((substs (fluid substitutions))) + (let ((substs (substitutions))) (and (pair? substs) (assq object substs)))) (define (with-bindings environment lambda receiver) diff --git a/src/runtime/unxdir.scm b/src/runtime/unxdir.scm index 77c343d9e..198b580d1 100644 --- a/src/runtime/unxdir.scm +++ b/src/runtime/unxdir.scm @@ -32,7 +32,7 @@ USA. (define *expand-directory-prefixes?*) (define (initialize-package!) - (set! *expand-directory-prefixes?* (make-fluid true))) + (set! *expand-directory-prefixes?* (make-parameter true))) (define (directory-read pattern #!optional sort?) (if (if (default-object? sort?) true sort?) @@ -55,9 +55,10 @@ USA. (merge-pathnames pathname directory-path)) (let ((pathnames (let ((fnames (generate-directory-pathnames directory-path))) - (let-fluid *expand-directory-prefixes?* false - (lambda () - (map ->pathname fnames)))))) + (parameterize* + (list (cons *expand-directory-prefixes?* false)) + (lambda () + (map ->pathname fnames)))))) (if (and (eq? (pathname-name pattern) 'WILD) (eq? (pathname-type pattern) 'WILD)) pathnames diff --git a/src/runtime/unxpth.scm b/src/runtime/unxpth.scm index 8f51a65b9..9ddf2c842 100644 --- a/src/runtime/unxpth.scm +++ b/src/runtime/unxpth.scm @@ -82,7 +82,7 @@ USA. (cdr components))))) (let ((end (string-length string))) (if (or (= 0 end) - (not (fluid *expand-directory-prefixes?*))) + (not (*expand-directory-prefixes?*))) components (case (string-ref string 0) ((#\$) diff --git a/src/runtime/usrint.scm b/src/runtime/usrint.scm index e76c61792..0dbae5f70 100644 --- a/src/runtime/usrint.scm +++ b/src/runtime/usrint.scm @@ -382,12 +382,12 @@ USA. (define (port/gc-start port) (let ((operation (port/operation port 'GC-START))) - (if (and operation (not (fluid *within-restore-window?*))) + (if (and operation (not (*within-restore-window?*))) (operation port)))) (define (port/gc-finish port) (let ((operation (port/operation port 'GC-FINISH))) - (if (and operation (not (fluid *within-restore-window?*))) + (if (and operation (not (*within-restore-window?*))) (operation port)))) (define (port/read-start port) @@ -421,8 +421,8 @@ USA. unspecific)) (lambda () (let ((v - (let-fluid *notification-depth* - (1+ (fluid *notification-depth*)) + (parameterize* (list (cons *notification-depth* + (1+ (*notification-depth*)))) thunk))) (set! done? #t) v)) @@ -484,7 +484,7 @@ USA. (define (write-notification-prefix port) (write-string ";" port) - (let ((depth (fluid *notification-depth*))) + (let ((depth (*notification-depth*))) (do ((i 0 (+ i 1))) ((not (< i depth))) (write-string indentation-atom port)))) @@ -492,14 +492,14 @@ USA. (define (notification-prefix-length) (+ 1 (* (string-length indentation-atom) - (fluid *notification-depth*)))) + (*notification-depth*)))) (define *notification-depth*) (define indentation-atom) (define wrapped-notification-port-type) (define (initialize-package!) - (set! *notification-depth* (make-fluid 0)) + (set! *notification-depth* (make-parameter 0)) (set! indentation-atom " ") (set! wrapped-notification-port-type (make-wrapped-notification-port-type)) unspecific) \ No newline at end of file diff --git a/src/runtime/world-report.scm b/src/runtime/world-report.scm index ab5bd037b..3cf22f7b0 100644 --- a/src/runtime/world-report.scm +++ b/src/runtime/world-report.scm @@ -37,7 +37,7 @@ USA. (flags (cons (cons (console-thread) "console") (if (default-object? thread-flags) '() - thread-flags))) + thread-flags))) (now (get-universal-time)) (cpu (process-time-clock))) (write-string "-*-Outline-*-" port) @@ -57,7 +57,7 @@ USA. (thread-report flags port))) (define (ticks->string ticks) - (let-fluid flonum-unparser-cutoff '(absolute 3) + (parameterize* (list (cons flonum-unparser-cutoff '(absolute 3))) (lambda () (number->string (internal-time/ticks->seconds ticks) 10)))) diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm index 8f8dd82d7..104f31c83 100644 --- a/src/runtime/wrkdir.scm +++ b/src/runtime/wrkdir.scm @@ -38,14 +38,14 @@ USA. (pathname-simplify (pathname-as-directory ((ucode-primitive working-directory-pathname)))))) - (set-fluid! *working-directory-pathname* pathname) - (set-fluid! *default-pathname-defaults* pathname)) + (*working-directory-pathname* pathname) + (*default-pathname-defaults* pathname)) unspecific) -(define *working-directory-pathname* (make-fluid #f)) +(define *working-directory-pathname* (make-parameter #f)) (define (working-directory-pathname) - (fluid *working-directory-pathname*)) + (*working-directory-pathname*)) (define (set-working-directory-pathname! name) (let ((pathname (new-pathname name))) @@ -63,18 +63,18 @@ USA. "no such directory") 'SET-WORKING-DIRECTORY-PATHNAME! (list name))) - (set-fluid! *working-directory-pathname* pathname) - (set-fluid! *default-pathname-defaults* pathname) + (*working-directory-pathname* pathname) + (*default-pathname-defaults* pathname) (cmdl/set-default-directory (nearest-cmdl) pathname) pathname)) (define (with-working-directory-pathname name thunk) (let ((pathname (new-pathname name))) - (let-fluids *default-pathname-defaults* pathname - *working-directory-pathname* pathname + (parameterize* (list (cons *default-pathname-defaults* pathname) + (cons *working-directory-pathname* pathname)) thunk))) (define (new-pathname name) (pathname-simplify (pathname-as-directory - (merge-pathnames name (fluid *working-directory-pathname*))))) \ No newline at end of file + (merge-pathnames name (*working-directory-pathname*))))) \ No newline at end of file diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm index 8cfe80bc8..cec4b0bdf 100644 --- a/src/sf/cgen.scm +++ b/src/sf/cgen.scm @@ -243,8 +243,8 @@ USA. ;;; Debugging utility (define (pp-expression form #!optional port) - (let-fluids *pp-primitives-by-name* #f - *pp-uninterned-symbols-by-name* #f - *unparse-abbreviate-quotations?* #t + (parameterize* (list (cons *pp-primitives-by-name* #f) + (cons *pp-uninterned-symbols-by-name* #f) + (cons *unparse-abbreviate-quotations?* #t)) (lambda () (pp (cgen/external-with-declarations form) port)))) \ No newline at end of file diff --git a/src/sicp/compat.scm b/src/sicp/compat.scm index 02eca86a0..8fffc1775 100644 --- a/src/sicp/compat.scm +++ b/src/sicp/compat.scm @@ -154,14 +154,14 @@ USA. (let ((newval (if (default-object? newval) false newval))) (if (not (or (not newval) (and (exact-integer? newval) (> newval 0)))) (error:illegal-datum newval 'PRINT-DEPTH)) - (set-fluid! *unparser-list-depth-limit* newval) + (*unparser-list-depth-limit* newval) unspecific)) (define (print-breadth #!optional newval) (let ((newval (if (default-object? newval) false newval))) (if (not (or (not newval) (and (exact-integer? newval) (> newval 0)))) (error:illegal-datum newval 'PRINT-BREADTH)) - (set-fluid! *unparser-list-breadth-limit* newval) + (*unparser-list-breadth-limit* newval) unspecific)) (define (ceiling->exact number) diff --git a/src/sicp/studen.scm b/src/sicp/studen.scm index c9141f6fc..a1e5d215c 100644 --- a/src/sicp/studen.scm +++ b/src/sicp/studen.scm @@ -99,12 +99,12 @@ USA. (access set-atom-delimiters! (->environment '(runtime parser)))) (define (enable-system-syntax) - (set-fluid! *parser-table* system-global-parser-table) + (*parser-table* system-global-parser-table) (set-atom-delimiters! 'mit-scheme) (set-repl/syntax-table! (nearest-repl) system-global-syntax-table)) (define (disable-system-syntax) - (set-fluid! *parser-table* *student-parser-table*) + (*parser-table* *student-parser-table*) (set-atom-delimiters! 'sicp) (set-repl/syntax-table! (nearest-repl) *student-syntax-table*)) diff --git a/src/sos/microbench.scm b/src/sos/microbench.scm index b0c64d675..1ec76448f 100644 --- a/src/sos/microbench.scm +++ b/src/sos/microbench.scm @@ -262,7 +262,7 @@ USA. (let ((f1-time (run-test f1-test))) (let ((report (lambda (name time scale) - (let-fluid flonum-unparser-cutoff '(ABSOLUTE 2) + (parameterize* (list (cons flonum-unparser-cutoff '(ABSOLUTE 2))) (lambda () (newline) (write name) diff --git a/src/ssp/xhtml-expander.scm b/src/ssp/xhtml-expander.scm index 2c5ef19ce..fe334c5fa 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 '() '()))) - (let-fluid load/suppress-loading-message? #t + (parameterize* (list (cons load/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 d7740b9f2..b7a8aa9f5 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))) - (let-fluid load/suppress-loading-message? #t + (parameterize* (list (cons load/suppress-loading-message? #t)) (lambda () (load pathname environment)))) (hash-table/get methods name #f))) \ No newline at end of file diff --git a/src/swat/scheme/other/rtest.scm b/src/swat/scheme/other/rtest.scm index 2c5dd5cc5..444aa5ab5 100644 --- a/src/swat/scheme/other/rtest.scm +++ b/src/swat/scheme/other/rtest.scm @@ -2,8 +2,8 @@ ;; to make this possible to debug -; (set-fluid! *unparser-list-breadth-limit* 10) -; (set-fluid! *unparser-list-depth-limit* 10) +; (*unparser-list-breadth-limit* 10) +; (*unparser-list-depth-limit* 10) ;; GC stress test @@ -52,31 +52,31 @@ (define v1 (make-self-painting-rectangle 50 30 "yellow")) (define v2 (make-self-painting-rectangle 100 10 "blue")) (define v3 (make-self-painting-rectangle 10 100 "orange")) - + (define topframe (make-vbox v1 v2 v3)) - + (define h1 (make-self-painting-rectangle 10 10 "white")) (define h2 (make-self-painting-rectangle 20 20 "gold")) (define h3 (make-self-painting-rectangle 30 30 "green")) - + (define bottomframe (make-hbox h1 h2 h3)) - + (make-hbox topframe bottomframe)) (define (make-bad-picture) (define v1 (make-rect 50 30 "yellow")) (define v2 (make-rect 100 10 "blue")) (define v3 (make-rect 10 100 "orange")) - + (define topframe (make-vbox v1 v2 v3)) - + (define h1 (make-rect 10 10 "white")) (define h2 (make-rect 20 20 "gold")) (define h3 (make-rect 30 30 "green")) (set! green h3) - + (define bottomframe (make-hbox h1 h2 h3)) - + (make-hbox topframe bottomframe)) (define (simple-picture) @@ -169,7 +169,3 @@ button2 button3 button4)))) (swat-open me '-title "Featureless Drawing Program") me))) - - - - diff --git a/tests/runtime/test-dynamic-env.scm b/tests/runtime/test-dynamic-env.scm index 4b981d2f4..581231b50 100644 --- a/tests/runtime/test-dynamic-env.scm +++ b/tests/runtime/test-dynamic-env.scm @@ -28,20 +28,6 @@ USA. (declare (usual-integrations)) -(define-test 'FLUIDS - (lambda () - (let ((f (make-fluid 'f)) - (g (make-fluid 'g))) - (assert-eqv (fluid f) 'f) - (assert-eqv (let-fluid f 'x (lambda () (fluid f))) 'x) - (assert-eqv (fluid f) 'f) - (assert-equal (let-fluids f 'h g 'i - (lambda () - (cons (fluid f) (fluid g)))) - '(h . i)) - (assert-equal (cons (fluid f) (fluid g)) - '(f . g))))) - (define-test 'PARAMETERS (lambda () (let ((p (make-parameter 1)) @@ -59,41 +45,6 @@ USA. (list condition-type:wrong-type-argument))))) ;; From node "Dynamic Binding" in doc/ref-manual/special-forms.texi: -(define (complicated-dynamic-binding) - (let ((variable (make-fluid 1)) - (inside-continuation)) - (write-line (fluid variable)) - (call-with-current-continuation - (lambda (outside-continuation) - (let-fluid variable 2 - (lambda () - (write-line (fluid variable)) - (set-fluid! variable 3) - (call-with-current-continuation - (lambda (k) - (set! inside-continuation k) - (outside-continuation #t))) - (write-line (fluid variable)) - (set! inside-continuation #f))))) - (write-line (fluid variable)) - (if inside-continuation - (begin - (set-fluid! variable 4) - (inside-continuation #f))))) - -(define-test 'COMPLICATED-DYNAMIC-BINDING - (lambda () - (assert-equal (call-with-output-string - (lambda (port) - (with-output-to-port port complicated-dynamic-binding))) - "1 -2 -1 -3 -4 -"))) - -;; This time with a parameter. (define (complicated-dynamic-parameter) (let ((variable (make-parameter 1)) (inside-continuation)) @@ -102,7 +53,7 @@ USA. (lambda (outside-continuation) (parameterize ((variable 2)) (write-line (variable)) - (set-parameter! variable 3) + (variable 3) (call-with-current-continuation (lambda (k) (set! inside-continuation k) @@ -112,7 +63,7 @@ USA. (write-line (variable)) (if inside-continuation (begin - (set-parameter! variable 4) + (variable 4) (inside-continuation #f))))) (define-test 'COMPLICATED-DYNAMIC-PARAMETER -- 2.25.1