Changeset 9848

Timestamp:

Jun 30, 2008, 7:05:03 AM (13 years ago)

Author:

gz

Message:

Make program-errors always cause an immediate error outside of file compilation.

For file compilation, the behavior is now controlled by a new :break-on-program-errors
argument to compile-file, defaulting from ccl::*fasl-break-on-program-errors*:

(defvar *fasl-break-on-program-errors* #+ccl-0711 nil #-ccl-0711 :defer

"Controls what happens when the compiler detects PROGRAM-ERROR's during file compilation.

If T, the compiler signals an error immediately when it detects the program-error.

If :DEFER, program errors are reported as compiler warnings, and in addition, an error

is signalled at the end of file compilation. This allows all warnings for the file
to be reported, but prevents the creation of a fasl file.

If NIL, program errors are treated the same as any other error condition detected by

the compiler, i.e. they are reported as compiler warnings and do not cause any
error to be signalled at compile time.")

Location:

trunk/source

Files:

• compiler/nx0.lisp (modified) (2 diffs)
• level-1/sysutils.lisp (modified) (1 diff)
• lib/nfcomp.lisp (modified) (7 diffs)

trunk/source/compiler/nx0.lisp

@@ -51 +51 @@
 (defparameter *nx-hoist-declarations* t)
 (defparameter *nx-loop-nesting-level* 0)
+(defvar *nx-break-on-program-errors* t)
 
 (defvar *nx1-vcells* nil)
@@ -1325 +1326 @@
           (setf (afunc-acode p) (nx1-lambda '(&rest args) `(args ,(runtime-program-error-form c)) nil)))
       (handler-bind ((warning (lambda (c)
-                                (nx1-whine :program-error c)
-                                (muffle-warning c)))
-                     (program-error (lambda (c)
-                                      (when (typep c 'compile-time-program-error)
-                                        (setq c (make-condition 'simple-program-error
-                                                  :format-control (simple-condition-format-control c)
-                                                  :format-arguments (simple-condition-format-arguments c))))
-                                      (nx1-whine :program-error c)
-                                      (throw 'program-error-handler c))))
+                                (nx1-whine :program-error c)
+                                (muffle-warning c)))
+                     (program-error (lambda (c)
+                                      (when *nx-break-on-program-errors*
+                                        (cerror "continue compilation ignoring this form" c))
+                                      (when (typep c 'compile-time-program-error)
+                                        (setq c (make-condition 'simple-program-error
+                                                                :format-control (simple-condition-format-control c)
+                                                                :format-arguments (simple-condition-format-arguments c))))
+                                      (unless *nx-break-on-program-errors*
+                                        (nx1-whine :program-error c))
+                                      (throw 'program-error-handler c))))
         (multiple-value-bind (body decls)
             (with-program-error-handler (lambda (c) (runtime-program-error-form c))

trunk/source/level-1/sysutils.lisp

@@ -625 +625 @@
     (unless muffled
       (setq any-p t)
-      (unless (typep w 'style-warning) (setq harsh-p t))
+      (unless (typep w 'style-warning)
+        (unless (eq harsh-p :very)
+          (setq harsh-p t)
+          (when (and (typep w 'compiler-warning)
+                     (eq (compiler-warning-warning-type w) :program-error)
+                     (typep (car (compiler-warning-args w)) 'error))
+            (setq harsh-p :very))))
       (when (or init-p (not (equalp w-file last-w-file)))
         (format s "~&;~A warnings " (if (null eval-p) "Compiler" "Interpreter"))

trunk/source/lib/nfcomp.lisp

@@ -67 +67 @@
 (defvar *fcomp-external-format* :default)
 
+(defvar *fasl-break-on-program-errors* #+ccl-0711 nil #-ccl-0711 :defer
+  "Controls what happens when the compiler detects PROGRAM-ERROR's during file compilation.
+
+  If T, the compiler signals an error immediately when it detects the program-error.
+
+  If :DEFER, program errors are reported as compiler warnings, and in addition, an error
+    is signalled at the end of file compilation.  This allows all warnings for the file
+    to be reported, but prevents the creation of a fasl file.
+
+  If NIL, program errors are treated the same as any other error condition detected by
+   the compiler, i.e. they are reported as compiler warnings and do not cause any
+   error to be signalled at compile time.")
+  
+
 (defvar *compile-print* nil ; Might wind up getting called *compile-FILE-print*
   "The default for the :PRINT argument to COMPILE-FILE.")
@@ -110 +124 @@
                          (save-doc-strings *fasl-save-doc-strings*)
                          (save-definitions *fasl-save-definitions*)
-                         (external-format :default)
+                         (break-on-program-errors *fasl-break-on-program-errors*)
+                         (external-format :default)
                          force)
   "Compile INPUT-FILE, producing a corresponding fasl file and returning
@@ -121 +136 @@
         (restart-case
          (return (%compile-file src output-file verbose print load features
-                                save-local-symbols save-doc-strings save-definitions force backend external-format))
+                                save-local-symbols save-doc-strings save-definitions
+                                break-on-program-errors
+                                force backend external-format))
          (retry-compile-file ()
                              :report (lambda (stream) (format stream "Retry compiling ~s" src))
@@ -131 +148 @@
 
 (defun %compile-file (src output-file verbose print load features
-                          save-local-symbols save-doc-strings save-definitions force target-backend external-format
+                          save-local-symbols save-doc-strings save-definitions
+                          break-on-program-errors
+                          force target-backend external-format
                           &aux orig-src)
 
@@ -166 +185 @@
              (*fasl-save-doc-strings* save-doc-strings)
              (*fasl-save-definitions* save-definitions)
+             (*fasl-break-on-program-errors* break-on-program-errors)
              (*fcomp-warnings-header* nil)
              (*compile-file-pathname* orig-src)
@@ -192 +212 @@
             (multiple-value-bind (any harsh) (report-deferred-warnings)
               (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any)
-                    *fasl-non-style-warnings-signalled-p* (or *fasl-non-style-warnings-signalled-p* harsh))))
+                    *fasl-non-style-warnings-signalled-p* (if (eq harsh :very) :very
+                                                              (or *fasl-non-style-warnings-signalled-p* harsh)))))
+          (when (and *fasl-break-on-program-errors* (eq *fasl-non-style-warnings-signalled-p* :very))
+            (cerror "create the output file despite the errors"
+                    "Serious errors encountered during compilation of ~s"
+                    src))
           (fasl-scan-forms-and-dump-file forms output-file lexenv)))
       (when load (load output-file :verbose (or verbose *load-verbose*)))
       (values (truename (pathname output-file)) 
               *fasl-warnings-signalled-p* 
-              *fasl-non-style-warnings-signalled-p*))))
+              (and *fasl-non-style-warnings-signalled-p* t)))))
 
 (defvar *fcomp-locked-hash-tables*)
@@ -839 +864 @@
 ;;; making an lfun, but it's simpler this way...
 (defun fcomp-named-function (def name env)
-  (let* ((env (new-lexical-environment env)))
+  (let* ((env (new-lexical-environment env))
+         (*nx-break-on-program-errors* (not (memq *fasl-break-on-program-errors* '(nil :defer)))))
     (multiple-value-bind (lfun warnings)
                          (compile-named-function