[armedbear-cvs] r11764 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sat Apr 18 20:17:41 UTC 2009
Author: ehuelsmann
Date: Sat Apr 18 16:17:41 2009
New Revision: 11764
Log:
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.
Modified:
trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Sat Apr 18 16:17:41 2009
@@ -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))))
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Apr 18 16:17:41 2009
@@ -1002,56 +1002,6 @@
(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 @@
(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 () , at body) , at 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)
More information about the armedbear-cvs
mailing list