clojure: delay/future/promise with polymorphic deref

ober

69c8d4d3fb60a1e018c9fa0ddb7845af45603d60

diff --git a/lib/std/clojure.sls b/lib/std/clojure.sls
index c6b3b72..20a4a87 100644
--- a/lib/std/clojure.sls
+++ b/lib/std/clojure.sls
@@ -96,10 +96,16 @@
     persistent-set-hash in-pset
 
     ;; ---- Re-exports from (std misc atom) ----
-    atom atom? deref reset! swap! compare-and-set!
+    atom atom? reset! swap! compare-and-set!
     add-watch! remove-watch!
     volatile! volatile? vreset! vswap! vderef
 
+    ;; ---- Delay / Future / Promise (Clojure-style) ----
+    clj-delay delay? clj-force
+    clj-future future? future-cancel future-cancelled? future-done?
+    clj-promise promise? deliver
+    deref
+
     ;; ---- Re-exports from (std misc meta) ----
     with-meta meta vary-meta meta-wrapped? strip-meta
 
@@ -151,7 +157,7 @@
           (rename (std pset)
                   (persistent-set!    pset-persistent!))
           (std concur hash)
-          (std misc atom)
+          (except (std misc atom) deref)
           (std misc meta)
           (std misc nested)
           (only (std misc func) fnil every-pred some-fn)
@@ -1548,7 +1554,164 @@
     (when (lazy-seq? seq)
       (lazy-for-each (lambda (_) (void)) seq)))
 
