script: Add join procedure.

2 files changed, 32 insertions, 6 deletions

diff --git a/chickadee/scripting/script.scm b/chickadee/scripting/script.scm
index a67884f..7ba660c 100644
--- a/chickadee/scripting/script.scm
+++ b/chickadee/scripting/script.scm
@@ -26,14 +26,16 @@
             spawn-script
             script
             cancel-script
-            yield)
+            yield
+            join)
   #:replace (yield))
 
 (define-record-type <script>
-  (make-script status children)
+  (make-script status children joined)
   script?
   (status script-status set-script-status!)
-  (children script-children set-script-children!))
+  (children script-children set-script-children!)
+  (joined script-joined set-script-joined!))
 
 (define current-script (make-parameter #f))
 
@@ -54,17 +56,30 @@
   "Return #t if SCRIPT has terminated."
   (eq? 'complete (script-status script)))
 
+(define (script-terminated? script)
+  "Return #t if SCRIPT is in either the completed or cancelled state."
+  (or (script-complete? script) (script-cancelled? script)))
+
 (define (cancel-script script)
   "Prevent further execution of SCRIPT."
   (set-script-status! script 'cancelled)
   (for-each cancel-script (script-children script))
-  *unspecified*)
+  (resume-joined-scripts script))
+
+(define (add-join! script cont)
+  "Add CONT to the list of continuations waiting for SCRIPT to finish."
+  (set-script-joined! script (cons cont (script-joined script))))
+
+(define (resume-joined-scripts script)
+  "Resume all scripts waiting on SCRIPT to terminate."
+  (for-each (lambda (cont) (cont))
+            (script-joined script)))
 
 (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 the continuation that resumes the script, unless the
@@ -83,7 +98,8 @@
            (lambda ()
              (current-script script)
              (thunk)
-             (set-script-status! script 'complete))))))
+             (set-script-status! script 'complete)
+             (resume-joined-scripts script))))))
     ;; Register child script with parent.  Cancelling the parent will
     ;; cause all children to be cancelled as well.
     (when (script? (current-script))
@@ -101,3 +117,9 @@
   "Suspend the current script and pass its continuation to the
 procedure HANDLER."
   (abort-to-prompt script-prompt handler))
+
+(define (join script)
+  "Suspend the current script until SCRIPT has terminated."
+  (unless (script-terminated? script)
+    (yield (lambda (cont)
+             (add-join! script cont)))))
diff --git a/doc/api.texi b/doc/api.texi
index 9ed9eff..e51a81d 100644
--- a/doc/api.texi
+++ b/doc/api.texi
@@ -5120,6 +5120,10 @@ Suspend the current script and pass its continuation to the
 procedure @var{handler}.
 @end deffn
 
+@deffn {Procedure} join script
+Suspend the current script until @var{script} has terminated.
+@end deffn
+
 @deffn {Procedure} sleep duration
 Wait @var{duration} before resuming the current script.
 @end deffn