120 lines
3.2 KiB
Scheme
120 lines
3.2 KiB
Scheme
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;
|
|||
|
|
;;; Copyright Texas Instruments Inc 8/15/85
|
|||
|
|
;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;; ;;;
|
|||
|
|
;;; Dynamic Wind ;;;
|
|||
|
|
;;; ;;;
|
|||
|
|
;;; File Updated : May 23, 1985 ;;;
|
|||
|
|
;;; ;;;
|
|||
|
|
;;; This file contains the code to implement dynamic ;;;
|
|||
|
|
;;; wind. User interacts by using dynamic-wind and ;;;
|
|||
|
|
;;; call/cc-dw. ;;;
|
|||
|
|
;;; ;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;
|
|||
|
|
|
|||
|
|
;;; macros for states
|
|||
|
|
|
|||
|
|
(macro make-new-state
|
|||
|
|
(lambda (e)
|
|||
|
|
(cons 'vector (cdr e))))
|
|||
|
|
|
|||
|
|
(macro %in-out-flag
|
|||
|
|
(lambda (e)
|
|||
|
|
(list 'vector-ref (cadr e) 0)))
|
|||
|
|
|
|||
|
|
(macro %before
|
|||
|
|
(lambda (e)
|
|||
|
|
(list 'vector-ref (cadr e) 1)))
|
|||
|
|
|
|||
|
|
(macro %after
|
|||
|
|
(lambda (e)
|
|||
|
|
(list 'vector-ref (cadr e) 2)))
|
|||
|
|
|
|||
|
|
(macro %next
|
|||
|
|
(lambda (e)
|
|||
|
|
(list 'vector-ref (cadr e) 3)))
|
|||
|
|
|
|||
|
|
(macro %set-next
|
|||
|
|
(lambda (e)
|
|||
|
|
(list 'vector-set! (cadr e) 3 (caddr e))))
|
|||
|
|
|
|||
|
|
(alias %in? %in-out-flag)
|
|||
|
|
|
|||
|
|
;;;
|
|||
|
|
;;; State Space - routines
|
|||
|
|
;;;
|
|||
|
|
|
|||
|
|
(define dynamic-wind '())
|
|||
|
|
(define call/cc-dw '())
|
|||
|
|
|
|||
|
|
(letrec
|
|||
|
|
|
|||
|
|
((%state-space (vector #!TRUE nil nil nil))
|
|||
|
|
|
|||
|
|
(extend-state-space
|
|||
|
|
(lambda (state)
|
|||
|
|
(%set-next %state-space state)
|
|||
|
|
(set! %state-space state)))
|
|||
|
|
|
|||
|
|
(execute-at-new-state
|
|||
|
|
(lambda (state)
|
|||
|
|
(letrec
|
|||
|
|
((loop
|
|||
|
|
(lambda (previous current)
|
|||
|
|
(if (not (null? (%next current)))
|
|||
|
|
(loop current (%next current)))
|
|||
|
|
(%set-next current previous)
|
|||
|
|
(if (%in? current)
|
|||
|
|
((%after current))
|
|||
|
|
((%before current)))))
|
|||
|
|
|
|||
|
|
(reroot-state-space
|
|||
|
|
(lambda ()
|
|||
|
|
(loop state (%next state))
|
|||
|
|
(%set-next state nil)
|
|||
|
|
(set! %state-space state)))
|
|||
|
|
|
|||
|
|
(recompute-new-state
|
|||
|
|
(lambda ()
|
|||
|
|
(if (not (%in? state))
|
|||
|
|
((%before state))))))
|
|||
|
|
|
|||
|
|
(if (not (eq? state %state-space))
|
|||
|
|
(begin
|
|||
|
|
(reroot-state-space)
|
|||
|
|
(recompute-new-state)))))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;;
|
|||
|
|
|
|||
|
|
(set! call/cc-dw
|
|||
|
|
(lambda (f)
|
|||
|
|
(call/cc
|
|||
|
|
(lambda (k)
|
|||
|
|
(let ((state %state-space))
|
|||
|
|
(let ((cob
|
|||
|
|
(lambda (v)
|
|||
|
|
(execute-at-new-state state)
|
|||
|
|
(k v))))
|
|||
|
|
(f cob)))))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(set! dynamic-wind
|
|||
|
|
(lambda (before body after)
|
|||
|
|
(let ((state %state-space))
|
|||
|
|
(extend-state-space
|
|||
|
|
(make-new-state #!TRUE before after nil))
|
|||
|
|
(before)
|
|||
|
|
(begin0
|
|||
|
|
(body)
|
|||
|
|
(execute-at-new-state state))))))
|
|||
|
|
|
|||
|
|
(define catch call/cc-dw)
|
|||
|
|
|
|||
|
|
|