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.

1 files changed, 10 insertions, 30 deletions

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)