0.7.9.6:

[sbcl.git] / src / cold / shared.lisp

diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp
index b4ff892..985a444 100644 (file)
--- a/src/cold/shared.lisp
+++ b/src/cold/shared.lisp
@@ -46,6 +46,7 @@
    ;; that we never explicitly refer to host object file suffixes,
    ;; only to the result of CL:COMPILE-FILE-PATHNAME.
    #+lispworks ".ufsl" ; as per Lieven Marchand sbcl-devel 2002-02-01
+   #+openmcl ".pfsl"
    ;; On most xc hosts, any old extension works, so we use an
    ;; arbitrary one.
    ".lisp-obj"))
@@ -150,41 +151,62 @@
     (when (probe-file obj)
       (delete-file obj))
 
-    ;; Work around a bug in CLISP 1999-01-08 #'COMPILE-FILE: CLISP
-    ;; mangles relative pathnames passed as :OUTPUT-FILE arguments,
-    ;; but works OK with absolute pathnames.
-    #+clisp
+    ;; Original comment:
+    ;;
+    ;;   Work around a bug in CLISP 1999-01-08 #'COMPILE-FILE: CLISP
+    ;;   mangles relative pathnames passed as :OUTPUT-FILE arguments,
+    ;;   but works OK with absolute pathnames.
+    ;;
+    ;; following discussion on cmucl-imp 2002-07
+    ;; "COMPILE-FILE-PATHNAME", it would seem safer to deal with
+    ;; absolute pathnames all the time; it is no longer clear that the
+    ;; original behaviour in CLISP was wrong or that the current
+    ;; behaviour is right; and in any case absolutifying the pathname
+    ;; insulates us against changes of behaviour. -- CSR, 2002-08-09
     (setf tmp-obj
          ;; (Note that this idiom is taken from the ANSI
          ;; documentation for TRUENAME.)
          (with-open-file (stream tmp-obj :direction :output)
            (close stream)
            (truename stream)))
+    ;; and some compilers (e.g. OpenMCL) will complain if they're
+    ;; asked to write over a file that exists already (and isn't
+    ;; recognizeably a fasl file), so
+    (when (probe-file tmp-obj)
+      (delete-file tmp-obj))
 
     ;; Try to use the compiler to generate a new temporary object file.
-    (multiple-value-bind (output-truename warnings-p failure-p)
-       (funcall compile-file src :output-file tmp-obj)
-      (declare (ignore warnings-p))
-      (cond ((not output-truename)
-            (error "couldn't compile ~S" src))
-           (failure-p
-            (if ignore-failure-p
-                (warn "ignoring FAILURE-P return value from compilation of ~S"
-                      src)
-                (unwind-protect
-                    (progn
-                      ;; FIXME: This should have another option,
-                      ;; redoing compilation.
-                      (cerror "Continue, using possibly-bogus ~S."
-                              "FAILURE-P was set when creating ~S."
-                              obj)
-                      (setf failure-p nil))
-                  ;; Don't leave failed object files lying around.
-                  (when (and failure-p (probe-file tmp-obj))
-                    (delete-file tmp-obj)
-                    (format t "~&deleted ~S~%" tmp-obj)))))
-           ;; Otherwise: success, just fall through.
-           (t nil)))
+    (flet ((report-recompile-restart (stream)
+             (format stream "Recompile file ~S" src))
+           (report-continue-restart (stream)
+             (format stream "Continue, using possibly bogus file ~S" obj)))
+      (tagbody
+       retry-compile-file
+         (multiple-value-bind (output-truename warnings-p failure-p)
+             (funcall compile-file src :output-file tmp-obj)
+           (declare (ignore warnings-p))
+           (cond ((not output-truename)
+                  (error "couldn't compile ~S" src))
+                 (failure-p
+                  (if ignore-failure-p
+                      (warn "ignoring FAILURE-P return value from compilation of ~S"
+                            src)
+                      (unwind-protect
+                           (restart-case
+                               (error "FAILURE-P was set when creating ~S."
+                                      obj)
+                             (recompile ()
+                               :report report-recompile-restart
+                               (go retry-compile-file))
+                             (continue ()
+                               :report report-continue-restart
+                               (setf failure-p nil)))
+                        ;; Don't leave failed object files lying around.
+                        (when (and failure-p (probe-file tmp-obj))
+                          (delete-file tmp-obj)
+                          (format t "~&deleted ~S~%" tmp-obj)))))
+                 ;; Otherwise: success, just fall through.
+                 (t nil)))))
 
     ;; If we get to here, compilation succeeded, so it's OK to rename
     ;; the temporary output file to the permanent object file.
@@ -236,7 +258,6 @@
                                  (read-from-file customizer-file-name))
                         #'identity)))
     (funcall customizer default-subfeatures)))
-(export '*shebang-backend-subfeatures*)
 (let ((*print-length* nil)
       (*print-level* nil))
   (format t
@@ -250,11 +271,11 @@
 ;;; values of special variables such as *** and +, anyway). Set up
 ;;; machinery to warn us when/if we change it.
 ;;;
-;;; FIXME: All this machinery should probably be conditional on
-;;; #!+SB-SHOW, i.e. we should be able to wrap #!+SB-SHOW around both
-;;; the LOAD and the DEFVAR here. 
-(load "src/cold/snapshot.lisp")
-(defvar *cl-snapshot* (take-snapshot "COMMON-LISP"))
+;;; All code depending on this is itself dependent on #!+SB-SHOW.
+#!+sb-show
+(progn
+  (load "src/cold/snapshot.lisp")
+  (defvar *cl-snapshot* (take-snapshot "COMMON-LISP")))
 \f
 ;;;; master list of source files and their properties