From 4bf9e918781ba334b44630ece5835fe22f370b6b Mon Sep 17 00:00:00 2001 From: "ehuelsmann@1c010e3e-69d0-11dd-93a8-456734b0d56f" Date: Sat, 18 Apr 2009 20:17:41 +0000 Subject: [PATCH] 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. --- src/org/armedbear/lisp/compile-system.lisp | 17 ++- src/org/armedbear/lisp/compiler-pass2.lisp | 161 ++++++++++----------- 2 files changed, 92 insertions(+), 86 deletions(-) diff --git a/src/org/armedbear/lisp/compile-system.lisp b/src/org/armedbear/lisp/compile-system.lisp index 654821a4..c5a21667 100644 --- a/src/org/armedbear/lisp/compile-system.lisp +++ b/src/org/armedbear/lisp/compile-system.lisp @@ -270,9 +270,18 @@ (check-lisp-home) (time (with-compilation-unit () - (let ((*compile-file-zip* zip)) - (%compile-system :output-path output-path)) - (when (zerop (+ jvm::*errors* jvm::*warnings*)) - (setf status 0)))) + (let ((*compile-file-zip* zip) + failure-p) + (handler-bind (((or warning + 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 (quit :status status)))) diff --git a/src/org/armedbear/lisp/compiler-pass2.lisp b/src/org/armedbear/lisp/compiler-pass2.lisp index 8a961db4..f5839459 100644 --- a/src/org/armedbear/lisp/compiler-pass2.lisp +++ b/src/org/armedbear/lisp/compiler-pass2.lisp @@ -1002,56 +1002,6 @@ representation, based on the derived type of the LispObject." (fix-boxing representation nil) (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 ;; of type WARNING must or might be signaled, warnings might be signaled in ;; situations where the compiler can determine that the consequences are @@ -8697,44 +8647,91 @@ for use with derive-type-times.") (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) (defmacro with-compilation-unit (options &body body) `(%with-compilation-unit (lambda () ,@body) ,@options)) (defun %with-compilation-unit (fn &key override) - (handler-bind ((style-warning 'handle-style-warning) - (warning 'handle-warning) - (compiler-error 'handle-compiler-error)) - (if (and *in-compilation-unit* (not override)) - (funcall fn) - (let ((*style-warnings* 0) - (*warnings* 0) - (*errors* 0) - (*defined-functions* nil) - (*undefined-functions* nil) - (*in-compilation-unit* t)) - (unwind-protect - (funcall fn) - (unless (or (and *suppress-compiler-warnings* (zerop *errors*)) - (and (zerop (+ *errors* *warnings* *style-warnings*)) - (null *undefined-functions*))) - (format *error-output* "~%; Compilation unit finished~%") - (unless (zerop *errors*) - (format *error-output* "; Caught ~D ERROR condition~P~%" - *errors* *errors*)) - (unless *suppress-compiler-warnings* - (unless (zerop *warnings*) - (format *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*))))))) + (if (and *in-compilation-unit* (not override)) + (funcall fn) + (let ((style-warnings 0) + (warnings 0) + (errors 0) + (*defined-functions* nil) + (*undefined-functions* nil) + (*in-compilation-unit* t)) + (unwind-protect + (handler-bind ((style-warning #'(lambda (c) + (incf style-warnings) + (handle-warning c))) + (warning #'(lambda (c) + (incf warnings) + (handle-warning c))) + (compiler-error #'(lambda (c) + (incf errors) + (handle-compiler-error c)))) + (funcall fn)) + (unless (or (and *suppress-compiler-warnings* (zerop errors)) + (and (zerop (+ errors warnings style-warnings)) + (null *undefined-functions*))) + (format *error-output* + "~%; Compilation unit finished~%") + (unless (zerop errors) + (format *error-output* + "; Caught ~D ERROR condition~P~%" + errors errors)) + (unless *suppress-compiler-warnings* + (unless (zerop warnings) + (format *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) (if (and (consp thing) -- GitLab