X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcold%2Fshared.lisp;h=86dcd58a93883e8f49719399beea0cdebd183f0c;hb=670010e3f3dcd62efaf23f61abdc73950edb88c6;hp=a55036c4108c27ef93b2cccf39b3ab4c8686bff4;hpb=ec2616d216958a608581802c47496c0194478dc8;p=sbcl.git diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index a55036c..86dcd58 100644 --- 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")) @@ -58,11 +59,12 @@ ;;; a function of one functional argument, which calls its functional argument ;;; in an environment suitable for compiling the target. (This environment ;;; includes e.g. a suitable *FEATURES* value.) +(declaim (type function *in-target-compilation-mode-fn*)) (defvar *in-target-compilation-mode-fn*) -;;; designator for a function with the same calling convention as -;;; CL:COMPILE-FILE, to be used to translate ordinary Lisp source files into -;;; target object files +;;; a function with the same calling convention as CL:COMPILE-FILE, to be +;;; used to translate ordinary Lisp source files into target object files +(declaim (type function *target-compile-file*)) (defvar *target-compile-file*) ;;; designator for a function with the same calling convention as @@ -129,6 +131,8 @@ (compile-file #'compile-file) ignore-failure-p) + (declare (type function compile-file)) + (let* (;; KLUDGE: Note that this CONCATENATE 'STRING stuff is not The Common ;; Lisp Way, although it works just fine for common UNIX environments. ;; Should it come to pass that the system is ported to environments @@ -150,41 +154,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 +261,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 @@ -262,10 +286,13 @@ (defparameter *expected-stem-flags* '(;; meaning: This file is not to be compiled when building the - ;; cross-compiler which runs on the host ANSI Lisp. + ;; cross-compiler which runs on the host ANSI Lisp. ("not host + ;; code", i.e. does not execute on host -- but may still be + ;; cross-compiled by the host, so that it executes on the target) :not-host ;; meaning: This file is not to be compiled as part of the target - ;; SBCL. + ;; SBCL. ("not target code" -- but still presumably host code, + ;; used to support the cross-compilation process) :not-target ;; meaning: This file is to be processed with the SBCL assembler, ;; not COMPILE-FILE. (Note that this doesn't make sense unless @@ -284,7 +311,7 @@ (defparameter *stems-and-flags* (read-from-file "build-order.lisp-expr")) (defmacro do-stems-and-flags ((stem flags) &body body) - (let ((stem-and-flags (gensym "STEM-AND-FLAGS-"))) + (let ((stem-and-flags (gensym "STEM-AND-FLAGS"))) `(dolist (,stem-and-flags *stems-and-flags*) (let ((,stem (first ,stem-and-flags)) (,flags (rest ,stem-and-flags))) @@ -306,6 +333,7 @@ ;;; Execute function FN in an environment appropriate for compiling the ;;; cross-compiler's source code in the cross-compilation host. (defun in-host-compilation-mode (fn) + (declare (type function fn)) (let ((*features* (cons :sb-xc-host *features*)) ;; the CROSS-FLOAT-INFINITY-KLUDGE, as documented in ;; base-target-features.lisp-expr: