Implementing while* and until* loops.

* eval.c (while_star_s, until_star_s): New symbol variables.
(me_while_star, me_until_star): New static functions.
(eval_init): Initialize new variables. Register while* and
until* macros.

* txr.1: Documented while* and until*.

* txr.vim, tl.vim: Regenerated.

5 files changed, 90 insertions, 21 deletions

diff --git a/ChangeLog b/ChangeLog
index a4898893..4df75cc6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,18 @@
 2015-04-11  Kaz Kylheku  <kaz@kylheku.com>
 
+	Implementing while* and until* loops.
+
+	* eval.c (while_star_s, until_star_s): New symbol variables.
+	(me_while_star, me_until_star): New static functions.
+	(eval_init): Initialize new variables. Register while* and
+	until* macros.
+
+	* txr.1: Documented while* and until*.
+
+	* txr.vim, tl.vim: Regenerated.
+
+2015-04-11  Kaz Kylheku  <kaz@kylheku.com>
+
 	* sysif.c: Use HAVE_FORK_STUFF to wrap fork, waitpid and dup/dup2.
 
 2015-04-11  Kaz Kylheku  <kaz@kylheku.com>
diff --git a/eval.c b/eval.c
index 1236a84d..4c44614b 100644
--- a/eval.c
+++ b/eval.c
@@ -74,7 +74,7 @@ val eq_s, eql_s, equal_s;
 val inc_s, dec_s, push_s, pop_s, flip_s, zap_s, gethash_s, car_s, cdr_s, not_s;
 val del_s, vecref_s;
 val for_s, for_star_s, each_s, each_star_s, collect_each_s, collect_each_star_s;
-val append_each_s, append_each_star_s, while_s;
+val append_each_s, append_each_star_s, while_s, while_star_s, until_star_s;
 val dohash_s;
 val uw_protect_s, return_s, return_from_s;
 val list_s, append_s, apply_s, iapply_s;
@@ -2204,6 +2204,16 @@ static val me_while(val form, val menv)
                               rest(rest(form)), nao));
 }
 
+static val me_while_star(val form, val menv)
+{
+  val once = gensym(lit("once-"));
+  (void) menv;
+  return apply_frob_args(list(for_s, cons(list(once, t, nao), nil),
+                              list(or_s, once, second(form), nao),
+                              cons(list(zap_s, once, nao), nil),
+                              rest(rest(form)), nao));
+}
+
 static val me_until(val form, val menv)
 {
   val inv = cons(not_s, cons(second(form), nil));
@@ -2212,6 +2222,18 @@ static val me_until(val form, val menv)
                               rest(rest(form)), nao));
 }
 
