Adding a tagbody macro to the language.

This is a "disciplined goto" feature of Common Lisp.
This uses a new sys:switch operator, which could
also be used for optimizing case and cond forms.

* eval.c (switch_s): New symbol variable.
(op_switch, expand_list_of_form_lists, expand_switch):
New static functions.
(do_expand): Hook in the expansion of the sys:switch
operator.
(eval_init): Initialize switch_s special variable to
sys:switch symbol. Register sys:switch special op.

* lisplib.c (tagbody_set_entries, tagbody_instantiate): New
static functions.
(lisplib_init): Register autoloading of tagbody module
via new functions.

* share/txr/stdlib/tagbody.tl: New file.

* txr.1: Documented.

4 files changed, 305 insertions, 1 deletions

diff --git a/eval.c b/eval.c
index e8ac079e..2bf3d694 100644
--- a/eval.c
+++ b/eval.c
@@ -97,7 +97,7 @@ val ret_s, aret_s;
 val hash_lit_s, hash_construct_s, struct_lit_s, qref_s;
 val vector_lit_s, vec_list_s;
 val macro_time_s, with_saved_vars_s, macrolet_s;
-val defsymacro_s, symacrolet_s, prof_s;
+val defsymacro_s, symacrolet_s, prof_s, switch_s;
 val fbind_s, lbind_s, flet_s, labels_s;
 val opip_s, oand_s, chain_s, chand_s;
 val load_path_s, sys_lisp1_value_s;
@@ -2378,6 +2378,16 @@ static val op_prof(val form, val env)
               nao);
 }
 
+static val op_switch(val form, val env)
+{
+  val args = cdr(form);
+  val expr = pop(&args);
+  val branches = car(args);
+  val index = eval(expr, env, expr);
+  val forms = ref(branches, index);
+  return eval_progn(forms, env, forms);
+}
+
 static val me_def_variable(val form, val menv)
 {
   val args = rest(form);
@@ -3484,6 +3494,38 @@ static val expand_save_specials(val form, val specials)
   return rlcp(cons(with_saved_vars_s, cons(form, nil)), form);
 }
 
+static val expand_list_of_form_lists(val lofl, val menv)
+{
+  list_collect_decl (out, ptail);
+
+  for (; lofl; lofl = cdr(lofl)) {
+    val forms = car(lofl);
+    val forms_ex = expand_forms(forms, menv);
+    ptail = list_collect(ptail, forms_ex);
+  }
+
+  return out;
+}
+
+static val expand_switch(val form, val menv)
+{
+  val sym = first(form);
+  val args = rest(form);
+  val expr = first(args);
+  val branches = second(args);
+  val expr_ex = expand(expr, menv);
+  val branches_ex;
+
+  if (listp(branches)) {
+    branches_ex = expand_list_of_form_lists(branches, menv);
+  } else if (vectorp(branches)) {
+    branches_ex = vec_list(expand_list_of_form_lists(list_vec(branches), menv));
+  } else {
+    eval_error(form, lit("~s: representation of branches"), sym, nao);
+  }
+  return rlcp(cons(sym, cons(expr_ex, cons(branches_ex, nil))), form);
+}
+
 static val do_expand(val form, val menv)
 {
   val macro = nil;
@@ -3720,6 +3762,8 @@ static val do_expand(val form, val menv)
       if (args == args_ex)
         return form;
       return rlcp(cons(sym, args_ex), form);
+    } else if (sym == switch_s) {
+      return expand_switch(form, menv);
     } else if ((macro = lookup_mac(menv, sym))) {
       val mac_expand = expand_macro(form, macro, menv);
       if (mac_expand == form)
@@ -4828,6 +4872,7 @@ void eval_init(void)
   unbound_s = intern(lit("unbound"), system_package);
   symacro_k = intern(lit("symacro"), keyword_package);
   prof_s = intern(lit("prof"), user_package);
+  switch_s = intern(lit("switch"), system_package);
   opip_s = intern(lit("opip"), user_package);
   oand_s = intern(lit("oand"), user_package);
   chain_s = intern(lit("chain"), user_package);
@@ -4893,6 +4938,7 @@ void eval_init(void)
   reg_op(handler_bind_s, op_handler_bind);
   reg_op(with_saved_vars_s, op_with_saved_vars);
   reg_op(prof_s, op_prof);
+  reg_op(switch_s, op_switch);
 
   reg_mac(defvar_s, me_def_variable);
   reg_mac(defparm_s, me_def_variable);
diff --git a/lisplib.c b/lisplib.c
index 713bb480..d1f237c4 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -446,6 +446,22 @@ static val getput_instantiate(val set_fun)
   return nil;
 }
 
