diff --git a/compiler/main.lisp b/compiler/main.lisp index ed861cc605af5550198f5ab520435e9bb316747e..ded912a32efbd3931dcb24911392c40fdb5443ce 100644 --- a/compiler/main.lisp +++ b/compiler/main.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.128 2002/11/14 16:54:37 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.129 2002/11/19 12:55:02 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1948,47 +1948,41 @@ (type (or string pathname stream (member t)) output-file) (values (or null pathname))) - ;; Check INPUT-FILE - (when (and (streamp input-file) (not (typep input-file 'file-stream))) - (error 'simple-type-error - :datum input-file - :expected-type 'file-stream - :format-control "The INPUT-FILE parameter is a ~S, which is an invalid value ~@ + (flet ((check-file-argument (file name) + (when (and (streamp file) + (not (typep file 'file-stream))) + (error 'simple-type-error + :datum input-file + :expected-type 'file-stream + :format-control "The ~A parameter is a ~S, which is an invalid value ~@ to COMPILE-FILE-PATHNAME." - :format-arguments (list (type-of input-file)))) - - - (when (eq output-file t) - (setf output-file (compile-output-type-from-input input-file - byte-compile))) - ;; Same checks on OUTPUT-FILE. - - (when (and (streamp output-file) (not (typep output-file 'file-stream))) - (error 'simple-type-error - :datum output-file - :expected-type 'file-stream - :format-control "The OUTPUT-FILE parameter is a ~S, which is an invalid value ~@ - to COMPILE-FILE-PATHNAME." - :format-arguments (list (type-of output-file)))) - - ;; Maybe these are too much. CLHS says "might". - (when (wild-pathname-p input-file) - (error 'file-error :pathname input-file)) - - (when (wild-pathname-p output-file) - (error 'file-error :pathname output-file)) - - - (let ((merged-input-file - (merge-pathnames input-file *default-pathname-defaults*)) - (resulting-pathname-type (pathname-type output-file))) - (cond ((and (not output-file-supplied-p) - (typep merged-input-file 'logical-pathname)) - (make-pathname :type resulting-pathname-type - :defaults merged-input-file - :case :common)) ; Not sure about this last one. - ((typep merged-input-file 'logical-pathname) - (merge-pathnames output-file - (translate-logical-pathname merged-input-file))) - (t - (merge-pathnames output-file merged-input-file))))) + :format-arguments (list name (type-of input-file)))) + ;; Maybe this is too much. CLHS says "might". + (when (wild-pathname-p input-file) + (error 'file-error :pathname input-file)))) + ;; Check INPUT-FILE + (check-file-argument input-file "INPUT-FILE") + + (let ((output-file-type (compile-output-type-from-input input-file + byte-compile))) + (when (eq output-file t) + (setf output-file output-file-type)) + (check-file-argument output-file "OUTPUT-FILE") + + (let* ((merged-input-file + (merge-pathnames input-file *default-pathname-defaults*)) + (output-pathname-type (or (pathname-type output-file) + (pathname-type output-file-type)))) + (cond ((and (not output-file-supplied-p) + (typep merged-input-file 'logical-pathname)) + (make-pathname :type output-pathname-type + :defaults merged-input-file + :case :common)) ; Not sure about this last one. + ((typep merged-input-file 'logical-pathname) + (make-pathname :type output-pathname-type + :defaults (merge-pathnames output-file + (translate-logical-pathname merged-input-file)))) + (t + (make-pathname :type output-pathname-type + :defaults (merge-pathnames output-file + merged-input-file))))))))