home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / wind.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  209 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: wind.scm,v 14.6 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; State Space Model
  23. ;;; package: (runtime state-space)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;; A STATE-SPACE is a tree of STATE-POINTs, except that the pointers
  28. ;;; in the tree point towards the root of the tree rather than its
  29. ;;; leaves.  These pointers are the NEARER-POINT of each point.
  30.  
  31. ;;; Each point in the space has two procedures, TO-NEARER and
  32. ;;; FROM-NEARER. To move the root of the space to an adjacent point,
  33. ;;; one executes the FROM-NEARER of that point, then makes the
  34. ;;; TO-NEARER and FROM-NEARER of the old root be the FROM-NEARER and
  35. ;;; TO-NEARER of the new root, respectively.
  36.  
  37. (define-integrable with-stack-marker
  38.   (ucode-primitive with-stack-marker 3))
  39.  
  40. (define-structure (state-space
  41.            (conc-name state-space/)
  42.            (constructor %make-state-space))
  43.   nearest-point)
  44.  
  45. (define (make-state-space)
  46.   (let ((space (%make-state-space '())))
  47.     ;; Save the state space in the TO-NEARER field of the root point,
  48.     ;; because it is needed by %%TRANSLATE-TO-STATE-POINT.
  49.     (set-state-space/nearest-point! space (make-state-point false space false))
  50.     space))
  51.  
  52. (define-structure (state-point (conc-name state-point/))
  53.   nearer-point
  54.   to-nearer
  55.   from-nearer)
  56.  
  57. (define (%execute-at-new-state-point space before during after)
  58.   (let ((old-root
  59.      (without-interrupts
  60.       (lambda ()
  61.         (let ((old-root (state-space/nearest-point space)))
  62.           (before)
  63.           ;; Don't trust BEFORE not to change the root; move back
  64.           ;; if it did.
  65.           (if (not (eq? old-root (state-space/nearest-point space)))
  66.           (%%translate-to-state-point old-root))
  67.           (let ((new-point (make-state-point false space false)))
  68.         (set-state-point/nearer-point! old-root new-point)
  69.         (set-state-point/to-nearer! old-root before)
  70.         (set-state-point/from-nearer! old-root after)
  71.         (set-state-space/nearest-point! space new-point))
  72.           old-root)))))
  73.     (let ((value
  74.        (with-stack-marker during %translate-to-state-point old-root)))
  75.       (%translate-to-state-point old-root)
  76.       value)))
  77.  
  78. (define (%translate-to-state-point point)
  79.   (without-interrupts
  80.    (lambda ()
  81.      (%%translate-to-state-point point))))
  82.  
  83. (define (%%translate-to-state-point point)
  84.   (let find-nearest ((point point) (chain '()))
  85.     (let ((nearer-point (state-point/nearer-point point)))
  86.       (if nearer-point
  87.       (find-nearest nearer-point (cons point chain))
  88.       (let ((space (state-point/to-nearer point)))
  89.         (let traverse-chain ((old-root point) (chain chain))
  90.           (if (not (null? chain))
  91.           (let ((new-root (car chain)))
  92.             ;; Move to NEW-ROOT.
  93.             (let ((to-nearer (state-point/to-nearer new-root))
  94.               (from-nearer (state-point/from-nearer new-root)))
  95.               (set-state-point/nearer-point! old-root new-root)
  96.               (set-state-point/to-nearer! old-root from-nearer)
  97.               (set-state-point/from-nearer! old-root to-nearer)
  98.               (set-state-point/nearer-point! new-root false)
  99.               (set-state-point/to-nearer! new-root space)
  100.               (set-state-point/from-nearer! new-root false)
  101.               (set-state-space/nearest-point! space new-root)
  102.               (with-stack-marker from-nearer
  103.             set-interrupt-enables! interrupt-mask/gc-ok))
  104.             ;; Disable interrupts again in case FROM-NEARER
  105.             ;; re-enabled them.
  106.             (set-interrupt-enables! interrupt-mask/gc-ok)
  107.             ;; Make sure that NEW-ROOT is still the root,
  108.             ;; because FROM-NEARER might have moved it.  If
  109.             ;; it has been moved, find the new root, and
  110.             ;; adjust CHAIN as needed.
  111.             (let find-root ((chain chain))
  112.               (let ((nearer-point
  113.                  (state-point/nearer-point (car chain))))
  114.             (cond ((not nearer-point)
  115.                    ;; (CAR CHAIN) is the root.
  116.                    (traverse-chain (car chain) (cdr chain)))
  117.                   ((and (not (null? (cdr chain)))
  118.                     (eq? nearer-point (cadr chain)))
  119.                    ;; The root has moved along CHAIN.
  120.                    (find-root (cdr chain)))
  121.                   (else
  122.                    ;; The root has moved elsewhere.
  123.                    (find-nearest nearer-point
  124.                          chain)))))))))))))
  125.  
  126. (define-integrable (guarantee-state-space space procedure)
  127.   (if (not (state-space? space))
  128.       (error:wrong-type-argument space "state space" procedure)))
  129.  
  130. (define-integrable (guarantee-state-point point procedure)
  131.   (if (not (state-point? point))
  132.       (error:wrong-type-argument point "state point" procedure)))
  133.  
  134. (define (current-state-point space)
  135.   (guarantee-state-space space current-state-point)
  136.   (state-space/nearest-point space))
  137.  
  138. (define (execute-at-new-state-point space before during after)
  139.   (guarantee-state-space space execute-at-new-state-point)
  140.   (%execute-at-new-state-point space before during after))
  141.  
  142. (define (translate-to-state-point point)
  143.   (guarantee-state-point point translate-to-state-point)
  144.   (%translate-to-state-point point))
  145.  
  146. (define (state-point/space point)
  147.   (guarantee-state-point point state-point/space)
  148.   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
  149.     (let loop ((point point))
  150.       (let ((nearer-point (state-point/nearer-point point)))
  151.     (if nearer-point
  152.         (loop nearer-point)
  153.         (begin
  154.           (set-interrupt-enables! interrupt-mask)
  155.           point))))))
  156.  
  157. (define state-space:global)
  158. (define state-space:local)
  159.  
  160. (define (shallow-fluid-bind before during after)
  161.   (%execute-at-new-state-point state-space:global before during after))
  162.  
  163. (define (dynamic-wind before during after)
  164.   (let ((fluid-bindings (state-space/nearest-point state-space:global)))
  165.     (%execute-at-new-state-point
  166.      state-space:local
  167.      (lambda ()
  168.        (%%translate-to-state-point fluid-bindings)
  169.        (before))
  170.      during
  171.      (lambda ()
  172.        (%%translate-to-state-point fluid-bindings)
  173.        (after)))))
  174.  
  175. (define (initialize-package!)
  176.   (set! state-space:global (make-state-space))
  177.   (set! state-space:local (make-state-space))
  178.   unspecific)
  179.  
  180. (define-structure (dynamic-state (conc-name dynamic-state/))
  181.   (global false read-only true)
  182.   (local false read-only true))
  183.  
  184. (define (get-dynamic-state)
  185.   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
  186.     (let ((state
  187.        (make-dynamic-state
  188.         (state-space/nearest-point state-space:global)
  189.         (state-space/nearest-point state-space:local))))
  190.       (set-interrupt-enables! interrupt-mask)
  191.       state)))
  192.  
  193. (define (set-dynamic-state! state global-only?)
  194.   (if (not (dynamic-state? state))
  195.       (error:wrong-type-argument state "dynamic state" set-dynamic-state!))
  196.   (if (not global-only?)
  197.       (%translate-to-state-point (dynamic-state/local state)))
  198.   (%translate-to-state-point (dynamic-state/global state)))
  199.  
  200. (define (merge-dynamic-state state point)
  201.   (let ((space (state-point/space point))
  202.     (global (dynamic-state/global state))
  203.     (local (dynamic-state/local state)))
  204.     (cond ((eq? space (state-point/space global))
  205.        (make-dynamic-state point local))
  206.       ((eq? space (state-point/space local))
  207.        (make-dynamic-state global point))
  208.       (else
  209.        state))))