lua: coroutines (create/resume/yield/status/wrap) via call/cc +8 tests

lib/lua/runtime.sx

@@ -529,3 +529,125 @@
   (fn
     (args i)
     (if (< i (len args)) (nth args i) nil)))
+
+;; ── Coroutines (call/cc based) ────────────────────────────────
+(define __current-co nil)
+
+(define
+  lua-coroutine-create
+  (fn
+    (f)
+    (let ((co {}))
+      (begin
+        (dict-set! co "__co" true)
+        (dict-set! co "status" "suspended")
+        (dict-set! co "body" f)
+        (dict-set! co "resume-k" nil)
+        (dict-set! co "caller-k" nil)
+        co))))
+
+(define
+  lua-coroutine-status
+  (fn
+    (co)
+    (if (and (= (type-of co) "dict") (has-key? co "__co"))
+        (get co "status")
+        (error "lua: not a coroutine"))))
+
+(define
+  lua-co-wrap-result
+  (fn (r)
+    (cond
+      ((lua-multi? r) (cons (quote lua-multi) (cons true (rest r))))
+      (else (list (quote lua-multi) true r)))))
+
+(define
+  lua-co-first-call
+  (fn (co rvals prev)
+    (let ((r (lua-apply (get co "body") rvals)))
+      (begin
+        (dict-set! co "status" "dead")
+        (set! __current-co prev)
+        ((get co "caller-k") (lua-co-wrap-result r))))))
+
+(define
+  lua-co-continue-call
+  (fn (co rvals)
+    (let ((rk (get co "resume-k")))
+      (begin
+        (dict-set! co "resume-k" nil)
+        (rk (if (> (len rvals) 0) (first rvals) nil))))))
+
+(define
+  lua-coroutine-resume
+  (fn
+    (&rest args)
+    (let ((co (first args)) (rvals (rest args)))
+      (cond
+        ((not (and (= (type-of co) "dict") (has-key? co "__co")))
+          (list (quote lua-multi) false "not a coroutine"))
+        ((= (get co "status") "dead")
+          (list (quote lua-multi) false "cannot resume dead coroutine"))
+        ((= (get co "status") "running")
+          (list (quote lua-multi) false "cannot resume running coroutine"))
+        (else
+          (call/cc
+            (fn (k)
+              (let ((prev __current-co))
+                (begin
+                  (dict-set! co "caller-k" k)
+                  (dict-set! co "status" "running")
+                  (set! __current-co co)
+                  (guard
+                    (e (true
+                         (begin
+                           (dict-set! co "status" "dead")
+                           (set! __current-co prev)
+                           (list (quote lua-multi) false e))))
+                    (cond
+                      ((= (get co "resume-k") nil) (lua-co-first-call co rvals prev))
+                      (else (lua-co-continue-call co rvals)))))))))))))
+
+(define
+  lua-coroutine-yield
+  (fn
+    (&rest yvals)
+    (cond
+      ((= __current-co nil) (error "lua: attempt to yield from outside a coroutine"))
+      (else
+        (call/cc
+          (fn (k)
+            (let ((co __current-co))
+              (begin
+                (dict-set! co "resume-k" k)
+                (dict-set! co "status" "suspended")
+                (set! __current-co nil)
+                ((get co "caller-k") (cons (quote lua-multi) (cons true yvals)))))))))))
+
+(define
+  lua-co-wrap-caller
+  (fn (co args)
+    (let ((r (sx-apply-ref lua-coroutine-resume (cons co args))))
+      (cond
+        ((and (lua-multi? r) (> (len r) 1) (= (nth r 1) true))
+          (cond
+            ((<= (len r) 2) nil)
+            ((= (len r) 3) (nth r 2))
+            (else (cons (quote lua-multi) (rest (rest r))))))
+        ((and (lua-multi? r) (> (len r) 1))
+          (error (if (> (len r) 2) (nth r 2) "coroutine error")))
+        (else nil)))))
+
+(define
+  lua-coroutine-wrap
+  (fn (f)
+    (let ((co (lua-coroutine-create f)))
+      (fn (&rest args) (lua-co-wrap-caller co args)))))
+
+(define coroutine {})
+
+(dict-set! coroutine "create" lua-coroutine-create)
+(dict-set! coroutine "resume" lua-coroutine-resume)
+(dict-set! coroutine "yield" lua-coroutine-yield)
+(dict-set! coroutine "status" lua-coroutine-status)
+(dict-set! coroutine "wrap" lua-coroutine-wrap)