delay/force overhaul.

* eval.c (promise_forced_s, promise_inprogress_s): New symbol
variables.
(me_delay): Change representation of promises so that the
original delay form is stashed there for better reporting
in the force function. Also, propagate the debug info
from the second argument of the form to the entire form;
otherwise it will inherit it from elsewhere.
(force): Rewritten to follow new three-state representation
to detect the recursive case and diagnose it.
(eval_init): Register new symbol variables.

2 files changed, 45 insertions, 7 deletions

diff --git a/ChangeLog b/ChangeLog
index 90d84f1c..1025fa7e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2015-04-22  Kaz Kylheku  <kaz@kylheku.com>
+
+	delay/force overhaul.
+
+	* eval.c (promise_forced_s, promise_inprogress_s): New symbol
+	variables.
+	(me_delay): Change representation of promises so that the
+	original delay form is stashed there for better reporting
+	in the force function. Also, propagate the debug info
+	from the second argument of the form to the entire form;
+	otherwise it will inherit it from elsewhere.
+	(force): Rewritten to follow new three-state representation
+	to detect the recursive case and diagnose it.
+	(eval_init): Register new symbol variables.
+
 2015-04-21  Kaz Kylheku  <kaz@kylheku.com>
 
 	Version 106
diff --git a/eval.c b/eval.c
index 35b1c2cc..9d9c7c2a 100644
--- a/eval.c
+++ b/eval.c
@@ -79,7 +79,8 @@ val dohash_s;
 val uw_protect_s, return_s, return_from_s;
 val list_s, append_s, apply_s, iapply_s;
 val gen_s, gun_s, generate_s, rest_s, plus_s;
-val promise_s, op_s, ap_s, identity_s, apf_s, ipf_s;
+val promise_s, promise_forced_s, promise_inprogress_s;
+val op_s, ap_s, identity_s, apf_s, ipf_s;
 val ret_s, aret_s;
 val hash_lit_s, hash_construct_s;
 val vector_lit_s, vector_list_s;
@@ -2163,9 +2164,12 @@ static val me_gun(val form, val menv)
 static val me_delay(val form, val menv)
 {
   (void) menv;
+  rlcp_tree(rest(form), second(form));
   return list(cons_s,
               cons(quote_s, cons(promise_s, nil)),
-              cons(lambda_s, cons(nil, rest(form))), nao);
+              list(cons_s, cons(lambda_s, cons(nil, rest(form))),
+                   cons(quote_s, cons(form, nil)), nao),
+              nao);
 }
 
 static val me_pprof(val form, val menv)
@@ -3630,11 +3634,28 @@ static val weavev(val lists)
 
 static val force(val promise)
 {
-  if (car(promise) != promise_s)
-    return cdr(promise);
-
-  rplaca(promise, nil);
-  return cdr(rplacd(promise, funcall(cdr(promise))));
+  loc pstate = car_l(promise);
+  val cd = cdr(promise);
+  loc pval = car_l(cd);
+
+  if (deref(pstate) == promise_forced_s) {
+    return deref(pval);
+  } else if (deref(pstate) == promise_s) {
+    val ret;
+    /* Safe: promise symbols are older generation */
+    deref(pstate) = promise_inprogress_s;
+    ret = funcall(deref(pval));
+    deref(pstate) = promise_forced_s;
+    deref(pval) = ret;
+    return ret;
+  } else if (deref(pstate) == promise_inprogress_s) {
+    val form = second(cdr(cd));
+    val sloc = source_loc_str(form);
+    eval_error(nil, lit("force: recursion forcing delayed form ~s (~a)"),
+               form, sloc, nao);
+  } else {
+    uw_throwf(error_s, lit("force: ~s is not a promise"), promise, nao);
+  }
 }
 
 static void reg_op(val sym, opfun_t fun)
@@ -3894,6 +3915,8 @@ void eval_init(void)
   gun_s = intern(lit("gun"), user_package);
   generate_s = intern(lit("generate"), user_package);
   promise_s = intern(lit("promise"), system_package);
+  promise_forced_s = intern(lit("promise-forced"), system_package);
+  promise_inprogress_s = intern(lit("promise-inprogress"), system_package);
   op_s = intern(lit("op"), user_package);
   ap_s = intern(lit("ap"), user_package);
   do_s = intern(lit("do"), user_package);