home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / DWIND.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  3.2 KB  |  120 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;
  3. ;;;     Copyright Texas Instruments Inc 8/15/85
  4. ;;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;                                                                 ;;;
  9. ;;;                    Dynamic Wind                                 ;;;
  10. ;;;                                                                 ;;;
  11. ;;;              File Updated : May 23, 1985                        ;;;
  12. ;;;                                                                 ;;;
  13. ;;;      This file contains the code to implement dynamic           ;;;
  14. ;;;      wind. User interacts by using dynamic-wind and             ;;;
  15. ;;;      call/cc-dw.                                                ;;;
  16. ;;;                                                                 ;;;
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18. ;;;
  19.  
  20. ;;; macros for states
  21.  
  22. (macro make-new-state
  23.   (lambda (e)
  24.     (cons 'vector (cdr e))))
  25.  
  26. (macro %in-out-flag
  27.   (lambda (e)
  28.     (list 'vector-ref (cadr e) 0)))
  29.  
  30. (macro %before
  31.   (lambda (e)
  32.     (list 'vector-ref (cadr e) 1)))
  33.  
  34. (macro %after
  35.   (lambda (e)
  36.     (list 'vector-ref (cadr e) 2)))
  37.  
  38. (macro %next
  39.   (lambda (e)
  40.     (list 'vector-ref (cadr e) 3)))
  41.  
  42. (macro %set-next
  43.   (lambda (e)
  44.     (list 'vector-set! (cadr e) 3 (caddr e))))
  45.  
  46. (alias %in? %in-out-flag)
  47.  
  48. ;;;
  49. ;;; State Space - routines
  50. ;;;
  51.  
  52. (define dynamic-wind '())
  53. (define call/cc-dw '())
  54.  
  55. (letrec
  56.  
  57.   ((%state-space (vector #T #F #F #F))
  58.  
  59.    (extend-state-space
  60.      (lambda (state)
  61.        (%set-next %state-space state)
  62.        (set! %state-space state)))
  63.  
  64.    (execute-at-new-state
  65.      (lambda (state)
  66.        (letrec 
  67.          ((loop
  68.             (lambda (previous current)
  69.               (if (not (null? (%next current)))
  70.                   (loop current (%next current)))
  71.               (%set-next current previous)
  72.               (if (%in? current)
  73.                   ((%after current))
  74.                   ((%before current)))))
  75.  
  76.           (reroot-state-space
  77.             (lambda ()
  78.               (loop state (%next state))
  79.               (%set-next state #F)
  80.               (set! %state-space state)))
  81.  
  82.           (recompute-new-state
  83.             (lambda ()
  84.               (if (not (%in? state))
  85.                   ((%before state))))))
  86.  
  87.          (if (not (eq? state %state-space))
  88.              (begin
  89.                (reroot-state-space)
  90.                (recompute-new-state)))))))
  91.    
  92.  
  93.  
  94. ;;;
  95.  
  96.   (set! call/cc-dw
  97.     (lambda (f)
  98.       (call/cc
  99.         (lambda (k)
  100.           (let ((state %state-space))
  101.             (let ((cob 
  102.                     (lambda (v)
  103.                       (execute-at-new-state state)
  104.                       (k v))))
  105.               (f cob)))))))
  106.  
  107.  
  108.   (set! dynamic-wind
  109.     (lambda (before body after)
  110.       (let ((state %state-space))
  111.         (extend-state-space
  112.           (make-new-state #T before after #F))
  113.         (before)
  114.         (begin0
  115.           (body)
  116.           (execute-at-new-state state))))))
  117.  
  118.  (define catch call/cc-dw)
  119.  
  120.