tests: suppress warnings in seq.tl.

When tests/012/compile.tl compiles tests/012/seq.tl, there
are now some compiler warnings due to constant expressions
that throw. We introduce a new compiler option to suppress
them, and then use it.

* stdlib/comp-opts.tl: New file. The definitions related
to compiler options are moved here out of compile.tl,
so that optimize.tl can use them.

* stdlib/compiler.tl (compile-opts, %warning-syms%,
when-opt, *compile-opts*, opt-controlled-diag): Moved to
comp-opts.tl. New constant-throws option added to
compile-opts and %warning-syms%.
(safe-constantp): Make the constant expression throws
diagnostic conditional on the new option.

* stdlib/optimize.tl: Load comp-opts file.
(basic-blocks do-peephole-block): Make diagnostic
about throwing situation subject to constant-throws
option.

* tests/012/seq.tl: Turn off constant-throws warning
option before the ref tests that work with ranges.
Fix: one of the expressions calls refs with the
wrong number of arguments, which was unintentional.

* txr.1: Document new diagnostic option.

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
diff --git a/txr.1 b/txr.1
index 25ae880a..5f5dc636 100644
--- a/txr.1
+++ b/txr.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*