diff options
| -rw-r--r-- | eval.c | 46 | ||||
| -rw-r--r-- | lisplib.c | 18 | ||||
| -rw-r--r-- | stdlib/compiler.tl | 38 | ||||
| -rw-r--r-- | stdlib/constfun.tl | 63 | ||||
| -rw-r--r-- | txr.1 | 49 |
5 files changed, 158 insertions, 56 deletions
@@ -104,6 +104,7 @@ val fbind_s, lbind_s, flet_s, labels_s; val load_path_s, load_recursive_s; val load_time_s, load_time_lit_s; val eval_only_s, compile_only_s; +val const_foldable_s; val special_s, unbound_s; val whole_k, form_k, symacro_k; @@ -115,6 +116,8 @@ val iter_item_f, iter_step_f; val origin_hash; +static val const_foldable_hash; + val make_env(val vbindings, val fbindings, val up_env) { val env = make_obj(); @@ -5277,7 +5280,27 @@ static val macroexpand_lisp1(val form, val menv) static val constantp_noex(val form) { if (consp(form)) { - return eq(car(form), quote_s); + val sym = car(form); + val args = cdr(form); + if (eq(sym, quote_s)) + return t; + if (!proper_list_p(args)) + return nil; + if (eq(sym, dwim_s)) { + sym = us_car(args); + args = us_cdr(args); + } + if (!symbolp(sym)) + return nil; + if (!const_foldable_hash) + const_foldable_hash = cdr(lookup_var(nil, const_foldable_s)); + if (!gethash(const_foldable_hash, sym)) + return nil; + for (; args; args = us_cdr(args)) { + if (!constantp_noex(us_car(args))) + return nil; + } + return t; } else { if (bindable(form)) return nil; @@ -5290,21 +5313,15 @@ static val constantp(val form, val env_in) val env = default_null_arg(env_in); if (consp(form)) { - if (car(form) == quote_s) { + if (car(form) == quote_s) return t; - } else if (macro_form_p(form, env)) { - return constantp_noex(macroexpand(form, env)); - } else { - return nil; - } + else + return constantp_noex(no_warn_expand(form, env)); } else if (symbolp(form)) { - if (!bindable(form)) { + if (!bindable(form)) return t; - } else if (macro_form_p(form, env)) { - return constantp_noex(macroexpand(form, env)); - } else { - return nil; - } + else + return constantp_noex(no_warn_expand(form, env)); } else { return t; } @@ -6421,7 +6438,7 @@ void eval_init(void) &op_table, &pm_table, &last_form_evaled, &call_f, &iter_begin_f, &iter_from_binding_f, &iter_more_f, &iter_item_f, &iter_step_f, - &unbound_s, &origin_hash, convert(val *, 0)); + &unbound_s, &origin_hash, &const_foldable_hash, convert(val *, 0)); top_fb = make_hash(t, nil, nil); top_vb = make_hash(t, nil, nil); top_mb = make_hash(t, nil, nil); @@ -6561,6 +6578,7 @@ void eval_init(void) load_time_lit_s = intern(lit("load-time-lit"), system_package); eval_only_s = intern(lit("eval-only"), user_package); compile_only_s = intern(lit("compile-only"), user_package); + const_foldable_s = intern(lit("%const-foldable%"), system_package); qquote_init(); @@ -936,6 +936,23 @@ static val pic_set_entries(val dlt, val fun) return nil; } +static val constfun_instantiate(val set_fun) +{ + funcall1(set_fun, nil); + load(scat2(stdlib_path, lit("constfun"))); + return nil; +} + +static val constfun_set_entries(val dlt, val fun) +{ + val sys_name[] = { + lit("%const-foldable%"), + nil + }; + set_dlt_entries_sys(dlt, sys_name, fun); + return nil; +} + val dlt_register(val dlt, val (*instantiate)(val), val (*set_entries)(val, val)) @@ -993,6 +1010,7 @@ void lisplib_init(void) dlt_register(dl_table, match_instantiate, match_set_entries); dlt_register(dl_table, doc_instantiate, doc_set_entries); dlt_register(dl_table, pic_instantiate, pic_set_entries); + dlt_register(dl_table, constfun_instantiate, constfun_set_entries); reg_fun(intern(lit("try-load"), system_package), func_n1(lisplib_try_load)); } diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl index c30ebbd6..05ed2a80 100644 --- a/stdlib/compiler.tl +++ b/stdlib/compiler.tl @@ -26,6 +26,7 @@ (load "vm-param") (load "optimize") +(load-for (usr:var %const-foldable% "constfun")) (compile-only (load-for (struct sys:param-parser-base "param"))) @@ -265,43 +266,6 @@ (defvarl %bin-op% (relate %nary-ops% %bin-ops% nil)) -(defvarl %const-foldable-funs% - '(+ - * / sum prod abs trunc mod zerop nzerop plusp minusp evenp oddp - > < >= <= = /= wrap wrap* expt exptmod isqrt square gcd lcm floor ceil - round trunc-rem floor-rem ceil-rem round-rem sin cos tan asin acos atan - atan2 sinh cosh tanh asinh acosh atanh log log10 log2 exp sqrt - logand logior logxor logtest lognot logtrunc sign-extend ash bit mask - width logcount bitset cum-norm-dist inv-cum-norm n-choose-k n-perm-k - fixnump bignump floatp integerp numberp signum bignum-len divides sys:bits - digpow digits poly rpoly b< b> b<= b=> b= b+ b- b* b/ neg - pred ppred ppred pppred succ ssucc ssucc sssucc - car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr - cdadar cdaddr cddaar cddadr cdddar cddddr caaaaar caaaadr caaadar caaaddr - caadaar caadadr caaddar caadddr cadaaar cadaadr cadadar cadaddr caddaar - caddadr cadddar caddddr cdaaaar cdaaadr cdaadar cdaaddr cdadaar cdadadr - cdaddar cdadddr cddaaar cddaadr cddadar cddaddr cdddaar cdddadr cddddar - cdddddr cons first rest sub-list identity typeof atom null false true have - consp listp endp proper-listp length-list second third fourth fifth - sixth seventh eighth ninth tenth conses ldiff nthcdr nth tailp - memq memql memqual rmemq rmemql rmemqual countq countql countqual - posq posql posqual rposq rposql rposqual eq eql equal meq meql mequal - neq neql nequal max min clamp bracket take drop uniq if or and progn - prog1 prog2 nilf tf tostring tostringp display-width sys:fmt-simple - sys:fmt-flex join join-with sys:fmt-join packagep - symbolp keywordp bindable stringp length-str - coded-length cmp-str string-lt str= str< str> str<= str>= int-str - flo-str num-str int-flo flo-int tofloat toint tointz less greater - lequal gequal chrp chr-isalnum chr-isalnum chr-isalpha chr-isascii - chr-iscntrl chr-isdigit chr-digit chr-isgraph chr-islower chr-isprint - chr-ispunct chr-isspace chr-isblank chr-isunisp chr-isupper chr-isxdigit - chr-xdigit chr-toupper chr-tolower num-chr int-chr chr-num chr-int - chr-str span-str compl-span-str break-str vectorp length-vec size-vec - assq assql assoc rassq rassql rassoc prop memp length len empty ref - rangep from to in-range in-range* nullify)) - -(defvarl %const-foldable% (hash-list %const-foldable-funs% :eq-based)) - (defvarl %effect-free-funs% '(append append* revappend list list* zip interpose copy-list reverse flatten flatten* flatcar flatcar* tuples remq remql remqual diff --git a/stdlib/constfun.tl b/stdlib/constfun.tl new file mode 100644 index 00000000..76bc0621 --- /dev/null +++ b/stdlib/constfun.tl @@ -0,0 +1,63 @@ +;; Copyright 2021 +;; 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. + + +(defvarl %const-foldable-funs% + '(+ - * / sum prod abs trunc mod zerop nzerop plusp minusp evenp oddp + > < >= <= = /= wrap wrap* expt exptmod isqrt square gcd lcm floor ceil + round trunc-rem floor-rem ceil-rem round-rem sin cos tan asin acos atan + atan2 sinh cosh tanh asinh acosh atanh log log10 log2 exp sqrt + logand logior logxor logtest lognot logtrunc sign-extend ash bit mask + width logcount bitset cum-norm-dist inv-cum-norm n-choose-k n-perm-k + fixnump bignump floatp integerp numberp signum bignum-len divides sys:bits + digpow digits poly rpoly b< b> b<= b=> b= b+ b- b* b/ neg + pred ppred ppred pppred succ ssucc ssucc sssucc + car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr + cdadar cdaddr cddaar cddadr cdddar cddddr caaaaar caaaadr caaadar caaaddr + caadaar caadadr caaddar caadddr cadaaar cadaadr cadadar cadaddr caddaar + caddadr cadddar caddddr cdaaaar cdaaadr cdaadar cdaaddr cdadaar cdadadr + cdaddar cdadddr cddaaar cddaadr cddadar cddaddr cdddaar cdddadr cddddar + cdddddr cons first rest sub-list identity typeof atom null false true have + consp listp endp proper-listp length-list second third fourth fifth + sixth seventh eighth ninth tenth conses ldiff nthcdr nth tailp + memq memql memqual rmemq rmemql rmemqual countq countql countqual + posq posql posqual rposq rposql rposqual eq eql equal meq meql mequal + neq neql nequal max min clamp bracket take drop uniq if or and progn + prog1 prog2 nilf tf tostring tostringp display-width sys:fmt-simple + sys:fmt-flex join join-with sys:fmt-join packagep + symbolp keywordp bindable stringp length-str + coded-length cmp-str string-lt str= str< str> str<= str>= int-str + flo-str num-str int-flo flo-int tofloat toint tointz less greater + lequal gequal chrp chr-isalnum chr-isalnum chr-isalpha chr-isascii + chr-iscntrl chr-isdigit chr-digit chr-isgraph chr-islower chr-isprint + chr-ispunct chr-isspace chr-isblank chr-isunisp chr-isupper chr-isxdigit + chr-xdigit chr-toupper chr-tolower num-chr int-chr chr-num chr-int + chr-str span-str compl-span-str break-str vectorp length-vec size-vec + assq assql assoc rassq rassql rassoc prop memp length len empty ref + rangep from to in-range in-range* nullify)) + +(defvarl %const-foldable% (hash-list %const-foldable-funs% :eq-based)) @@ -18139,8 +18139,9 @@ If is absent, the global environment is used. The .meta env -argument is used for macro-expanding -.metn form . +argument is used for fully expanding +.meta form +prior to analyzing. Currently, .code constantp @@ -18154,10 +18155,48 @@ These symbols are the keyword symbols, and the symbols and .codn nil . -In the future, +Additionally, +.code constantp +returns true for a compound form, or a DWIM form, whose symbol is +the member of a set a large number of constant-foldable library functions, +and whose arguments are, recursively, +.code constantp +expressions for the same environment. The arithmetic functions +are members of this set. + +For all other inputs, +.code constantp +returns +.codn nil . + +Note: some uses of .code constantp -will be able to recognize more constant forms, such as calls to certain -functions whose arguments are constant forms. +require manual expansion. + +.TP* Examples: + +.verb + (constantp nil) -> t + (constantp t) -> t + (constantp :key) -> t + (constantp :) -> t + (constantp 'a) -> nil + (constantp 42) -> t + + (constantp '(+ 2 2 [* 3 (/ 4 4)]) -> t + + ;; symacrolet form expands to 42, which is constant + (constantp '(symacrolet ((a 42)) a)) + + (defmacro cp (:env e arg) + (constantp arg e)) + + ;; macro call (cp 'a) is replaced by t because + ;; the symbol a expands to (+ 2 2) in the given environment, + ;; and so (* a a) expands to (* (+ 2 2) (+ 2 2)) which is constantp. + (symacrolet ((a (+ 2 2))) + (cp '(* a a))) -> t +.brev .coNP Function @ make-env .synb |