Alters the contents of @var{cell} to be @var{object}, calls @var{thunk}
with no arguments, then restores the original contents of @var{cell} and
returns the value returned by @var{thunk}. This is completely
-equivalent to dynamic binding of a variable, including the behavior when
-continuations are used (@pxref{Dynamic Binding}).
+equivalent to a dynamic winding that saves and restores the value of
+the cell, including the behavior when
+continuations are used. (@xref{Dynamic Binding}.)
+
+Note that the behavior of this procedure has changed. The new
+behavior allows other threads to see the value bound to @var{cell}.
@end deffn
@node Records, Promises, Parameters, Miscellaneous Datatypes
@item delay
@tab do
@tab er-macro-transformer
-@item fluid-let
-@tab if
+@item if
@tab lambda
-@item let
-@tab let*
+@tab let
+@item let*
@tab let*-syntax
-@item let-syntax
-@tab letrec
+@tab let-syntax
+@item letrec
@tab letrec-syntax
-@item local-declare
-@tab named-lambda
+@tab local-declare
+@item named-lambda
@tab non-hygienic-macro-transformer
-@item or
-@tab quasiquote
+@tab or
+@item quasiquote
@tab quote
-@item rsc-macro-transformer
-@tab sc-macro-transformer
+@tab rsc-macro-transformer
+@item sc-macro-transformer
@tab set!
-@item syntax-rules
-@tab the-environment
+@tab syntax-rules
+@item the-environment
@end multitable
@node Procedure Call Syntax, , Special Form Syntax, Expressions
A @code{parameterize} expression is used to change the values of
specified parameter objects during the evaluation of the body
-@var{expression}s.
+@var{expression}s. These values are not visible to other threads
+executing outside the dynamic extent of the body.
The @var{parameter} and @var{value} expressions are evaluated in an
unspecified order. The body is evaluated in a dynamic
new values are only accessible to the thread that constructed the
dynamic environment, and any threads created within that environment.
+@cindex dynamic extent
@cindex extent, of dynamic binding (defn)
The @dfn{extent} of a dynamic binding is defined to be the time period
during which calling the parameter returns the new value. Normally
@subsection Fluid-Let
-The @code{fluid-let} special form can change the value of @emph{any}
-variable for a dynamic extent, but it is difficult to implement in a
-multi-processing (SMP) world. It and the cell object type
-(@pxref{Cells}) are now @strong{deprecated}. They are still available
-and functional in a uni-processing (non-SMP) world, but will signal an
-error when used in an SMP world. The @code{parameterize} special form
-(@pxref{parameterize}) or @code{let-fluids} procedure
-(@pxref{let-fluids}) should be used instead.
+After version 9.2, the behavior of the @code{fluid-let} special form
+changed, allowing other threads to see the dynamic values of its
+variables. It is now implemented by @code{dynamic-wind} and will
+restore its variables' original values when its body is exited, and
+re-instate the dynamic values when its body is re-entered.
+Thread-local values are implemented now only by @code{parameter} or
+@code{fluid} objects. (@xref{Dynamic Binding}.)
@deffn {special form} fluid-let ((@var{variable} @var{init}) @dots{}) expression expression @dots{}
@cindex variable binding, fluid-let
@findex let
The syntax of this special form is similar to that of @code{let}, but
-@code{fluid-let} temporarily rebinds existing variables. Unlike
+@code{fluid-let} temporarily assigns existing variables. Unlike
@code{let}, @code{fluid-let} creates no new bindings; instead it
@emph{assigns} the value of each @var{init} to the binding (determined
by the rules of lexical scoping) of its corresponding @var{variable}.
@code{fluid-let} operates by means of side effects, it is valid for any
@var{variable} to be unassigned when the form is entered.
@findex condition-type:unbound-variable
+
+This special form is @strong{deprecated} as explained at the beginning
+of this section.
@end deffn
@node Definitions, Assignments, Dynamic Binding, Special Forms
@findex let
@findex let*
@findex letrec
-@findex fluid-let
Definitions are valid in some but not all contexts where expressions are
allowed. Definitions may only occur at the top level of a program and
at the beginning of a lambda body (that is, the body of a @code{lambda},
-@code{let}, @code{let*}, @code{letrec}, @code{fluid-let}, or ``procedure
+@code{let}, @code{let*}, @code{letrec} or ``procedure
@code{define}'' expression). A definition that occurs at the top level
of a program is called a @dfn{top-level definition}, and a definition
that occurs at the beginning of a body is called an @dfn{internal
@findex let
@findex let*
@findex letrec
-@findex fluid-let
@findex define
An @dfn{internal definition} is a definition that occurs at the
beginning of a @var{body} (that is, the body of a @code{lambda},
-@code{let}, @code{let*}, @code{letrec}, @code{fluid-let}, or ``procedure
+@code{let}, @code{let*}, @code{letrec} or ``procedure
@code{define}'' expression), rather than at the top level of a program.
The variable defined by an internal definition is local to the
@var{body}. That is, @var{variable} is bound rather than assigned, and
cond
define @r{;``procedure @code{define}'' only}
do
-fluid-let
lambda
let
let*
@findex cond
@findex define
@findex do
-@findex fluid-let
@findex lambda
@findex let
@findex let*
will cause the system to go to each compiled procedure that calls
@code{newline} and update its execute cache to call the new procedure.
Obviously you want to avoid updating hundreds of execute caches in a
-critical loop. Using @code{fluid-let} to temporarily redefine a
+critical loop. Using @code{dynamic-wind} to temporarily redefine a
procedure has the same inefficiency (but twice!).
To behave correctly in all situations, each variable reference or
(lambda (dynamic-state block-thread-events? interrupt-mask)
(parser/%stack-marker dynamic-state block-thread-events?
interrupt-mask type elements state))))
- (cond ((eq? marker-type %translate-to-state-point)
- (continue (merge-dynamic-state
+ (cond ((eq? marker-type 'EXTEND-DYNAMIC-ENVIRONMENT)
+ (continue (merge-dynamic-environment
(parser-state/dynamic-state state)
marker-instance)
(parser-state/block-thread-events? state)
(parser-state/interrupt-mask state)))
- ((eq? marker-type 'SET-INTERRUPT-ENABLES!)
- (continue (parser-state/dynamic-state state)
+ ((eq? marker-type 'DYNAMIC-WIND)
+ (continue (merge-dynamic-point
+ (parser-state/dynamic-state state)
+ marker-instance)
(parser-state/block-thread-events? state)
- marker-instance))
+ (parser-state/interrupt-mask state)))
((eq? marker-type 'WITH-THREAD-EVENTS-BLOCKED)
(continue (parser-state/dynamic-state state)
marker-instance
(declare (usual-integrations))
\f
-;; The current thread's fluid and parameter bindings.
-(define bindings '())
-
;;;; Fluids
(define-structure fluid
(define (fluid f)
(guarantee-fluid f 'FLUID)
- (let ((entry (assq f bindings)))
+ (let ((entry (assq f (the-dynamic-environment))))
(if entry (cdr entry) (fluid-value f))))
(define (set-fluid! f val)
(guarantee-fluid f 'SET-FLUID!)
- (let ((entry (assq f bindings)))
+ (let ((entry (assq f (the-dynamic-environment))))
(if entry (set-cdr! entry val) (set-fluid-value! f val))))
(define (let-fluid fluid value thunk)
(guarantee-fluid fluid 'LET-FLUID)
(guarantee-thunk thunk 'LET-FLUID)
- (fluid-let ((bindings (cons (cons fluid value) bindings)))
- (thunk)))
+ (with-extended-dynamic-environment (list (cons fluid value)) thunk))
(define (let-fluids . args)
(let loop ((args args)
(if (null? (cdr args))
(begin
(guarantee-thunk (car args) 'LET-FLUIDS)
- (fluid-let ((bindings (append! new-bindings bindings)))
- ((car args))))
+ (with-extended-dynamic-environment new-bindings (car args)))
(begin
(guarantee-fluid (car args) 'LET-FLUIDS)
(loop (cddr args)
(if (not (default-object? converter))
(guarantee-procedure-of-arity converter 1 'MAKE-PARAMETER))
(make-entity (lambda (self)
- (let ((entry (assq self bindings)))
+ (let ((entry (assq self (the-dynamic-environment))))
(if entry
(cdr entry)
(%parameter-value (entity-extra self)))))
(guarantee-parameter p 'PARAMETER-SET!)
(let ((%p (entity-extra p)))
(let ((%v ((%parameter-converter %p) v))
- (entry (assq p bindings)))
+ (entry (assq p (the-dynamic-environment))))
(if entry
(set-cdr! entry %v)
(set-%parameter-value! %p %v)))))
(parameterize* (list EXTENSION ...) (lambda () BODY ...)))))
(define (parameterize* new-bindings thunk)
- (fluid-let
- ((bindings
- (let loop ((new new-bindings))
+ (with-extended-dynamic-environment
+ (let loop ((new new-bindings))
(if (null? new)
- bindings
+ '()
(if (and (pair? new)
(pair? (car new)))
(let ((p (caar new))
(cons p* ((parameter-converter p*) v))))
(loop (cdr new))))
(error:wrong-type-argument
- new-bindings "alist" 'parameterize*))))))
- (thunk)))
\ No newline at end of file
+ new-bindings "alist" 'parameterize*))))
+ thunk))
\ No newline at end of file
(let ((value* value))
(set! value (get-component object))
(set-component! object value*)))
- (shallow-fluid-bind swap! thunk swap!)))
+ (dynamic-wind swap! thunk swap!)))
(define bind-cell-contents!
(object-component-binder cell-contents set-cell-contents!))
'(("syntax-items" . (RUNTIME SYNTAX ITEMS))
("syntax-transforms" . (RUNTIME SYNTAX TRANSFORMS))
("thread" . (RUNTIME THREAD))
- ("wind" . (RUNTIME STATE-SPACE))
+ ("wind" . (RUNTIME WIND))
("prop1d" . (RUNTIME 1D-PROPERTY))
("events" . (RUNTIME EVENT-DISTRIBUTOR))
("gdatab" . (RUNTIME GLOBAL-DATABASE))
(package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
(load-files files2)
(package-initialize '(RUNTIME 1D-PROPERTY) #f #t) ;First population.
- (package-initialize '(RUNTIME STATE-SPACE) #f #t)
(package-initialize '(RUNTIME THREAD) 'INITIALIZE-LOW! #t) ;First 1d-table.
(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) #f #t)
(package-initialize '(RUNTIME GLOBAL-DATABASE) #f #t)
(r-lambda (rename 'LAMBDA))
(r-let (rename 'LET))
(r-set! (rename 'SET!))
- (r-shallow-fluid-bind (rename 'SHALLOW-FLUID-BIND))
+ (r-dynamic-wind (rename 'DYNAMIC-WIND))
(r-unspecific (rename 'UNSPECIFIC)))
(let ((temporaries
(map (lambda (lhs)
left-hand-sides
temporaries)
,r-unspecific)
- (,r-shallow-fluid-bind ,swap! ,body ,swap!)))))))
+ (,r-dynamic-wind ,swap! ,body ,swap!)))))))
(define-syntax :local-declare
(er-macro-transformer
))
))
-(define-package (runtime state-space)
+(define-package (runtime wind)
(files "wind")
(parent (runtime))
(export ()
dynamic-wind
shallow-fluid-bind)
+ (import (runtime thread)
+ thread/dynamic-environment
+ thread/dynamic-point
+ set-thread/dynamic-environment!
+ set-thread/dynamic-point!)
(export (runtime continuation)
get-dynamic-state
set-dynamic-state!)
(export (runtime continuation-parser)
- %translate-to-state-point
- merge-dynamic-state)
+ merge-dynamic-environment
+ merge-dynamic-point)
(export (runtime thread)
- current-state-point
- make-state-space
- state-space:local
- translate-to-state-point)
- (initialization (initialize-package!)))
+ dynamic-unwind))
(define-package (runtime dynamic)
(files "dynamic")
set-parameter!
parameterize
parameter-converter
- parameterize*))
+ parameterize*)
+ (import (runtime wind)
+ the-dynamic-environment
+ with-extended-dynamic-environment))
(define-package (runtime stream)
(files "stream")
;; joined threads can get it. If the thread has been detached,
;; this field holds a condition of type THREAD-DETACHED.
- (root-state-point #f)
- ;; Root state-point of the local state space of the thread. Used to
- ;; unwind the thread's state space when it is exited.
+ (dynamic-point #f)
+ ;; The dynamic-wind point of the thread.
+
+ (dynamic-environment '())
+ ;; The bindings of fluids and parameters.
+
+ (root-dynamic-state #f)
+ ;; Root dynamic-state of the thread. Used to unwind the thread's
+ ;; dynamic state when it exits.
(floating-point-environment #f)
;; A floating-point environment descriptor, or #T if the thread is
(reset-threads-low!)
(let ((first (%make-thread (make-1d-table/unsafe))))
(set-thread/exit-value! first detached-thread-marker)
- (set-thread/root-state-point! first
- (current-state-point state-space:local))
(add-to-population!/unsafe thread-population first)
(%thread-running first)))
(define (make-thread continuation)
(let ((thread (%make-thread (make-1d-table))))
(set-thread/continuation! thread continuation)
- (set-thread/root-state-point! thread
- (current-state-point state-space:local))
+ (set-thread/root-dynamic-state! thread
+ (continuation/dynamic-state continuation))
(add-to-population! thread-population thread)
(thread-running thread)
thread))
(lambda (return)
(%within-continuation root-continuation #t
(lambda ()
- (fluid-let ((state-space:local (make-state-space)))
- (call-with-current-continuation
- (lambda (continuation)
- (let ((thread (make-thread continuation)))
- (%within-continuation (let ((k return)) (set! return #f) k)
- #t
- (lambda () thread)))))
- (set-interrupt-enables! interrupt-mask/all)
- (exit-current-thread
- (with-create-thread-continuation root-continuation thunk)))))))))
+ (call-with-current-continuation
+ (lambda (continuation)
+ (let ((thread (make-thread continuation)))
+ (%within-continuation (let ((k return)) (set! return #f) k)
+ #t
+ (lambda () thread)))))
+ (set-interrupt-enables! interrupt-mask/all)
+ (exit-current-thread
+ (with-create-thread-continuation root-continuation thunk))))))))
(define (create-thread-continuation)
(fluid root-continuation-default))
(set-interrupt-enables! interrupt-mask/gc-ok)
(set-thread/block-events?! thread #t)
(ring/discard-all (thread/pending-events thread))
- (translate-to-state-point (thread/root-state-point thread))
+ (dynamic-unwind thread (thread/root-dynamic-state thread))
(%deregister-io-thread-events thread)
(%discard-thread-timer-records thread)
(%deregister-subprocess-events thread)
(define (wait-for-io)
(%maybe-toggle-thread-timer #f)
- (let ((catch-errors
- (lambda (thunk)
- (let ((thread (console-thread)))
- (if thread
- (bind-condition-handler '()
- (lambda (condition)
- (error:derived-thread thread condition))
- thunk)
- (call-with-current-continuation
- (lambda (k)
- (bind-condition-handler '()
- (lambda (condition)
- condition
- (within-continuation k thunk))
- thunk))))))))
- (let ((result
- (catch-errors
- (lambda ()
- (set-interrupt-enables! interrupt-mask/all)
- (test-select-registry io-registry #t)))))
- (set-interrupt-enables! interrupt-mask/gc-ok)
- (signal-select-result result)
- (let ((thread first-running-thread))
- (if thread
- (if (thread/continuation thread)
- (run-thread thread)
- (%maybe-toggle-thread-timer))
- (wait-for-io))))))
+ (let ((result (begin
+ (set-interrupt-enables! interrupt-mask/all)
+ (test-select-registry io-registry #t))))
+ (set-interrupt-enables! interrupt-mask/gc-ok)
+ (signal-select-result result)
+ (if first-running-thread
+ (run-thread first-running-thread)
+ (wait-for-io))))
\f
(define (signal-select-result result)
(cond ((vector? result)
|#
-;;;; State Space Model
-;;; package: (runtime state-space)
+;;;; Dynamic Windings
+;;; package: (runtime wind)
(declare (usual-integrations))
-;;; A STATE-SPACE is a tree of STATE-POINTs, except that the pointers
-;;; in the tree point towards the root of the tree rather than its
-;;; leaves. These pointers are the NEARER-POINT of each point.
-
-;;; Each point in the space has two procedures, TO-NEARER and
-;;; FROM-NEARER. To move the root of the space to an adjacent point,
-;;; one executes the FROM-NEARER of that point, then makes the
-;;; TO-NEARER and FROM-NEARER of the old root be the FROM-NEARER and
-;;; TO-NEARER of the new root, respectively.
-
-(define-integrable with-stack-marker
- (ucode-primitive with-stack-marker 3))
-
-(define-structure (state-space
- (conc-name state-space/)
- (constructor %make-state-space))
- nearest-point)
-
-(define (make-state-space)
- (let ((space (%make-state-space '())))
- ;; Save the state space in the TO-NEARER field of the root point,
- ;; because it is needed by %%TRANSLATE-TO-STATE-POINT.
- (set-state-space/nearest-point! space (make-state-point #f space #f))
- space))
-
-(define-integrable (guarantee-state-space space caller)
- (if (not (state-space? space))
- (error:wrong-type-argument space "state space" caller)))
-
-(define-structure (state-point (conc-name state-point/))
- nearer-point
- to-nearer
- from-nearer)
-
-(define-integrable (guarantee-state-point point caller)
- (if (not (state-point? point))
- (error:wrong-type-argument point "state point" caller)))
-\f
-(define (%execute-at-new-state-point space before during after)
- (let ((old-root
- (%without-interrupts
- (lambda (interrupt-mask)
- (let ((old-root (state-space/nearest-point space)))
- (before)
- ;; Don't trust BEFORE not to change the root; move back
- ;; if it did.
- (if (not (eq? old-root (state-space/nearest-point space)))
- (%%translate-to-state-point old-root interrupt-mask))
- (let ((new-point (make-state-point #f space #f)))
- (set-state-point/nearer-point! old-root new-point)
- (set-state-point/to-nearer! old-root before)
- (set-state-point/from-nearer! old-root after)
- (set-state-space/nearest-point! space new-point))
- old-root)))))
- (let ((value
- (with-stack-marker during %translate-to-state-point old-root)))
- (%translate-to-state-point old-root)
- value)))
-
-(define (%translate-to-state-point point)
- (%without-interrupts
- (lambda (interrupt-mask)
- (%%translate-to-state-point point interrupt-mask))))
-
-(define (%%translate-to-state-point point interrupt-mask)
- (let find-nearest ((point point) (chain '()))
- (let ((nearer-point (state-point/nearer-point point)))
- (if nearer-point
- (find-nearest nearer-point (cons point chain))
- (let ((space (state-point/to-nearer point)))
- (let traverse-chain ((old-root point) (chain chain))
- (if (not (null? chain))
- (let ((new-root (car chain)))
- ;; Move to NEW-ROOT.
- (let ((to-nearer (state-point/to-nearer new-root))
- (from-nearer (state-point/from-nearer new-root)))
- (set-state-point/nearer-point! old-root new-root)
- (set-state-point/to-nearer! old-root from-nearer)
- (set-state-point/from-nearer! old-root to-nearer)
- (set-state-point/nearer-point! new-root #f)
- (set-state-point/to-nearer! new-root space)
- (set-state-point/from-nearer! new-root #f)
- (set-state-space/nearest-point! space new-root)
- (with-stack-marker from-nearer
- 'SET-INTERRUPT-ENABLES! interrupt-mask))
- ;; Disable interrupts again in case FROM-NEARER
- ;; re-enabled them.
- ((ucode-primitive set-interrupt-enables! 1) interrupt-mask)
- ;; Make sure that NEW-ROOT is still the root,
- ;; because FROM-NEARER might have moved it. If
- ;; it has been moved, find the new root, and
- ;; adjust CHAIN as needed.
- (let find-root ((chain chain))
- (let ((nearer-point
- (state-point/nearer-point (car chain))))
- (cond ((not nearer-point)
- ;; (CAR CHAIN) is the root.
- (traverse-chain (car chain) (cdr chain)))
- ((and (not (null? (cdr chain)))
- (eq? nearer-point (cadr chain)))
- ;; The root has moved along CHAIN.
- (find-root (cdr chain)))
- (else
- ;; The root has moved elsewhere.
- (find-nearest nearer-point
- chain)))))))))))))
-
-(define (%without-interrupts procedure)
- (with-limited-interrupts interrupt-mask/gc-ok
- (lambda (interrupt-mask)
- (procedure (fix:and interrupt-mask interrupt-mask/gc-ok)))))
-\f
-(define (current-state-point space)
- (guarantee-state-space space 'CURRENT-STATE-POINT)
- (state-space/nearest-point space))
-
-(define (execute-at-new-state-point space before during after)
- (guarantee-state-space space 'EXECUTE-AT-NEW-STATE-POINT)
- (%execute-at-new-state-point space before during after))
-
-(define (translate-to-state-point point)
- (guarantee-state-point point 'TRANSLATE-TO-STATE-POINT)
- (%translate-to-state-point point))
-
-(define (state-point/space point)
- (guarantee-state-point point 'STATE-POINT/SPACE)
- (let ((interrupt-mask (limit-interrupts! interrupt-mask/gc-ok)))
- (let loop ((point point))
- (let ((nearer-point (state-point/nearer-point point)))
- (if nearer-point
- (loop nearer-point)
- (begin
- (set-interrupt-enables! interrupt-mask)
- point))))))
-
-(define state-space:global)
-(define state-space:local)
-
-(define (shallow-fluid-bind before during after)
- (%execute-at-new-state-point state-space:global before during after))
+;;; This dynamic-wind follows the example of Scheme48's
+;;; multiprocessing-friendly implementation, which credits Pavel
+;;; Curtis and Scheme Xerox as its inspiration. The earlier,
+;;; uniprocessor-only implementation (of the Hanson/Lamping algorithm)
+;;; can be found on the release-9.2 branch.
+
+;;; A continuation's dynamic state is two part: the stack of
+;;; dynamic-wind points, and the dynamic environment (a stack of
+;;; dynamic bindings). These stacks become trees when continuations
+;;; are invoked multiple times. Both trees are read-only. The trees
+;;; are separate so that the debugger can set-dynamic-state! with
+;;; thread-switch? true. This allows fluid values to be inspected
+;;; without unwinding dynamic-wind points. Otherwise with-extended-
+;;; dynamic-environment might have been implemented in terms of
+;;; dynamic-wind.
(define (dynamic-wind before during after)
- (let ((fluid-bindings (state-space/nearest-point state-space:global)))
+ (let ((fluid-bindings (thread/dynamic-environment (current-thread))))
(%execute-at-new-state-point
- state-space:local
(lambda ()
- (%translate-to-state-point fluid-bindings)
+ (set-thread/dynamic-environment! (current-thread) fluid-bindings)
(before))
during
(lambda ()
- (%translate-to-state-point fluid-bindings)
+ (set-thread/dynamic-environment! (current-thread) fluid-bindings)
(after)))))
-(define (initialize-package!)
- (set! state-space:global (make-state-space))
- (set! state-space:local (make-state-space))
- unspecific)
+(define (shallow-fluid-bind before thunk after)
+ ;; This is just temporary, to avoid hacking the fluid-let macro on
+ ;; your host, which probably expands fluid-lets into applications of
+ ;; shallow-fluid-bind (a free variable).
+ (dynamic-wind before thunk after))
+(define-integrable with-stack-marker
+ (ucode-primitive with-stack-marker 3))
+
+(define-structure (state-point (conc-name state-point/))
+ depth
+ before
+ after
+ env
+ parent)
+
+(define (%execute-at-new-state-point before during after)
+ (let ((thread (current-thread)))
+ (let ((here (thread/dynamic-point thread))
+ (env (thread/dynamic-environment thread)))
+ (before)
+ ;; Don't trust BEFORE not to change the root; move back if it did.
+ (travel-to-point! thread (thread/dynamic-point thread) here)
+ (set-thread/dynamic-environment! thread env)
+ (set-thread/dynamic-point! thread
+ (make-state-point
+ (if here
+ (1+ (state-point/depth here))
+ 1)
+ before after env here))
+ (let ((value
+ (with-stack-marker during 'DYNAMIC-WIND here)))
+ (travel-to-point! thread (thread/dynamic-point thread) here)
+ (set-thread/dynamic-environment! thread env)
+ (set-thread/dynamic-point! thread here)
+ value))))
+
+(define (dynamic-unwind thread root-state)
+ (let ((point (dynamic-state/point root-state))
+ (env (dynamic-state/environment root-state)))
+ (travel-to-point! thread (thread/dynamic-point thread) point)
+ (set-thread/dynamic-environment! thread env)
+ (set-thread/dynamic-point! thread point)))
+
+(define (travel-to-point! thread here target)
+ (cond ((eq? here target) 'done)
+ ((or (not here) ; HERE has reached the root.
+ (and target
+ (< (state-point/depth here)
+ (state-point/depth target))))
+ (travel-to-point! thread here (state-point/parent target))
+ ((state-point/before target))
+ (set-thread/dynamic-environment! thread (state-point/env target))
+ (set-thread/dynamic-point! thread target))
+ (else
+ (set-thread/dynamic-environment! thread (state-point/env here))
+ (set-thread/dynamic-point! thread here)
+ ((state-point/after here))
+ (travel-to-point! thread (state-point/parent here) target))))
+
+(define (the-dynamic-environment)
+ (thread/dynamic-environment (current-thread)))
+
+(define (with-extended-dynamic-environment extension thunk)
+ (let* ((thread (current-thread))
+ (env (thread/dynamic-environment thread)))
+ (set-thread/dynamic-environment!
+ thread
+ (append! extension (thread/dynamic-environment thread)))
+ (let ((val (with-stack-marker thunk 'EXTEND-DYNAMIC-ENVIRONMENT env)))
+ (set-thread/dynamic-environment! thread env)
+ val)))
+\f
(define-structure (dynamic-state (conc-name dynamic-state/))
- (global #f read-only #t)
- (local #f read-only #t))
+ (point #f read-only #t)
+ (environment #f read-only #t))
(define (get-dynamic-state)
- (let ((interrupt-mask (limit-interrupts! interrupt-mask/gc-ok)))
- (let ((state
- (make-dynamic-state
- (state-space/nearest-point state-space:global)
- (state-space/nearest-point state-space:local))))
- (set-interrupt-enables! interrupt-mask)
- state)))
-
-(define (set-dynamic-state! state global-only?)
+ (let ((thread (current-thread)))
+ (make-dynamic-state (thread/dynamic-point thread)
+ (thread/dynamic-environment thread))))
+
+(define (set-dynamic-state! state thread-switch?)
(if (not (dynamic-state? state))
(error:wrong-type-argument state "dynamic state" 'SET-DYNAMIC-STATE!))
- (if (not global-only?)
- (%translate-to-state-point (dynamic-state/local state)))
- (%translate-to-state-point (dynamic-state/global state)))
-
-(define (merge-dynamic-state state point)
- (let ((space (state-point/space point))
- (global (dynamic-state/global state))
- (local (dynamic-state/local state)))
- (cond ((eq? space (state-point/space global))
- (make-dynamic-state point local))
- ((eq? space (state-point/space local))
- (make-dynamic-state global point))
- (else
- state))))
\ No newline at end of file
+ (let ((thread (current-thread))
+ (there (dynamic-state/point state)))
+ (if (not thread-switch?)
+ (travel-to-point! thread (thread/dynamic-point thread) there))
+ (set-thread/dynamic-point! thread there)
+ (set-thread/dynamic-environment! thread (dynamic-state/environment state))))
+
+(define (merge-dynamic-environment state env)
+ (make-dynamic-state (dynamic-state/point state) env))
+
+(define (merge-dynamic-point state point)
+ (make-dynamic-state point (dynamic-state/environment state)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff