[armedbear-cvs] r11763 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Apr 18 15:08:08 2009
New Revision: 11763

Log:
Fix COMPILE and COMPILE-FILE secondary and tertiary return values
in case of successful completion with multiple invocations inside
a single WITH-COMPILATION-UNIT and failed previous invocations.

Found by: Robert Dodier (robert_dodier at yahoo dot com)


Modified:
   trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	Sat Apr 18 15:08:08 2009
@@ -403,8 +403,8 @@
          (type (pathname-type output-file))
          (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp"))
                                      output-file))
-         (warnings-p t)
-         (failure-p t))
+         (warnings-p nil)
+         (failure-p nil))
     (with-open-file (in input-file :direction :input)
       (let* ((*compile-file-pathname* (pathname in))
              (*compile-file-truename* (truename in))
@@ -436,20 +436,26 @@
                   (%stream-terpri out)
                   (write (list 'setq '*source* *compile-file-truename*) :stream out)
                   (%stream-terpri out))
-                (loop
-                   (let* ((*source-position* (file-position in))
-                          (jvm::*source-line-number* (stream-line-number in))
-                          (form (read in nil in))
-                          (*compiler-error-context* form))
-                     (when (eq form in)
-                       (return))
-                     (process-toplevel-form form out nil)))
+                (handler-bind ((style-warning #'(lambda (c)
+                                                  (declare (ignore c))
+                                                  (setf warnings-p t)
+                                                  nil))
+                               ((or warning
+                                    compiler-error) #'(lambda (c)
+                                                        (declare (ignore c))
+                                                        (setf warnings-p t
+                                                              failure-p t)
+                                                        nil)))
+                  (loop
+                     (let* ((*source-position* (file-position in))
+                            (jvm::*source-line-number* (stream-line-number in))
+                            (form (read in nil in))
+                            (*compiler-error-context* form))
+                       (when (eq form in)
+                         (return))
+                       (process-toplevel-form form out nil))))
                 (dolist (name *fbound-names*)
-                  (fmakunbound name)))))
-          (cond ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
-                 (setf warnings-p nil failure-p nil))
-                ((zerop (+ jvm::*errors* jvm::*warnings*))
-                 (setf failure-p nil))))
+                  (fmakunbound name))))))
         (rename-file temp-file output-file)
 
         (when *compile-file-zip*

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 15:08:08 2009
@@ -8760,14 +8760,27 @@
                           (symbol-package name)
                           *package*))
            compiled-function
-           (warnings-p t)
-           (failure-p t))
+           (warnings-p nil)
+           (failure-p nil))
       (with-compilation-unit ()
         (with-saved-compiler-policy
           (let* ((tempfile (make-temp-file)))
             (unwind-protect
                  (setf compiled-function
-                       (load-compiled-function (compile-defun name expr env tempfile)))
+                       (load-compiled-function
+                        (handler-bind ((style-warning
+                                        #'(lambda (c)
+                                            (declare (ignore c))
+                                            (setf warnings-p t)
+                                            nil))
+                                       ((or warning
+                                            compiler-error)
+                                        #'(lambda (c)
+                                            (declare (ignore c))
+                                            (setf warnings-p t
+                                                  failure-p t)
+                                            nil)))
+                          (compile-defun name expr env tempfile))))
               (delete-file tempfile))))
         (when (and name (functionp compiled-function))
           (sys::%set-lambda-name compiled-function name)
@@ -8780,11 +8793,7 @@
                    (setf (fdefinition name)
                          (if (macro-function name)
                              (make-macro name compiled-function)
-                             compiled-function))))))
-        (cond ((zerop (+ *errors* *warnings* *style-warnings*))
-               (setf warnings-p nil failure-p nil))
-              ((zerop (+ *errors* *warnings*))
-               (setf failure-p nil))))
+                             compiled-function)))))))
       (values (or name compiled-function) warnings-p failure-p))))
 
 (defun jvm-compile (name &optional definition)