+static val me_until_star(val form, val menv)
+{
+  val once = gensym(lit("once-"));
+  val inv = cons(not_s, cons(second(form), nil));
+  (void) menv;
+  return apply_frob_args(list(for_s, cons(list(once, t, nao), nil),
+                              list(or_s, once, inv, nao),
+                              cons(list(zap_s, once, nao), nil),
+                              rest(rest(form)), nao));
+}
+
+
 static val me_quasilist(val form, val menv)
 {
   return cons(list_s, cdr(form));
@@ -3823,6 +3845,8 @@ void eval_init(void)
   append_each_star_s = intern(lit("append-each*"), user_package);
   dohash_s = intern(lit("dohash"), user_package);
   while_s = intern(lit("while"), user_package);
+  while_star_s = intern(lit("while*"), user_package);
+  until_star_s = intern(lit("until*"), user_package);
   uw_protect_s = intern(lit("unwind-protect"), user_package);
   return_s = intern(lit("return"), user_package);
   return_from_s = intern(lit("return-from"), user_package);
@@ -3935,7 +3959,9 @@ void eval_init(void)
   reg_mac(when_s, me_when);
   reg_mac(intern(lit("unless"), user_package), me_unless);
   reg_mac(while_s, me_while);
+  reg_mac(while_star_s, me_while_star);
   reg_mac(until_s, me_until);
+  reg_mac(until_star_s, me_until_star);
   reg_mac(quasilist_s, me_quasilist);
   reg_mac(flet_s, me_flet_labels);
   reg_mac(labels_s, me_flet_labels);
diff --git a/tl.vim b/tl.vim
index 419a20a1..3d238f63 100644
--- a/tl.vim
+++ b/tl.vim
@@ -189,16 +189,16 @@ syn keyword txl_keyword contained trim-str true trunc trunc-rem
 syn keyword txl_keyword contained tuples txr-case txr-if txr-when
 syn keyword txl_keyword contained typeof unget-byte unget-char uniq
 syn keyword txl_keyword contained unique unless unquote until
-syn keyword txl_keyword contained upcase-str update url-decode url-encode
-syn keyword txl_keyword contained usleep uw-protect vec vec-push
-syn keyword txl_keyword contained vec-set-length vecref vector vector-list
-syn keyword txl_keyword contained vectorp w-continued w-coredump w-exitstatus
-syn keyword txl_keyword contained w-ifcontinued w-ifexited w-ifsignaled w-ifstopped
-syn keyword txl_keyword contained w-nohang w-stopsig w-termsig w-untraced
-syn keyword txl_keyword contained wait weave when whenlet
-syn keyword txl_keyword contained where while whilet width
-syn keyword txl_keyword contained with-saved-vars wrap wrap* zap
-syn keyword txl_keyword contained zerop zip
+syn keyword txl_keyword contained until* upcase-str update url-decode
+syn keyword txl_keyword contained url-encode usleep uw-protect vec
+syn keyword txl_keyword contained vec-push vec-set-length vecref vector
+syn keyword txl_keyword contained vector-list vectorp w-continued w-coredump
+syn keyword txl_keyword contained w-exitstatus w-ifcontinued w-ifexited w-ifsignaled
+syn keyword txl_keyword contained w-ifstopped w-nohang w-stopsig w-termsig
+syn keyword txl_keyword contained w-untraced wait weave when
+syn keyword txl_keyword contained whenlet where while while*
+syn keyword txl_keyword contained whilet width with-saved-vars wrap
+syn keyword txl_keyword contained wrap* zap zerop zip
 syn match txr_metanum "@[0-9]\+"
 syn match txr_nested_error "[^\t `]\+" contained
 
diff --git a/txr.1 b/txr.1
index b23961d7..6b7c013c 100644
--- a/txr.1
+++ b/txr.1
@@ -10201,6 +10201,36 @@ is if the
 operator is used to terminate the implicit anonymous block,
 and is given an argument, which becomes the result value.
 
+.coNP Macros @ while* and @ until*
+.synb
+.mets (while* < expression << form *)
+.mets (until* < expression << form *)
+.syne
+.desc
+The
+.code while*
+and
+.code until*
+macros are similar, respectively, to the macros
+.code while
+and
+.codn until .
+
+They differ in one respect: they begin by evaluating the
+.metn form -s
+one time unconditionally, without first evaluating
+.metn expression .
+After this evaluation, the subsequent behavior is
+like that of
+.code while
+or
+.codn until .
+
+Another way to regard the behavior is that that these forms execute
+one iteration unconditionally, without evaluating the termination test prior to
+the first iteration. Yet another view is that these constructs relocate the
+test from the "top of the loop" to the "bottom of the loop".
+
 .coNP Macro @ whilet
 .synb
 .mets (whilet ({ sym | >> ( sym << init-form )}+)
diff --git a/txr.vim b/txr.vim
index 182d3fd9..39abd499 100644
--- a/txr.vim
+++ b/txr.vim
@@ -189,16 +189,16 @@ syn keyword txl_keyword contained trim-str true trunc trunc-rem
 syn keyword txl_keyword contained tuples txr-case txr-if txr-when
 syn keyword txl_keyword contained typeof unget-byte unget-char uniq
 syn keyword txl_keyword contained unique unless unquote until
-syn keyword txl_keyword contained upcase-str update url-decode url-encode
-syn keyword txl_keyword contained usleep uw-protect vec vec-push
-syn keyword txl_keyword contained vec-set-length vecref vector vector-list
-syn keyword txl_keyword contained vectorp w-continued w-coredump w-exitstatus
-syn keyword txl_keyword contained w-ifcontinued w-ifexited w-ifsignaled w-ifstopped
-syn keyword txl_keyword contained w-nohang w-stopsig w-termsig w-untraced
-syn keyword txl_keyword contained wait weave when whenlet
-syn keyword txl_keyword contained where while whilet width
-syn keyword txl_keyword contained with-saved-vars wrap wrap* zap
-syn keyword txl_keyword contained zerop zip
+syn keyword txl_keyword contained until* upcase-str update url-decode
+syn keyword txl_keyword contained url-encode usleep uw-protect vec
+syn keyword txl_keyword contained vec-push vec-set-length vecref vector
+syn keyword txl_keyword contained vector-list vectorp w-continued w-coredump
+syn keyword txl_keyword contained w-exitstatus w-ifcontinued w-ifexited w-ifsignaled
+syn keyword txl_keyword contained w-ifstopped w-nohang w-stopsig w-termsig
+syn keyword txl_keyword contained w-untraced wait weave when
+syn keyword txl_keyword contained whenlet where while while*
+syn keyword txl_keyword contained whilet width with-saved-vars wrap
+syn keyword txl_keyword contained wrap* zap zerop zip
 
 syn keyword txr_keyword contained accept all and assert
 syn keyword txr_keyword contained bind block cases cat