diff options
| -rw-r--r-- | eval.c | 13 | ||||
| -rw-r--r-- | lisplib.c | 21 | ||||
| -rw-r--r-- | share/txr/stdlib/op.tl | 94 | ||||
| -rw-r--r-- | txr.1 | 57 |
4 files changed, 157 insertions, 28 deletions
@@ -3400,6 +3400,10 @@ val expand_quasi(val quasi_forms, val menv) if (consp(form)) { val sym = car(form); + int comp_184 = opt_compat && opt_compat <= 184; + + if (!comp_184) + form_ex = expand(form, menv); if (sym == var_s) { val param = second(form); @@ -3410,7 +3414,8 @@ val expand_quasi(val quasi_forms, val menv) if (param_ex != param || mods_ex != mods) form_ex = rlcp(list(sym, param_ex, mods_ex, nao), form); } else { - form_ex = expand(form, menv); + if (comp_184) + form_ex = expand(form, menv); } } @@ -5677,8 +5682,10 @@ void eval_init(void) reg_mac(gen_s, func_n2(me_gen)); reg_mac(gun_s, func_n2(me_gun)); reg_mac(intern(lit("delay"), user_package), func_n2(me_delay)); - reg_mac(op_s, func_n2(me_op)); - reg_mac(do_s, func_n2(me_op)); + if (opt_compat && opt_compat <= 184) { + reg_mac(op_s, func_n2(me_op)); + reg_mac(do_s, func_n2(me_op)); + } reg_mac(ap_s, func_n2(me_ap)); reg_mac(intern(lit("ip"), user_package), func_n2(me_ip)); reg_mac(intern(lit("ado"), user_package), func_n2(me_ado)); @@ -560,6 +560,23 @@ static val doloop_instantiate(val set_fun) return nil; } +static val op_set_entries(val dlt, val fun) +{ + val name[] = { + lit("op"), lit("do"), + nil + }; + set_dlt_entries(dlt, name, fun); + return nil; +} + +static val op_instantiate(val set_fun) +{ + funcall1(set_fun, nil); + load(format(nil, lit("~aop.tl"), stdlib_path, nao)); + return nil; +} + val dlt_register(val dlt, val (*instantiate)(val), val (*set_entries)(val, val)) @@ -601,6 +618,10 @@ void lisplib_init(void) dlt_register(dl_table, keyparams_instantiate, keyparams_set_entries); dlt_register(dl_table, ffi_instantiate, ffi_set_entries); dlt_register(dl_table, doloop_instantiate, doloop_set_entries); + + if (!opt_compat || opt_compat >= 185) + dlt_register(dl_table, op_instantiate, op_set_entries); + reg_fun(intern(lit("try-load"), system_package), func_n1(lisplib_try_load)); } diff --git a/share/txr/stdlib/op.tl b/share/txr/stdlib/op.tl new file mode 100644 index 00000000..78658658 --- /dev/null +++ b/share/txr/stdlib/op.tl @@ -0,0 +1,94 @@ +;; Copyright 2017 +;; 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. + +(sys:make-struct-type + 'sys:op-ctx nil nil '(form gens up meta) nil + (lambda (me) + (slotset me 'up sys:*op-ctx*) + (slotset me 'meta (gensym "meta-"))) + nil nil) + +(defvar sys:*op-ctx*) + +(defun sys:ensure-op-arg (ctx n) + (let ((ag (slot ctx 'gens))) + (when (> n 1024) + ['compile-error (slot ctx 'form) + "@~a calls for function with too many arguments" n]) + (for ((i (len ag)) (l)) + ((<= i n) + (sys:setq ag (append ag (nreverse l))) + (slotset ctx 'gens ag) + [ag n]) + ((sys:setq i (succ i))) + (sys:setq l (cons (gensym `arg-@(if (plusp i) i "rest")-`) l))))) + +(defun sys:op-meta-p (expr) + (tree-case expr + ((x y . r) (and (null r) + (cond + ((eq x 'sys:expr) (sys:op-meta-p y)) + ((eq x 'sys:var) (or (integerp y) + (eq y 'rest)))))))) + +(defun sys:op-alpha-rename (f e op-args do-nested-metas) + (let* ((ctx sys:*op-ctx*) + (code ^(macrolet ((sys:expr (:form f arg) + (let ((ctx ,ctx)) + (if (and (slot ctx 'up) (sys:op-meta-p arg)) + ^(,(slot (slot ctx 'up) 'meta) (quote ,arg)) + f))) + (sys:var (:form f arg . mods) + (cond + ((and (not mods) (sys:op-meta-p f)) + (unless (integerp arg) + (sys:setq arg 0)) + (sys:ensure-op-arg ,ctx arg)) + (t f))) + ,*(if do-nested-metas + ^((,(slot ctx 'meta) ((quote arg)) arg)))) + ,op-args))) + (sys:expand code e))) + +(defun sys:op-expand (f e args) + (let* ((ctx (make-struct 'sys:op-ctx ^(form ,f))) + (sys:*op-ctx* ctx) + (sym (car f)) + (syntax-0 (if (eq sym 'do) ^(,*args) ^[,*args])) + (syntax-1 (sys:op-alpha-rename f e syntax-0 nil)) + (syntax-2 (sys:op-alpha-rename f e syntax-1 t)) + (have-metas (slot ctx 'gens)) + (rest-sym (sys:ensure-op-arg ctx 0))) + ^(lambda (,*(cdr (slot ctx 'gens)) . ,rest-sym) + ,(if (or have-metas (eq sym 'do)) + syntax-2 + (append syntax-2 rest-sym))))) + +(defmacro op (:form f :env e . args) + (sys:op-expand f e args)) + +(defmacro do (:form f :env e . args) + (sys:op-expand f e args)) @@ -39875,23 +39875,23 @@ can be used in the dot position of a function call, such as: [(op list 1 . @1) 2] -> (1 . 2) .cble -Even though the notation -.code @1 -produces a compound form, which the dot notation then splices into -the surrounding form, the expander for the -.code op -and -.code do -macro takes recognizes and takes care of this special case. +This is a consequence of the special transformations described +in the paragraph +.B "Dot Position in Function Calls" +in the subsection +.B "Additional Syntax" +of the +.BR "TXR Lisp" +section. The .code op -syntax interacts with quasiliterals which are nested within it. +syntax works in conjunction with quasiliterals which are nested within it. The metanumber notation as well as .code @rest are recognized without requiring an additional .code @ -escape: +escape, which is effectively optional: .cblk (apply (op list `@1-@rest`) '(1 2 3)) -> "1-2 3" @@ -39899,29 +39899,19 @@ escape: (apply (op list `@@1-@@rest`) '(1 2 3)) -> "1-2 3" .cble -This is because the -.code op -macro traverses the code structure produced by the literal without recognizing -it specially, and there imposes its own meaning on these elements. - Though they produce the same result, the above two examples differ in that .code @rest embeds a metasymbol into the quasiliteral structure, whereas .code @@rest embeds the Lisp expression .code @rest -into the quasiliteral. - -Under the -.code op -macro and its relatives, occurrences of +into the quasiliteral. Either way, in the scope of +.codn op , .code @rest -are replaced with syntax which refers to the trailing arguments -of the anonymous function. This happens before the interior of the +undergoes the macro-expansion which renames it to the machine-generated +function argument symbol of the implicit function denoted by the .code op -syntax undergoes expansion. Therefore the quasiliteral expander never -sees the -.codn @rest . +macro form. This convenient omission of the .code @ @@ -61276,6 +61266,23 @@ of these version values, the described behaviors are provided if is given an argument which is equal or lower. For instance .code "-C 103" selects the behaviors described below for version 105, but not those for 102. +.IP 184 +A value of 184 or lower switches to the old implementation of the +.code op +and +.code do +macros which was replaced starting in \*(TX 185. Also, this has the +effect of disabling the special recognition of meta-expressions +and meta-variables in the dot position of function calls, and +the macro expansion of meta-variables in quasiliterals. This is +because the old +.code op +implementation implements these behaviors itself. The implication +is that user code which binds custom macros to +.code sys:var +or +.code sys:expr +may be affected by 184 or lower compatibility. .IP 183 A value of 183 or lower restores an inconsistent behavior in the .code "@(bind)" |