New whilet macro.

* eval.c (while_s): New symbol variable.
(me_whilet): New static function.
(eval_init): Initialize while_s. Use while_s in registration
of while macro. Register new whilet macro.

* txr.1: whilet is documented.

* tl.vim, txr.vim: Regenerated.

5 files changed, 125 insertions, 28 deletions

diff --git a/ChangeLog b/ChangeLog
index dac4784b..bf4ec2da 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+2015-04-05  Kaz Kylheku  <kaz@kylheku.com>
+
+	New whilet macro.
+
+	* eval.c (while_s): New symbol variable.
+	(me_whilet): New static function.
+	(eval_init): Initialize while_s. Use while_s in registration
+	of while macro. Register new whilet macro.
+
+	* txr.1: whilet is documented.
+
+	* tl.vim, txr.vim: Regenerated.
+
 2015-04-01  Kaz Kylheku  <kaz@kylheku.com>
 
 	New zap operator.
diff --git a/eval.c b/eval.c
index 2bd4121d..2a2b0e97 100644
--- a/eval.c
+++ b/eval.c
@@ -73,7 +73,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;
+val append_each_s, append_each_star_s, while_s;
 val dohash_s;
 val uw_protect_s, return_s, return_from_s;
 val list_s, append_s, apply_s, iapply_s;
@@ -2779,6 +2779,25 @@ static val me_ignerr(val form, val menv)
               list(error_s, error_s, nao), nao);
 }
 
