>From d1bfb890dadcfe992ff69b8aa9ee13293ee064c2 Mon Sep 17 00:00:00 2001
From: Evan Hanson <address@hidden>
Date: Wed, 30 Oct 2013 20:43:10 +1300
Subject: [PATCH 2/2] R7RS delay/force/delay-force

Implement R7RS's lazy semantics, specifically the space-safe
tail-recursive forcing via delay-force, and a set of tests (mostly taken
from SRFI 45).

Also make promise a single-slot record type, whose value is dispatched
on by type when forcing (since it can now be a procedure, the resulting
values, or (in the case of iterative forcing) another promise).
---
 expand.scm              |   10 +++++
 library.scm             |   36 ++++++++++++------
 tests/r7rs-tests.scm    |   55 +++++++++++++++++++++++++++-
 tests/runtests.sh       |    3 ++
 tests/srfi-45-tests.scm |   93 +++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 184 insertions(+), 13 deletions(-)
 create mode 100644 tests/srfi-45-tests.scm

diff --git a/expand.scm b/expand.scm
index 2f34df3..5838bcf 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1316,6 +1316,16 @@
  (##sys#er-transformer
   (lambda (form r c)
     (##sys#check-syntax 'delay form '(_ _))
+    `(,(r 'delay-force)
+      (##sys#make-promise
+       (##sys#call-with-values (##core#lambda () ,(cadr form)) ##sys#list))))))
+
+(##sys#extend-macro-environment
+ 'delay-force
+ '()
+ (##sys#er-transformer
+  (lambda (form r c)
+    (##sys#check-syntax 'delay-force form '(_ _))
     `(##sys#make-promise (##core#lambda () ,(cadr form))))))
 
 (##sys#extend-macro-environment
diff --git a/library.scm b/library.scm
index d95724a..364b477 100644
--- a/library.scm
+++ b/library.scm
@@ -334,17 +334,29 @@ EOF
       (##core#inline "C_i_check_closure_2" x (car loc))
       (##core#inline "C_i_check_closure" x) ) )
 
-(define (##sys#force promise)
-  (if (##sys#structure? promise 'promise)
-      (apply ##sys#values
-             (or (##sys#slot promise 2)
-                 (let ((results (##sys#call-with-values (##sys#slot promise 1) (lambda xs xs))))
-                   (or (##sys#slot promise 2)
-                       (begin
-                         (##sys#setslot promise 1 #f)
-                         (##sys#setslot promise 2 results)
-                         results)))))
-      promise))
+(define (##sys#force obj)
+  (if (##sys#structure? obj 'promise)
+      (let lp ((promise obj)
+	       (forward #f))
+	(let ((val (##sys#slot promise 1)))
+	  (cond ((null? val) (##sys#values))
+		((pair? val) (apply ##sys#values val))
+		((procedure? val)
+		 (when forward (##sys#setslot forward 1 promise))
+		 (let ((results (##sys#call-with-values val ##sys#list)))
+		   (cond ((not (procedure? (##sys#slot promise 1)))
+			  (lp promise forward)) ; in case of reentrance
+			 ((and (not (null? results)) (null? (cdr results))
+			       (##sys#structure? (##sys#slot results 0) 'promise))
+			  (let ((result0 (##sys#slot results 0)))
+			    (##sys#setslot promise 1 (##sys#slot result0 1))
+			    (lp promise result0)))
+			 (else
+			  (##sys#setslot promise 1 results)
+			  (apply ##sys#values results)))))
+		((##sys#structure? val 'promise)
+		 (lp val forward)))))
+      obj))
 
 (define force ##sys#force)
 
@@ -4823,7 +4835,7 @@ EOF
 ;;; Promises:
 
 (define (##sys#make-promise proc)
-  (##sys#make-structure 'promise proc #f))
+  (##sys#make-structure 'promise proc))
 
 (define (promise? x)
   (##sys#structure? x 'promise) )
diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
index f47eacd..670e959 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -77,7 +77,60 @@
 (test #t procedure? (force (make-promise (lambda _ 1))))
 (test 1 force (make-promise (make-promise 1)))
 
-
+;; delay/force/delay-force
+(test #t promise? (delay 1))
+(test #t promise? (delay (delay 1)))
+(test 1 force 1)
+(test force force (force (delay force)))
+
+(test 3 force (delay (+ 1 2))) ; pp. 18
+(let ((p (delay (+ 1 2))))
+  (test '(3 3) list (force p) (force p)))
+
+(let () ; pp. 19
+  (define integers
+    (letrec ((next
+	      (lambda (n)
+		(delay (cons n (next (+ n 1)))))))
+      (next 0)))
+  (define head
+    (lambda (stream) (car (force stream))))
+  (define tail
+    (lambda (stream) (cdr (force stream))))
+  (test 0 head integers)
+  (test 0 head integers)
+  (test 1 head (tail integers))
+  (test 2 head (tail (tail integers))))
+
+(let () ; later on pp. 19
+  (define count 0)
+  (define p
+    (delay (begin (set! count (+ count 1))
+	     (if (> count x)
+		 count
+		 (force p)))))
+  (define x 5)
+  (test #t promise? p)
+  (test 6 force p)
+  (test #t promise? p)
+  (set! x 10)
+  (test 6 force p))
+
+(test #t promise? (delay-force 1))
+(test 1 force (delay-force 1))
+(test 6 force (delay-force (+ 1 2 3)))
+(test #t promise? (delay-force (delay 1)))
+
+;; delayed MVs
+(call-with-values
+ (lambda () (force (delay (values 1 2 3))))
+ (lambda mv (test '(1 2 3) #f mv)))
+(call-with-values
+ (lambda () (force (delay-force (values 4 5 6))))
+ (lambda mv (test '(4 5 6) #f mv)))
+(call-with-values
+ (lambda () (force (delay (values))))
+ (lambda mv (test '() #f mv)))
 
 (SECTION 6 6)
 
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 43dd392..16e4bc2 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -335,6 +335,9 @@ $interpret -s data-structures-tests.scm
 echo "======================================== path tests ..."
 $interpret -bnq path-tests.scm
 
+echo "======================================== srfi-45 tests ..."
+$interpret -s srfi-45-tests.scm
+
 echo "======================================== posix tests ..."
 $compile posix-tests.scm
 ./a.out
diff --git a/tests/srfi-45-tests.scm b/tests/srfi-45-tests.scm
new file mode 100644
index 0000000..1950fd3
--- /dev/null
+++ b/tests/srfi-45-tests.scm
@@ -0,0 +1,93 @@
+;;; Tests adapted from SRFI 45 (for "lazy" -> "delay-force").
+;;; That SRFI Copyright (C) André van Tonder (2003).
+
+(use (only ports with-output-to-string))
+
+(define *errors* 0)
+
+(define-syntax test
+  (syntax-rules ()
+    ((_ name expect form)
+     (let ((ok (equal? expect form)))
+       (printf "(~a) ~a~n" (if ok "PASS" "FAIL") name)
+       (when (not ok) (set! *errors* (add1 *errors*)))))))
+
+(define-syntax output
+  (syntax-rules ()
+    ((_ . body) (with-output-to-string (lambda () . body)))))
+
+(test "Memoization test 1"
+      "hello"
+      (output (define s (delay (begin (display 'hello) 1)))
+	      (force s)
+	      (force s)))
+
+(test "Memoization test 2"
+      "bonjour"
+      (output (let ((s (delay (begin (display 'bonjour) 2))))
+		(+ (force s) (force s)))))
+
+(test "Memoization test 3"
+      "hi"
+      (output (define r (delay (begin (display 'hi) 1)))
+	      (define s (delay-force r))
+	      (define t (delay-force s))
+	      (force t)
+	      (force r)))
+
+(test "Memoization test 4"
+      "hohohohoho"
+      (output (define (stream-drop s index)
+		(delay-force
+		 (if (zero? index)
+		     s
+		     (stream-drop (cdr (force s)) (- index 1)))))
+	      (define (ones)
+		(delay (begin
+			 (display 'ho)
+			 (cons 1 (ones)))))
+	      (define s (ones))
+	      (car (force (stream-drop s 4)))
+	      (car (force (stream-drop s 4)))))
+
+(let ()
+  (define count 0)
+  (define p
+    (delay (begin (set! count (+ count 1))
+		  (if (> count x)
+		      count
+		      (force p)))))
+  (define x 5)
+  (test "Reentrancy test 1 (1)" 6 (force p))
+  (set! x 10)
+  (test "Reentrancy test 1 (2)" 6 (force p)))
+
+(let ()
+  (define f
+    (let ((first? #t))
+      (delay
+       (if first?
+	   (begin
+	     (set! first? #f)
+	     (force f))
+	   'second))))
+  (test "Reentrancy test 2" 'second (force f)))
+
+(let ()
+  (define q
+    (let ((count 5))
+      (define (get-count) count)
+      (define p (delay (if (<= count 0)
+			   count
+			   (begin (set! count (- count 1))
+				  (force p)
+				  (set! count (+ count 2))
+				  count))))
+      (list get-count p)))
+  (define get-count (car q))
+  (define p (cadr q))
+  (test "Reentrancy test 3 (1)" 5 (get-count))
+  (test "Reentrancy test 3 (2)" 0 (force p))
+  (test "Reentrancy test 3 (3)" 10 (get-count)))
+
+(exit *errors*)
-- 
1.7.10.4