summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/scripting/script.scm27
1 files changed, 20 insertions, 7 deletions
diff --git a/chickadee/scripting/script.scm b/chickadee/scripting/script.scm
index 97ba811..a67884f 100644
--- a/chickadee/scripting/script.scm
+++ b/chickadee/scripting/script.scm
@@ -30,9 +30,12 @@
#:replace (yield))
(define-record-type <script>
- (make-script status)
+ (make-script status children)
script?
- (status script-status set-script-status!))
+ (status script-status set-script-status!)
+ (children script-children set-script-children!))
+
+(define current-script (make-parameter #f))
(define (display-script script port)
(format port "<script status: ~a>" (script-status script)))
@@ -54,17 +57,18 @@
(define (cancel-script script)
"Prevent further execution of SCRIPT."
(set-script-status! script 'cancelled)
+ (for-each cancel-script (script-children script))
*unspecified*)
(define script-prompt (make-prompt-tag 'script))
(define (spawn-script thunk)
"Apply THUNK as a script."
- (let ((script (make-script 'running)))
+ (let ((script (make-script 'running '())))
(define (handler cont callback . args)
(define (resume . args)
- ;; Call continuation that resumes the procedure, unless, of
- ;; course, the script has been cancelled in the meantime.
+ ;; Call the continuation that resumes the script, unless the
+ ;; script has been cancelled in the meanwhile.
(unless (script-cancelled? script)
(call-with-prompt script-prompt
(lambda () (apply cont args))
@@ -74,8 +78,17 @@
(define task
(let ((dynamic-state (current-dynamic-state)))
(lambda ()
- (with-dynamic-state dynamic-state thunk)
- (set-script-status! script 'complete))))
+ (with-dynamic-state
+ dynamic-state
+ (lambda ()
+ (current-script script)
+ (thunk)
+ (set-script-status! script 'complete))))))
+ ;; Register child script with parent. Cancelling the parent will
+ ;; cause all children to be cancelled as well.
+ (when (script? (current-script))
+ (set-script-children! (current-script)
+ (cons script (script-children (current-script)))))
;; Start the script.
(call-with-prompt script-prompt task handler)
script))