+static val me_whilet(val form, val env)
+{
+  val body = form;
+  val sym = pop(&body);
+  val lets = pop(&body);
+  val lastlet = last(lets);
+  val not_done = gensym(lit("not-done"));
+
+  if (nilp(lastlet))
+    eval_error(form, lit("~s: empty binding list"), sym, nao);
+
+  return list(let_s, cons(list(not_done, t, nao), nil),
+              list(while_s, not_done,
+                   list(let_star_s, lets,
+                        list(if_s, car(car(lastlet)),
+                             cons(progn_s, body),
+                             list(set_s, not_done, nil, nao), nao), nao), nao), nao);
+}
+
 static val expand_catch_clause(val form, val menv)
 {
   val sym = first(form);
@@ -3785,6 +3804,7 @@ void eval_init(void)
   append_each_s = intern(lit("append-each"), user_package);
   append_each_star_s = intern(lit("append-each*"), user_package);
   dohash_s = intern(lit("dohash"), user_package);
+  while_s = intern(lit("while"), 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);
@@ -3896,7 +3916,7 @@ void eval_init(void)
   reg_mac(intern(lit("pprof"), user_package), me_pprof);
   reg_mac(intern(lit("when"), user_package), me_when);
   reg_mac(intern(lit("unless"), user_package), me_unless);
-  reg_mac(intern(lit("while"), user_package), me_while);
+  reg_mac(while_s, me_while);
   reg_mac(intern(lit("until"), user_package), me_until);
   reg_mac(quasilist_s, me_quasilist);
   reg_mac(flet_s, me_flet_labels);
@@ -3909,6 +3929,7 @@ void eval_init(void)
   reg_mac(opip_s, me_opip);
   reg_mac(oand_s, me_opip);
   reg_mac(intern(lit("ignerr"), user_package), me_ignerr);
+  reg_mac(intern(lit("whilet"), user_package), me_whilet);
 
   reg_fun(cons_s, func_n2(cons));
   reg_fun(intern(lit("make-lazy-cons"), user_package), func_n1(make_lazy_cons));
diff --git a/tl.vim b/tl.vim
index 34ede875..0bcc6c75 100644
--- a/tl.vim
+++ b/tl.vim
@@ -181,19 +181,19 @@ syn keyword txl_keyword contained tc tf third throw
 syn keyword txl_keyword contained throwf time time-fields-local time-fields-utc
 syn keyword txl_keyword contained time-string-local time-string-utc time-usec tofloat
 syn keyword txl_keyword contained toint tok-str tok-where tostring
-syn keyword txl_keyword contained tostringp transpose tree-bind tree-case
-syn keyword txl_keyword contained tree-find trie-add trie-compress trie-lookup-begin
-syn keyword txl_keyword contained trie-lookup-feed-char trie-value-at trim-str true
-syn keyword txl_keyword contained trunc trunc-rem tuples txr-case
-syn keyword txl_keyword contained txr-if txr-when typeof unget-byte
-syn keyword txl_keyword contained unget-char uniq unique unless
-syn keyword txl_keyword contained unquote until upcase-str update
-syn keyword txl_keyword contained url-decode url-encode usleep uw-protect
-syn keyword txl_keyword contained vec vec-push vec-set-length vecref
-syn keyword txl_keyword contained vector vector-list vectorp weave
-syn keyword txl_keyword contained when where while width
-syn keyword txl_keyword contained with-saved-vars wrap wrap* zerop
-syn keyword txl_keyword contained zip
+syn keyword txl_keyword contained tostringp tprint transpose tree-bind
+syn keyword txl_keyword contained tree-case tree-find trie-add trie-compress
+syn keyword txl_keyword contained trie-lookup-begin trie-lookup-feed-char trie-value-at trim-str
+syn keyword txl_keyword contained true trunc trunc-rem tuples
+syn keyword txl_keyword contained txr-case txr-if txr-when typeof
+syn keyword txl_keyword contained unget-byte unget-char uniq unique
+syn keyword txl_keyword contained unless unquote until upcase-str
+syn keyword txl_keyword contained update url-decode url-encode usleep
+syn keyword txl_keyword contained uw-protect vec vec-push vec-set-length
+syn keyword txl_keyword contained vecref vector vector-list vectorp
+syn keyword txl_keyword contained weave when where 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 745520fe..3bb05aae 100644
--- a/txr.1
+++ b/txr.1
@@ -10029,6 +10029,69 @@ is if the
 operator is used to terminate the implicit anonymous block,
 and is given an argument, which becomes the result value.
 
+.coNP Macro @ whilet
+.synb
+.mets (whilet ({ sym | >> ( sym << init-form )}+)
+.mets \ \  < body-form *)
+.syne
+.desc
+The
+.code whilet
+macro provides a construct which combines iteration with variable
+binding.
+
+The evaluation of the form takes place as follows. First, fresh bindings are
+established for
+.metn sym -s
+as if by the
+.code let*
+operator.
+It is an error for the list of variable bindings to be empty.
+
+After the establishment of the bindings, the the value of the
+.meta sym
+is tested. If the value is
+.codn nil ,
+then
+.code whilet
+terminates. Otherwise,
+.metn body-form -s
+are evaluated in the scope of the variable bindings, and then
+.code whilet
+iterates from the beginning, again establishing fresh bindings for the
+.metn sym -s,
+and testing the value of the last
+.metn sym .
+
+
+All evaluation takes place in an anonymous block, which can be
+terminated with the
+.code return
+operator. Doing so terminates the loop.
+If the
+.code whilet
+loop is thus terminated by an explicit
+.codn return ,
+a return value can be specified. Under normal termination, the return value is
+.codn nil .
+
+.TP* Examples:
+.cblk
+  ;; read lines of text from *std-input* and print them,
+  ;; until the end-of-stream condition:
+
+  (whilet ((line (get-line)))
+    (put-line line))
+
+  ;; read lines of text from *std-input* and print them,
+  ;; until the end-of-stream condition occurs or
+  ;; a line is identical to the character string "end".
+
+  (whilet ((line (get-line))
+           (more (and line (not (equal line "end")))))
+    (put-line line))
+.cble
+
 .coNP Operator/function @ if
 .synb
 .mets (if < cond < t-form <> [ e-form ])
diff --git a/txr.vim b/txr.vim
index 5d1c999d..15dd9e9f 100644
--- a/txr.vim
+++ b/txr.vim
@@ -181,19 +181,19 @@ syn keyword txl_keyword contained tc tf third throw
 syn keyword txl_keyword contained throwf time time-fields-local time-fields-utc
 syn keyword txl_keyword contained time-string-local time-string-utc time-usec tofloat
 syn keyword txl_keyword contained toint tok-str tok-where tostring
-syn keyword txl_keyword contained tostringp transpose tree-bind tree-case
-syn keyword txl_keyword contained tree-find trie-add trie-compress trie-lookup-begin
-syn keyword txl_keyword contained trie-lookup-feed-char trie-value-at trim-str true
-syn keyword txl_keyword contained trunc trunc-rem tuples txr-case
-syn keyword txl_keyword contained txr-if txr-when typeof unget-byte
-syn keyword txl_keyword contained unget-char uniq unique unless
-syn keyword txl_keyword contained unquote until upcase-str update
-syn keyword txl_keyword contained url-decode url-encode usleep uw-protect
-syn keyword txl_keyword contained vec vec-push vec-set-length vecref
-syn keyword txl_keyword contained vector vector-list vectorp weave
-syn keyword txl_keyword contained when where while width
-syn keyword txl_keyword contained with-saved-vars wrap wrap* zerop
-syn keyword txl_keyword contained zip
+syn keyword txl_keyword contained tostringp tprint transpose tree-bind
+syn keyword txl_keyword contained tree-case tree-find trie-add trie-compress
+syn keyword txl_keyword contained trie-lookup-begin trie-lookup-feed-char trie-value-at trim-str
+syn keyword txl_keyword contained true trunc trunc-rem tuples
+syn keyword txl_keyword contained txr-case txr-if txr-when typeof
+syn keyword txl_keyword contained unget-byte unget-char uniq unique
+syn keyword txl_keyword contained unless unquote until upcase-str
+syn keyword txl_keyword contained update url-decode url-encode usleep
+syn keyword txl_keyword contained uw-protect vec vec-push vec-set-length
+syn keyword txl_keyword contained vecref vector vector-list vectorp
+syn keyword txl_keyword contained weave when where 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