diff options
| -rw-r--r-- | stdlib/comp-opts.tl | 51 | ||||
| -rw-r--r-- | stdlib/compiler.tl | 40 | ||||
| -rw-r--r-- | stdlib/optimize.tl | 17 | ||||
| -rw-r--r-- | tests/012/seq.tl | 4 | ||||
| -rw-r--r-- | txr.1 | 10 |
5 files changed, 83 insertions, 39 deletions
diff --git a/stdlib/comp-opts.tl b/stdlib/comp-opts.tl new file mode 100644 index 00000000..9d4dd050 --- /dev/null +++ b/stdlib/comp-opts.tl @@ -0,0 +1,51 @@ +;; Copyright 2017-2024 +;; 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. + +(defstruct usr:compile-opts () + usr:shadow-fun + usr:shadow-var + usr:shadow-cross + usr:unused + usr:constant-throws + usr:log-level) + +(defsymacro %warning-syms% '(shadow-fun shadow-var shadow-cross + unused log-level constant-throws)) + +(defvar usr:*compile-opts* (new compile-opts unused t constant-throws t)) + +(defmacro when-opt (compile-opt . forms) + (with-gensyms (optval) + ^(whenlet ((,optval usr:*compile-opts*.,compile-opt)) + (macrolet ((diag (. args) + ^(opt-controlled-diag ,',optval ,*args))) + ,*forms)))) + +(defun opt-controlled-diag (optval . args) + (caseq optval + (:error (compile-error . args)) + ((t :warn) (compile-warning . args)))) diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl index 92c00770..3585971a 100644 --- a/stdlib/compiler.tl +++ b/stdlib/compiler.tl @@ -30,31 +30,9 @@ (load-for (usr:var %const-foldable% "constfun")) (compile-only - (load-for (struct sys:param-parser-base "param"))) - -(defstruct usr:compile-opts () - usr:shadow-fun - usr:shadow-var - usr:shadow-cross - usr:unused - usr:log-level) - -(defsymacro %warning-syms% '(usr:shadow-fun usr:shadow-var usr:shadow-cross - usr:unused usr:log-level)) - -(defvar usr:*compile-opts* (new compile-opts usr:unused t)) - -(defmacro when-opt (compile-opt . forms) - (with-gensyms (optval) - ^(whenlet ((,optval *compile-opts*.,compile-opt)) - (macrolet ((diag (. args) - ^(opt-controlled-diag ,',optval ,*args))) - ,*forms)))) - -(defun opt-controlled-diag (optval . args) - (caseq optval - (:error (compile-error . args)) - ((t :warn) (compile-warning . args)))) + (load-for + (struct sys:param-parser-base "param") + (macro when-opt "comp-opts"))) (defstruct (frag oreg code : fvars ffuns pars) nil oreg @@ -2386,11 +2364,13 @@ (when ece.throws (del [%eval-cache% form]) (let ((of ece.orig-form)) - (when (or (source-loc of) - (and (consp of) - (neq system-package (symbol-package (car of))))) - (compile-warning ece.orig-form - "constant expression ~s throws" ece.orig-form)))))) + (when-opt constant-throws + (when (or (source-loc of) + (and (consp of) + (neq system-package (symbol-package (car of))))) + (unless *compile-opts*.usr:constant-throws + (diag ece.orig-form "constant expression ~s throws" + ece.orig-form)))))))) (defun system-symbol-p (sym) (member (symbol-package sym) diff --git a/stdlib/optimize.tl b/stdlib/optimize.tl index dd43de68..52e5504c 100644 --- a/stdlib/optimize.tl +++ b/stdlib/optimize.tl @@ -25,7 +25,9 @@ ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ;; POSSIBILITY OF SUCH DAMAGE. -(load-for (usr:var %const-foldable% "constfun")) +(load-for + (usr:var %const-foldable% "constfun") + (usr:macro when-opt "comp-opts")) (compile-only (defstruct live-info nil @@ -555,12 +557,13 @@ (apply fun (append [args 0..-1] [args -1]))) (error (#:x) err)))) - (when (and (eq val err) - (not (member insn bb.warned-insns))) - (compile-warning co.top-form - "function ~s with arguments ~s throws" - fun args) - (push insn bb.warned-insns)) + (when-opt usr:constant-throws + (when (and (eq val err) + (not (member insn bb.warned-insns))) + (diag co.top-form + "function ~s with arguments ~s throws" + fun args) + (push insn bb.warned-insns))) val)) (neq val err))) (let* ((dreg bb.compiler.(get-dreg val))) diff --git a/tests/012/seq.tl b/tests/012/seq.tl index c48296bd..262c7739 100644 --- a/tests/012/seq.tl +++ b/tests/012/seq.tl @@ -826,9 +826,11 @@ [apply mapcar join (list-seq "aaa".."zzz")] (transpose (list-seq "aaa".."zzz"))) +(eval-only (set *compile-opts*.constant-throws nil)) + (mtest (ref "a".."z" 0) :error - (ref (rcons 'foo 'bar)) :error) + (ref (rcons 'foo 'bar) 0) :error) (mtest (ref 1..6 0) 1 @@ -91362,7 +91362,8 @@ and not to propagate compiled versions of the macros which produced it. .coNP Structure @ compile-opts .synb .mets (defstruct compile-opts () -.mets \ \ shadow-fun shadow-var shadow-cross unused log-level) +.mets \ \ shadow-fun shadow-var shadow-cross unused +.mets \ \ log-level constant-throws) .syne .desc The @@ -91461,6 +91462,13 @@ to emit an informational message whenever a file is compiled. The value 2 causes informational messages emitted for each compound top-level that is compiled, if it is a compound form beginning with a symbol. +.coIP constant-throws +Diagnostic option, +.code t +by default. Controls whether the compiler issues diagnostics when +it encounters a constant expression, whose evaluation throws +an exception, such as +.codn "(/ 0 0)" . .RE .coNP Special Variable @ *compile-opts* |