+static val tagbody_set_entries(val dlt, val fun)
+{
+  val name[] = {
+    lit("tagbody"), lit("go"), nil
+  };
+  set_dlt_entries(dlt, name, fun);
+  return nil;
+}
+
+static val tagbody_instantiate(val set_fun)
+{
+  funcall1(set_fun, nil);
+  load(format(nil, lit("~atagbody.tl"), stdlib_path, nao));
+  return nil;
+}
+
 val dlt_register(val dlt,
                  val (*instantiate)(val),
                  val (*set_entries)(val, val))
@@ -481,6 +497,7 @@ void lisplib_init(void)
   dlt_register(dl_table, getopts_instantiate, getopts_set_entries);
   dlt_register(dl_table, package_instantiate, package_set_entries);
   dlt_register(dl_table, getput_instantiate, getput_set_entries);
+  dlt_register(dl_table, tagbody_instantiate, tagbody_set_entries);
 }
 
 val lisplib_try_load(val sym)
diff --git a/share/txr/stdlib/tagbody.tl b/share/txr/stdlib/tagbody.tl
new file mode 100644
index 00000000..7cfcd3f1
--- /dev/null
+++ b/share/txr/stdlib/tagbody.tl
@@ -0,0 +1,75 @@
+;; Copyright 2016
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice, this
+;;    list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;;    this list of conditions and the following disclaimer in the documentation
+;;    and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(defmacro tagbody (:env env . forms)
+  (when forms
+    (let* ((tb-id (gensym "tb-id-"))
+           (next-var (gensym "next-"))
+           (bblocks [partition forms (op where [orf symbolp integerp chrp])])
+           (start-lbl (and (car bblocks) [[orf symbolp integerp chrp] (caar bblocks)]))
+           (entry-lbl (if start-lbl (caar bblocks) (gensym "entry-"))))
+      (unless start-lbl
+        (push entry-lbl (car bblocks)))
+      (let* ((lbls [mapcar car bblocks])
+             (forms [mapcar cdr bblocks])
+             ;; This trickery transform the individually labeled form
+             ;; blocks into branches, such that each branch falls through
+             ;; to the next one thanks to substructure sharing.
+             (threaded-1 (mapcar (op member-if true) (conses forms)))
+             (threaded-2 [apply nconc forms]) ;; important side effect
+             (codes [mapcar car threaded-1]))
+        (unless (eql (length (uniq lbls)) (length lbls))
+          (throwf 'eval-error "~s: duplicate labels occur" 'tagbody))
+        (let* ((basic-code ^(let ((,tb-id (gensym "tb-dyn-id-")))
+                              (for ((,next-var 0))
+                                   (,next-var)
+                                   ((set ,next-var
+                                         (block* ,tb-id
+                                           (sys:switch ,next-var #(,*codes))
+                                           nil))))))
+               ;; pass one: expand inner forms, including tagbody forms.
+               ;; if any inner tagbody forms leave (go ...) forms unexpanded,
+               ;; protect those (go ...)forms from falling victim to the
+               ;; global macro, by wrapping this with a harmless local go macro.
+               (pass-one (sys:expand ^(macrolet ((go (:form form label) form))
+                                        ,basic-code)) env))
+          ;; pass two: now expand the remaining go forms at this level, against
+          ;; this tagbody. If any go forms remain, they must refer to nonexistent
+          ;; labels. By calling sys:expand one more time, we flush these out
+          ;; using the global go macro --- unless we are nested inside the
+          ;; pass-one expansion of outer tagbody, which protects them!
+          ;; Thus, the outermost tagbody flushes out the undefined labels.
+          (sys:expand ^(macrolet ((go (:form form label)
+                                      (let ((index (posql label ',lbls)))
+                                        (cond
+                                          ((null index) form)
+                                          (t ^(return* ,',tb-id ,index))))))
+                         ,pass-one) env))))))
+
+(defmacro go (label)
+  (if [[orf symbolp integerp chrp] label]
+    (throwf 'eval-error "~s: no ~s label visible" 'go label)
+    (throwf 'eval-error "~s: ~s isn't a symbol, integer or character" 'go label)))
diff --git a/txr.1 b/txr.1
index 48dd0c87..e17536cc 100644
--- a/txr.1
+++ b/txr.1
@@ -14546,6 +14546,172 @@ arguments to
 which do not simply quote a symbol have no equivalent in
 .codn return-from .
 
+.coNP Macros @ tagbody and @ go
+.synb
+.mets (tagbody >> { form | << label }*)
+.mets (go << label )
+.syne
+.desc
+The
+.code tagbody
+macro provides a form of the "go to" control construct. The arguments of a
+.code tagbody
+form are a mixture of zero or more forms and
+.IR "go labels" .
+The latter consist of those arguments which are symbols, integers or
+characters.  Labels are not considered by
+.code tagbody
+and
+.code go
+to be forms, and are not subject to macro expansion or evaluation.
+
+The
+.code go
+macro is available inside
+.codn tagbody .
+It is erroneous for a
+.code go
+form to occurs outside of a
+.codn tagbody .
+This situation is diagnosed by global macro called
+.codn go ,
+which unconditionally throws an error.
+
+In the absence of invocations of
+.code go
+or other control transfers, the
+.code tagbody
+macro evaluates each
+.meta form
+in left to right order. The go labels are ignored.
+After the last
+.meta form
+is evaluated, the
+.code tagbody
+form terminates, and yields
+.codn nil .
+
+Any
+.meta form
+itself, or else one of its sub-forms, may be the form
+.cblk
+.meti (go << label )
+.cble
+where
+.meta label
+matches one of the go labels of a surrounding
+.codn tagbody .
+When this
+.code go
+form is evaluated, then the evaluation of
+.meta form
+is immediately abandoned, and control transfers to the specified
+label. The forms are then evaluated in left-to-right order starting
+with the form immediately after that label. If the label is not
+followed by any forms, then the
+.code tagbody
+terminates. If
+.meta label
+doesn't match to any label in any surrounding
+.codn tagbody ,
+the
+.code go
+form is erroneous.
+
+The abandonment of a
+.meta form
+by invocation of
+.code go
+is a dynamic transfer. All necessary unwinding inside
+.meta form
+takes place.
+
+The go labels are lexically scoped, but dynamically bound. Their scope
+being lexical means that the labels are not visible to forms which are not
+enclosed within the
+.codn tagbody ,
+even if their evaluation is invoked from that
+.codn tagbody .
+The dynamic binding means that the labels of a
+.code tagbody
+form are established when it begins evaluating, and removed when
+that form terminates. Once a label is removed, it is not available
+to be the target of a
+.code go
+control transfer, even if that
+.code go
+form has the label in its lexical scope. Such an attempted transfer
+is erroneous.
+
+It is permitted for
+.code tagbody
+forms to nest arbitrarily. The labels of an inner
+.code tagbody
+are not visible to an outer
+.codn tagbody .
+However, the reverse is true: a
+.code go
+form in an inner
+.code tagbody
+may branch to a label in an outer
+.codn tagbody ,
+in which case the entire inner
+.code tagbody
+terminates.
+
+In cases where the same objects are used as labels
+by an inner and outer
+.codn tagbody ,
+the inner labels shadow the outer labels.
+
+.TP* "Dialect Note:"
+
+ANSI Common Lisp
+.code tagbody
+supports only symbols and integers as labels (which are called "go tags");
+characters are not supported.
+
+.TP* Examples:
+.cblk
+  ;; print the numbers 1 to 10
+  (let ((i 0))
+    (tagbody
+      (go skip) ;; forward goto skips 0
+     again
+      (prinl i)
+     skip
+      (when (<= (inc i) 10)
+        (go again))))
+
+  ;; Example of erroneous usage: by the time func is invoked
+  ;; by (call func) the tagbody has already terminated. The
+  ;; lambda body can still "see" the label, but it doesn't
+  ;; have a binding.
+  (let (func)
+    (tagbody
+      (set func (lambda () (go label)))
+      (go out)
+     label
+      (prinl 'never-reached)
+      out)
+    (call func))
+
+  ;; Example of unwinding when the unwind-protect
+  ;; form is abandoned by (go out). Output is:
+  ;;   reached
+  ;;   cleanup
+  ;;   out
+  (tagbody
+     (unwind-protect
+       (progn
+         (prinl 'reached)
+         (go out)
+         (prinl 'notreached))
+       (prinl 'cleanup))
+   out
+     (prinl 'out))
+.cble
+
 .SS* Evaluation
 
 .coNP Function @ eval