Don't use the implementation details in WITH-COMPILATION-UNIT

to signal errors. Move around some code to achieve that.
At the same time, switch away from using specials in favor of
variables being closed over.
parent c9066d08
...@@ -270,9 +270,18 @@ ...@@ -270,9 +270,18 @@
(check-lisp-home) (check-lisp-home)
(time (time
(with-compilation-unit () (with-compilation-unit ()
(let ((*compile-file-zip* zip)) (let ((*compile-file-zip* zip)
(%compile-system :output-path output-path)) failure-p)
(when (zerop (+ jvm::*errors* jvm::*warnings*)) (handler-bind (((or warning
(setf status 0)))) compiler-error)
#'(lambda (c)
(declare (ignore c))
(setf failure-p t)
;; only register that we had this type of signal
;; defer the actual handling to another handler
nil)))
(%compile-system :output-path output-path))
(unless failure-p
(setf status 0)))))
(when quit (when quit
(quit :status status)))) (quit :status status))))
...@@ -1002,56 +1002,6 @@ representation, based on the derived type of the LispObject." ...@@ -1002,56 +1002,6 @@ representation, based on the derived type of the LispObject."
(fix-boxing representation nil) (fix-boxing representation nil)
(emit-move-from-stack target representation)) (emit-move-from-stack target representation))
(defvar *style-warnings* nil)
(defvar *warnings* nil)
(defvar *errors* nil)
(defvar *last-error-context* nil)
(defun note-error-context ()
(let ((context *compiler-error-context*))
(when (and context (neq context *last-error-context*))
(fresh-line *error-output*)
(princ "; in " *error-output*)
(let ((*print-length* 2)
(*print-level* 2)
(*print-pretty* nil))
(prin1 context *error-output*))
(terpri *error-output*)
(terpri *error-output*)
(setf *last-error-context* context))))
(defvar *resignal-compiler-warnings* nil) ; bind this to t inside slime compilation
(defun handle-style-warning (condition)
(cond (*resignal-compiler-warnings*
(signal condition))
(t
(unless *suppress-compiler-warnings*
(fresh-line *error-output*)
(note-error-context)
(format *error-output* "; Caught ~A:~%; ~A~2%" (type-of condition) condition))
(incf *style-warnings*)
(muffle-warning))))
(defun handle-warning (condition)
(cond (*resignal-compiler-warnings*
(signal condition))
(t
(unless *suppress-compiler-warnings*
(fresh-line *error-output*)
(note-error-context)
(format *error-output* "; Caught ~A:~%; ~A~2%" (type-of condition) condition))
(incf *warnings*)
(muffle-warning))))
(defun handle-compiler-error (condition)
(fresh-line *error-output*)
(note-error-context)
(format *error-output* "; Caught ERROR:~%; ~A~2%" condition)
(incf *errors*)
(throw 'compile-defun-abort (funcall *compiler-error-bailout*)))
;; "In addition to situations for which the standard specifies that conditions ;; "In addition to situations for which the standard specifies that conditions
;; of type WARNING must or might be signaled, warnings might be signaled in ;; of type WARNING must or might be signaled, warnings might be signaled in
;; situations where the compiler can determine that the consequences are ;; situations where the compiler can determine that the consequences are
...@@ -8697,44 +8647,91 @@ for use with derive-type-times.") ...@@ -8697,44 +8647,91 @@ for use with derive-type-times.")
(defvar *catch-errors* t) (defvar *catch-errors* t)
(defvar *last-error-context* nil)
(defun note-error-context ()
(let ((context *compiler-error-context*))
(when (and context (neq context *last-error-context*))
(fresh-line *error-output*)
(princ "; in " *error-output*)
(let ((*print-length* 2)
(*print-level* 2)
(*print-pretty* nil))
(prin1 context *error-output*))
(terpri *error-output*)
(terpri *error-output*)
(setf *last-error-context* context))))
(defvar *resignal-compiler-warnings* nil
"Bind this to t inside slime compilation")
(defun handle-warning (condition)
(cond (*resignal-compiler-warnings*
(signal condition))
(t
(unless *suppress-compiler-warnings*
(fresh-line *error-output*)
(note-error-context)
(format *error-output* "; Caught ~A:~%; ~A~2%"
(type-of condition) condition))
(muffle-warning))))
(defun handle-compiler-error (condition)
(fresh-line *error-output*)
(note-error-context)
(format *error-output* "; Caught ERROR:~%; ~A~2%" condition)
(throw 'compile-defun-abort (funcall *compiler-error-bailout*)))
(defvar *in-compilation-unit* nil) (defvar *in-compilation-unit* nil)
(defmacro with-compilation-unit (options &body body) (defmacro with-compilation-unit (options &body body)
`(%with-compilation-unit (lambda () ,@body) ,@options)) `(%with-compilation-unit (lambda () ,@body) ,@options))
(defun %with-compilation-unit (fn &key override) (defun %with-compilation-unit (fn &key override)
(handler-bind ((style-warning 'handle-style-warning) (if (and *in-compilation-unit* (not override))
(warning 'handle-warning) (funcall fn)
(compiler-error 'handle-compiler-error)) (let ((style-warnings 0)
(if (and *in-compilation-unit* (not override)) (warnings 0)
(funcall fn) (errors 0)
(let ((*style-warnings* 0) (*defined-functions* nil)
(*warnings* 0) (*undefined-functions* nil)
(*errors* 0) (*in-compilation-unit* t))
(*defined-functions* nil) (unwind-protect
(*undefined-functions* nil) (handler-bind ((style-warning #'(lambda (c)
(*in-compilation-unit* t)) (incf style-warnings)
(unwind-protect (handle-warning c)))
(funcall fn) (warning #'(lambda (c)
(unless (or (and *suppress-compiler-warnings* (zerop *errors*)) (incf warnings)
(and (zerop (+ *errors* *warnings* *style-warnings*)) (handle-warning c)))
(null *undefined-functions*))) (compiler-error #'(lambda (c)
(format *error-output* "~%; Compilation unit finished~%") (incf errors)
(unless (zerop *errors*) (handle-compiler-error c))))
(format *error-output* "; Caught ~D ERROR condition~P~%" (funcall fn))
*errors* *errors*)) (unless (or (and *suppress-compiler-warnings* (zerop errors))
(unless *suppress-compiler-warnings* (and (zerop (+ errors warnings style-warnings))
(unless (zerop *warnings*) (null *undefined-functions*)))
(format *error-output* "; Caught ~D WARNING condition~P~%" (format *error-output*
*warnings* *warnings*)) "~%; Compilation unit finished~%")
(unless (zerop *style-warnings*) (unless (zerop errors)
(format *error-output* "; Caught ~D STYLE-WARNING condition~P~%" (format *error-output*
*style-warnings* *style-warnings*)) "; Caught ~D ERROR condition~P~%"
(when *undefined-functions* errors errors))
(format *error-output* "; The following functions were used but not defined:~%") (unless *suppress-compiler-warnings*
(dolist (name *undefined-functions*) (unless (zerop warnings)
(format *error-output* "; ~S~%" name)))) (format *error-output*
(terpri *error-output*))))))) "; Caught ~D WARNING condition~P~%"
warnings warnings))
(unless (zerop style-warnings)
(format *error-output*
"; Caught ~D STYLE-WARNING condition~P~%"
style-warnings style-warnings))
(when *undefined-functions*
(format *error-output*
"; The following functions were used but not defined:~%")
(dolist (name *undefined-functions*)
(format *error-output* "; ~S~%" name))))
(terpri *error-output*))))))
(defun get-lambda-to-compile (thing) (defun get-lambda-to-compile (thing)
(if (and (consp thing) (if (and (consp thing)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment