1 files changed, 90 insertions, 0 deletions
diff --git a/chickadee/scripting/script.scm b/chickadee/scripting/script.scm
new file mode 100644
index 0000000..df2d6bb
--- /dev/null
+++ b/chickadee/scripting/script.scm
@@ -0,0 +1,90 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2017 David Thompson <davet@gnu.org>
+;;;
+;;; Chickadee is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Chickadee is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (chickadee scripting script)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:export (script?
+            script-cancelled?
+            script-running?
+            script-complete?
+            spawn-script
+            script
+            cancel-script
+            yield)
+  #:replace (yield))
+
+(define-record-type <script>
+  (make-script status)
+  script?
+  (status script-status set-script-status!))
+
+(define (display-script script port)
+  (format port "<script status: ~a>" (script-status script)))
+
+(set-record-type-printer! <script> display-script)
+
+(define (script-cancelled? script)
+  "Return #t if SCRIPT has been cancelled."
+  (eq? 'cancelled (script-status script)))
+
+(define (script-running? script)
+  "Return #t if SCRIPT has not yet terminated or been cancelled."
+  (eq? 'cancelled (script-status script)))
+
+(define (script-complete? script)
+  "Return #t if SCRIPT has terminated."
+  (eq? 'cancelled (script-status script)))
+
+(define (cancel-script script)
+  "Prevent further execution of SCRIPT."
+  (set-script-status! script 'cancelled)
+  *unspecified*)
+
+(define script-prompt (make-prompt-tag 'script))
+
+(define (spawn-script thunk)
+  "Apply THUNK as a script."
+  (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.
+        (unless (script-cancelled? script)
+          (call-with-prompt script-prompt
+            (lambda () (apply cont args))
+            handler)))
+      (when (procedure? callback)
+        (apply callback resume args)))
+    (define task
+      (let ((dynamic-state (current-dynamic-state)))
+        (lambda ()
+          (with-dynamic-state dynamic-state thunk)
+          (set-script-status! script 'complete))))
+    ;; Start the script.
+    (call-with-prompt script-prompt task handler)
+    script))
+
+(define-syntax-rule (script body ...)
+  "Evaluate BODY in a script."
+  (spawn-script (lambda () body ...)))
+
+(define (yield handler)
+  "Suspend the current script and pass its continuation to the
+procedure HANDLER."
+  (abort-to-prompt script-prompt handler))