diff options
| -rw-r--r-- | eval.c | 48 | ||||
| -rw-r--r-- | lisplib.c | 17 | ||||
| -rw-r--r-- | share/txr/stdlib/tagbody.tl | 75 | ||||
| -rw-r--r-- | txr.1 | 166 |
4 files changed, 305 insertions, 1 deletions
@@ -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); @@ -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))) @@ -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 |