-  ;; realized? — check if a lazy seq has been forced
-  (define realized? lazy-realized?)
+  ;; realized? — polymorphic: lazy seqs, delays, futures, promises
+  (define (realized? x)
+    (cond
+      [(lazy-seq? x) (lazy-realized? x)]
+      [(delay? x) (delay-realized? x)]
+      [(future? x) (future-done? x)]
+      [(promise? x) (promise-realized? x)]
+      [else (error 'realized? "not a realizable type" x)]))
+
+  ;; =========================================================================
+  ;; Delay / Future / Promise — Clojure-style concurrency primitives
+  ;; =========================================================================
+
+  ;; ---- Delay: lazy memoized computation ----
+  ;; (clj-delay body ...) → delay object, computed at most once on deref
+
+  (define-record-type clj-delay-record
+    (nongenerative std-clojure-delay)
+    (fields thunk
+            (mutable value)
+            (mutable realized?))
+    (sealed #t)
+    (protocol (lambda (new) (lambda (thunk) (new thunk (void) #f)))))
+
+  (define-syntax clj-delay
+    (syntax-rules ()
+      [(_ body ...)
+       (make-clj-delay-record (lambda () body ...))]))
+
+  (define (delay? x) (clj-delay-record? x))
+
+  (define (delay-realized? d) (clj-delay-record-realized? d))
+
+  (define (force-delay d)
+    (unless (clj-delay-record-realized? d)
+      (let ([v ((clj-delay-record-thunk d))])
+        (unless (clj-delay-record-realized? d)
+          (clj-delay-record-value-set! d v)
+          (clj-delay-record-realized?-set! d #t))))
+    (clj-delay-record-value d))
+
+  (define clj-force force-delay)
+
+  ;; ---- Future: computation in a separate thread ----
+  ;; (clj-future body ...) → future object, runs body in a new thread
+
+  (define-record-type clj-future-record
+    (nongenerative std-clojure-future)
+    (fields (mutable value)
+            (mutable done?)
+            (mutable exception)
+            (mutable cancelled?)
+            mutex
+            condvar
+            (mutable thread))
+    (sealed #t))
+
+  (define-syntax clj-future
+    (syntax-rules ()
+      [(_ body ...)
+       (let* ([mtx (make-mutex)]
+              [cv (make-condition)]
+              [f (make-clj-future-record (void) #f #f #f mtx cv #f)])
+         (let ([t (fork-thread
+                    (lambda ()
+                      (guard (exn
+                               [#t
+                                (with-mutex mtx
+                                  (clj-future-record-exception-set! f exn)
+                                  (clj-future-record-done?-set! f #t)
+                                  (condition-broadcast cv))])
+                        (let ([v (begin body ...)])
+                          (with-mutex mtx
+                            (clj-future-record-value-set! f v)
+                            (clj-future-record-done?-set! f #t)
+                            (condition-broadcast cv))))))])
+           (clj-future-record-thread-set! f t)
+           f))]))
+
+  (define (future? x) (clj-future-record? x))
+
+  (define (future-done? f)
+    (clj-future-record-done? f))
+
+  (define (future-cancel f)
+    (with-mutex (clj-future-record-mutex f)
+      (unless (clj-future-record-done? f)
+        (clj-future-record-cancelled?-set! f #t)
+        (clj-future-record-done?-set! f #t)
+        (condition-broadcast (clj-future-record-condvar f))))
+    #t)
+
+  (define (future-cancelled? f)
+    (clj-future-record-cancelled? f))
+
+  (define (deref-future f)
+    (with-mutex (clj-future-record-mutex f)
+      (let loop ()
+        (cond
+          [(clj-future-record-cancelled? f)
+           (error 'deref "future was cancelled")]
+          [(clj-future-record-done? f)
+           (let ([exn (clj-future-record-exception f)])
+             (if exn (raise exn) (clj-future-record-value f)))]
+          [else
+           (condition-wait (clj-future-record-condvar f)
+                           (clj-future-record-mutex f))
+           (loop)]))))
+
+  ;; ---- Promise: write-once value, delivered from another thread ----
+  ;; (clj-promise) → promise object
+  ;; (deliver p val) → delivers val to the promise
+
+  (define-record-type clj-promise-record
+    (nongenerative std-clojure-promise)
+    (fields (mutable value)
+            (mutable realized?)
+            mutex
+            condvar)
+    (sealed #t)
+    (protocol (lambda (new)
+                (lambda ()
+                  (new (void) #f (make-mutex) (make-condition))))))
+
+  (define (clj-promise) (make-clj-promise-record))
+
+  (define (promise? x) (clj-promise-record? x))
+
+  (define (promise-realized? p) (clj-promise-record-realized? p))
+
+  (define (deliver p val)
+    (with-mutex (clj-promise-record-mutex p)
+      (unless (clj-promise-record-realized? p)
+        (clj-promise-record-value-set! p val)
+        (clj-promise-record-realized?-set! p #t)
+        (condition-broadcast (clj-promise-record-condvar p))))
+    p)
+
+  (define (deref-promise p)
+    (with-mutex (clj-promise-record-mutex p)
+      (let loop ()
+        (if (clj-promise-record-realized? p)
+          (clj-promise-record-value p)
+          (begin
+            (condition-wait (clj-promise-record-condvar p)
+                            (clj-promise-record-mutex p))
+            (loop))))))
+
+  ;; ---- Polymorphic deref ----
+  ;; Works on atoms, delays, futures, and promises
+
+  (define (deref x)
+    (cond
+      [(atom? x) (atom-deref x)]
+      [(delay? x) (force-delay x)]
+      [(future? x) (deref-future x)]
+      [(promise? x) (deref-promise x)]
+      [(volatile? x) (vderef x)]
+      [else (error 'deref "not a deref-able type" x)]))
 
 ) ;; end library
diff --git a/tests/test-delay-future-promise.ss b/tests/test-delay-future-promise.ss
new file mode 100644
index 0000000..1c62618
--- /dev/null
+++ b/tests/test-delay-future-promise.ss
@@ -0,0 +1,158 @@
+(import (jerboa prelude))
+(import (std clojure))
+
+(def test-count 0)
+(def pass-count 0)
+
+(defrule (test name body ...)
+  (begin
+    (set! test-count (+ test-count 1))
+    (guard (exn [#t
+      (displayln (str "FAIL: " name))
+      (displayln (str "  Error: " (if (message-condition? exn)
+                                    (condition-message exn) exn)))])
+      body ...
+      (set! pass-count (+ pass-count 1))
+      (displayln (str "PASS: " name)))))
+
+(defrule (assert-equal got expected msg)
+  (unless (equal? got expected)
+    (error 'assert msg (list 'got: got 'expected: expected))))
+
+(defrule (assert-true val msg)
+  (unless val (error 'assert msg)))
+
+;; =========================================================================
+;; Delay tests
+;; =========================================================================
+
+(test "delay creates delay object"
+  (let ([d (clj-delay (+ 1 2))])
+    (assert-true (delay? d) "is delay")))
+
+(test "delay not realized before deref"
+  (let ([d (clj-delay (+ 1 2))])
+    (assert-true (not (realized? d)) "not yet realized")))
+
+(test "deref delay forces computation"
+  (let ([d (clj-delay (+ 1 2))])
+    (assert-equal (deref d) 3 "computed value")))
+
+(test "delay memoizes result"
+  (let ([count 0])
+    (let ([d (clj-delay (set! count (+ count 1)) count)])
+      (assert-equal (deref d) 1 "first deref")
+      (assert-equal (deref d) 1 "second deref — memoized")
+      (assert-equal count 1 "thunk called only once"))))
+
+(test "delay realized after deref"
+  (let ([d (clj-delay 42)])
+    (deref d)
+    (assert-true (realized? d) "realized after deref")))
+
+(test "clj-force works on delay"
+  (let ([d (clj-delay (* 6 7))])
+    (assert-equal (clj-force d) 42 "force")))
+
+;; =========================================================================
+;; Future tests
+;; =========================================================================
+
+(test "future creates future object"
+  (let ([f (clj-future (+ 1 2))])
+    (assert-true (future? f) "is future")
+    (deref f)))  ;; clean up
+
+(test "deref future waits for result"
+  (let ([f (clj-future 42)])
+    (assert-equal (deref f) 42 "future result")))
+
+(test "future-done? after completion"
+  (let ([f (clj-future 42)])
+    (deref f)
+    (assert-true (future-done? f) "done after deref")))
+
+(test "future propagates exceptions"
+  (let ([f (clj-future (error 'test "boom"))])
+    (guard (exn [#t
+      (assert-true (message-condition? exn) "has message")
+      (assert-equal (condition-message exn) "boom" "error message")])
+      (deref f)
+      (error 'test "should have raised"))))
+
+(test "future-cancel"
+  (let ([f (clj-future
+             (let loop () (loop)))])  ;; infinite loop — will be cancelled
+    (future-cancel f)
+    (assert-true (future-cancelled? f) "cancelled")
+    (assert-true (future-done? f) "done after cancel")))
+
+(test "realized? on future"
+  (let ([f (clj-future 99)])
+    (deref f)
+    (assert-true (realized? f) "realized after deref")))
+
+;; =========================================================================
+;; Promise tests
+;; =========================================================================
+
+(test "promise creates promise object"
+  (let ([p (clj-promise)])
+    (assert-true (promise? p) "is promise")))
+
+(test "promise not realized before deliver"
+  (let ([p (clj-promise)])
+    (assert-true (not (realized? p)) "not yet realized")))
+
+(test "deliver and deref promise"
+  (let ([p (clj-promise)])
+    (deliver p 42)
+    (assert-equal (deref p) 42 "delivered value")))
+
+(test "promise realized after deliver"
+  (let ([p (clj-promise)])
+    (deliver p "hello")
+    (assert-true (realized? p) "realized after deliver")))
+
+(test "deliver only once"
+  (let ([p (clj-promise)])
+    (deliver p 1)
+    (deliver p 2)  ;; second deliver is a no-op
+    (assert-equal (deref p) 1 "first delivery wins")))
+
+(test "promise across threads"
+  (let ([p (clj-promise)])
+    (fork-thread (lambda ()
+      (deliver p 42)))
+    (assert-equal (deref p) 42 "delivered from thread")))
+
+;; =========================================================================
+;; Polymorphic deref tests
+;; =========================================================================
+
+(test "deref atom"
+  (let ([a (atom 42)])
+    (assert-equal (deref a) 42 "atom deref")))
+
+(test "deref delay"
+  (let ([d (clj-delay (+ 1 2))])
+    (assert-equal (deref d) 3 "delay deref")))
+
+(test "deref future"
+  (let ([f (clj-future (* 6 7))])
+    (assert-equal (deref f) 42 "future deref")))
+
+(test "deref promise"
+  (let ([p (clj-promise)])
+    (deliver p 99)
+    (assert-equal (deref p) 99 "promise deref")))
+
+;; =========================================================================
+;; Summary
+;; =========================================================================
+(newline)
+(displayln (str "========================================="))
+(displayln (str "Results: " pass-count "/" test-count " passed"))
+(displayln (str "========================================="))
+(when (< pass-count test-count)
+  (exit 1))