From 51ea61ab6273a710e9f7662bb0987a19e643562a Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 14 Oct 2017 22:01:01 -0400
Subject: scripting: Cancelling a script cancels all nested scripts.

* chickadee/scripting/script.scm (<script>)[children]: New field.
(current-script): New variable.
(cancel-script): Cancel all child scripts, too.
(spawn-script): Register new script as a child of the current script.
---
 chickadee/scripting/script.scm | 27 ++++++++++++++++++++-------
 1 file 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))
-- 
cgit v1.2.3