Also simplify implementation of parameters.
@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
@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.
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}.
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.
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 ...)"
@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)"
@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...\""
@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
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
@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
@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."
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.
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).
@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
@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
@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
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
@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
(@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
(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))))
;;; 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))))
(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))))))))
(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*)
(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))))
(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 ()
(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)
(loop (instruction-stream)))))))
\f
(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)))
(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)
(loop (instruction-stream)))))))
\f
(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)))
(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)
(loop (instruction-stream)))))))
\f
(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)))
(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)
(loop (instruction-stream)))))))
\f
(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)))
(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)
(loop (instruction-stream)))))))
\f
(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)))
(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 ()
#t)))))
\f
(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
(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)
(loop (instruction-stream)))))))
\f
(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)))
(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)
(loop (instruction-stream)))))))
\f
(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)))
(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))
(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)))
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))
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))
(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))
(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
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
(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)
(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)))))
(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
(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)))))
\f
(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)
(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
(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))))
(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)))
(let ((environment (evaluation-environment #f)))
(obarray-completions
(if (and bound-only?
- (fluid
- (environment-lookup
+ ((environment-lookup
environment
'*PARSER-CANONICALIZE-SYMBOLS?*)))
(string-downcase prefix)
((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))))))))
string<?)))))
(define (update-html-index directory)
- ;;(let-fluid load/suppress-loading-message? #t (lambda () (load-option 'XML)))
+ ;;(parameterize* (list (cons load/suppress-loading-message? #t)
+ ;; (lambda () (load-option 'XML)))
(rewrite-file
(merge-pathnames "index.html" directory)
(lambda (in out)
;; Toplevel entry point for the generator.
;; Returns a new C-INCLUDES structure.
(let ((includes (make-c-includes library))
- (cwd (if (fluid load/loading?)
+ (cwd (if (load/loading?)
(directory-pathname (current-load-pathname))
(working-directory-pathname))))
(fluid-let ((c-include-noisily? #t))
(define read-environment
(make-top-level-environment '(*PARSER-CANONICALIZE-SYMBOLS?*)
- (list (make-fluid #f))))
+ (list (make-parameter #f))))
(define (include-cdecl-file filename cwd twd includes)
;; Adds the C declarations in FILENAME to INCLUDES. Interprets
(if (< n (expt 10 (- k 1)))
(string-append (string-pad-left (number->string 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)))
(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?)
(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))
(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)
(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"
(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
(string-append "; **** [" mumble-string " Table Uninitialized]."))))
(define (pc-sample/code-block/display-acate)
- (let ((BTW-string
+ (let ((BTW-string
(string-append
"\n"
";..............................................................\n"
(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)))
,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)
,@(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)))
`#(#((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)))))))
(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))
";~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\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))
(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)
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))
(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)))
(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."
;;;; 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)
(apply trace-display port info)))
message)
environment
- (fluid advice-continuation)))
+ (advice-continuation)))
(define (break-entry procedure)
(advise-entry procedure break-entry-advice))
(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))
(stack-frame/reductions (dstate/subproblem dstate)))
\f
(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
(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
(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)
(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"
(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))))
(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?)
(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
(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)
((#\$)
exponent)))))
\f
(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)
(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)
(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)
(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*)
(lambda ()
(set! bindings (set! temp (set! bindings)))
unspecific)))
- (shallow-fluid-bind swap! thunk swap!))))
-\f
-;;;; 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
\f
(define-integrable (%restarts-argument restarts operator)
(cond ((eq? 'BOUND-RESTARTS restarts)
- (fluid *bound-restarts*))
+ (*bound-restarts*))
((condition? restarts)
(%condition/restarts restarts))
(else
(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
(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)
(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)))
(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
(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)
(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)))
(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)))
(memq condition-type:error (%condition-type/generalizations type)))
\f
(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
(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)
(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)
(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))))
(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
((#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))
(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")
(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)
((ucode-primitive exit-with-value 1) integer)))
(define (quit)
- ((fluid hook/quit)))
+ ((hook/quit)))
(define (%quit)
(with-absolutely-no-interrupts (ucode-primitive halt))
(,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!))
(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)))))))
(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))
(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?))))
(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)
(thunk)))
\f
(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))
(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))
(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)))))
(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)
(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."
(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?))
(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)))))))
(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)))))))
(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)
(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)))
\f
(define (dummy-option-loader)
unspecific)
(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?)
(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)))))))
(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))
(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!))
(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?*)
(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)
(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)))
(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)
(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))
(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))
(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))
(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)
'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)
(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)
(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
(declare (usual-integrations))
\f
(define (initialize-package!)
- (set! *pp-named-lambda->define?* (make-fluid #f))
- (set! *pp-primitives-by-name* (make-fluid #t))
- (set! *pp-uninterned-symbols-by-name* (make-fluid #t))
- (set! *pp-no-highlights?* (make-fluid #t))
- (set! *pp-save-vertical-space?* (make-fluid #f))
- (set! *pp-lists-as-tables?* (make-fluid #t))
- (set! *pp-forced-x-size* (make-fluid #f))
- (set! *pp-avoid-circularity?* (make-fluid #f))
- (set! *pp-default-as-code?* (make-fluid #t))
- (set! *pp-auto-highlighter* (make-fluid #f))
- (set! *pp-arity-dispatched-procedure-style* (make-fluid 'FULL))
- (set! x-size (make-fluid #f))
- (set! output-port (make-fluid #f))
+ (set! *pp-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)
(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)
(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)
(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)))
(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))))
(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))
(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))))
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)))
(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 #\())
(*unparse-char #\newline))
\f
(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))))
(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)
(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)
(*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)))))
\f
(define (print-guaranteed-node node)
(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)))
;;;; 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.
(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))))))
(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.
(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)))
(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
;; 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)))
object))))
\f
(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)))
(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)))
list-depth)))))))))))))
(define-integrable (no-highlights? object)
- (or (fluid *pp-no-highlights?*)
+ (or (*pp-no-highlights?*)
(not (partially-highlighted? object))))
(define (partially-highlighted? object)
(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)
(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)))
(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
;;; 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)))
(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)))
"."
(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)))
half-pointer/queue list-depth)))))))))))))))
\f
(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)))
"."
(make-singleton-list-node
(if (let ((limit
- (fluid *unparser-list-breadth-limit*)))
+ (*unparser-list-breadth-limit*)))
(and limit
(>= list-breadth limit)
(no-highlights? pair)))
(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))
(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)
(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))
\f
;;; The actual queue constructors/extractors
(write symbol port)))))
(define (*unparse-symbol symbol)
- (write symbol (fluid output-port)))
+ (write symbol (output-port)))
(define-structure (prefix-node
(conc-name prefix-node-)
(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
(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))))
;; 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))))
(%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))))
(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))
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)))))
(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)
(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
(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)))
(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
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)
(files "dynamic")
(parent (runtime))
(export ()
- fluid?
- make-fluid
- fluid
- set-fluid!
- let-fluid
- let-fluids
parameter?
make-parameter
parameterize*)
(define *within-restore-window?*)
(define (initialize-package!)
- (set! *within-restore-window?* (make-fluid #f)))
+ (set! *within-restore-window?* (make-parameter #f)))
\f
(define (disk-save filename #!optional id)
(let ((filename (->namestring (merge-pathnames filename)))
(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)
(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 ()
(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))
(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)))))))
\f
;;;; Profile Data
(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
;;;; 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)))))
(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)))
(define name-counters)
(define (initialize-package!)
- (set! name-counters (make-fluid unspecific)))
+ (set! name-counters (make-parameter unspecific)))
\f
;;;; Optimizer
(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)))))))
(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))))
'())))
(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))))
(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))
(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
(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)
(sldb-restarts rs)
(sldb-backtrace c start end)
;;'((0 "dummy frame"))
- (list (fluid *index*)))))
+ (list (*index*)))))
(define (sldb-restarts restarts)
(map (lambda (r)
(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)))
\f
(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))
(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
(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)
(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 '()))
(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))))))
(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/))
(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
(define (unmap-identifier identifier)
(let ((entry
(hash-table/get (rename-database/unmapping-table
- (fluid *rename-database*))
+ (*rename-database*))
identifier
#f)))
(if entry
(define (finalize-mapped-identifier identifier)
(let ((entry
(hash-table/get (rename-database/unmapping-table
- (fluid *rename-database*))
+ (*rename-database*))
identifier
#f)))
(if entry
(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)))
(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)
(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)
"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
(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))
\f
(define (current-thread)
(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*)
(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)))))
\f
(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
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*)
(define *dispatch-table*)
(define (*unparse-object object)
- ((vector-ref (fluid *dispatch-table*)
+ ((vector-ref (*dispatch-table*)
((ucode-primitive primitive-object-type 1) object))
object))
\f
(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)))
(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 #\])))))
\f
;;;; Unparser Methods
(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 ()
(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))
(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)
(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)
(else #f)))
(define (unparse/character character)
- (if (or (fluid *slashify?*)
+ (if (or (*slashify?*)
(not (char-ascii? character)))
(begin
(*unparse-string "#\\")
(*unparse-char character)))
\f
(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))))
(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
(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)))
\f
=> (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))))
(*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 "...")
(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))))
(*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)
((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 " ...")
(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
(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
(*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))
(*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)))))
(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.
(*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
(declare (usual-integrations))
\f
(define (initialize-package!)
- (set! substitutions (make-fluid '()))
+ (set! substitutions (make-parameter '()))
(set! unsyntaxer/scode-walker
(make-scode-walker unsyntax-constant
`((ACCESS ,unsyntax-ACCESS-object)
(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))))
(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)
(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?)
(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
(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)
((#\$)
(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)
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))
(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))))
(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
(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)
(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))))
(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)))
"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
\f
;;; 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
(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)
(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*))
(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)
(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 ()
(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
;; 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
(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)
button2 button3 button4))))
(swat-open me '-title "Featureless Drawing Program")
me)))
-
-
-
-
(declare (usual-integrations))
\f
-(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))
(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))
(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)
(write-line (variable))
(if inside-continuation
(begin
- (set-parameter! variable 4)
+ (variable 4)
(inside-continuation #f)))))
(define-test 'COMPLICATED-DYNAMIC-PARAMETER
projects / mit-scheme.git / commitdiff