diff --git a/uiop/lisp-build.lisp b/uiop/lisp-build.lisp index 65d55402565af6f27510d30f8fefe34adbe6c2bc..927fc019e8facb501de203e4039028f730391854 100644 --- a/uiop/lisp-build.lisp +++ b/uiop/lisp-build.lisp @@ -11,6 +11,7 @@ #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*output-translation-function* #:*optimization-settings* #:*previous-optimization-settings* + #:*base-build-directory* #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error #:compile-warned-warning #:compile-failed-warning #:check-lisp-compile-results #:check-lisp-compile-warnings @@ -44,8 +45,13 @@ Valid values are :error, :warn, and :ignore.") "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) when compiling a file, which includes any non-style-warning warning. Valid values are :error, :warn, and :ignore. -Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")) +Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") + (defvar *base-build-directory* nil + "When set to a non-null value, it should be an absolute directory pathname, +which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE, +what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it. +This can help you produce more deterministic output for FASLs.")) ;;; Optimization settings (with-upgradability () @@ -551,7 +557,7 @@ possibly in a different process. Otherwise just call THUNK." (funcall thunk))) (defmacro with-saved-deferred-warnings ((warnings-file) &body body) - "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS" + "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS" `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file))) @@ -563,7 +569,7 @@ possibly in a different process. Otherwise just call THUNK." (defun load-pathname () "Portably return the LOAD-PATHNAME of the current source file or fasl" - *load-pathname*) ;; see magic for GCL in uiop/common-lisp + *load-pathname*) ;; see magic for GCL in uiop/common-lisp (defun lispize-pathname (input-file) "From a INPUT-FILE pathname, return a corresponding .lisp source pathname" @@ -649,16 +655,17 @@ it will filter them appropriately." (multiple-value-bind (output-truename warnings-p failure-p) (with-saved-deferred-warnings (warnings-file) (with-muffled-compiler-conditions () - (or #-(or ecl mkcl) - (apply 'compile-file input-file :output-file tmp-file - #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) - #-sbcl keywords) - #+ecl (apply 'compile-file input-file :output-file - (if object-file - (list* object-file :system-p t keywords) - (list* tmp-file keywords))) - #+mkcl (apply 'compile-file input-file - :output-file object-file :fasl-p nil keywords)))) + (with-enough-pathname (input-file :defaults *base-build-directory*) + (or #-(or ecl mkcl) + (apply 'compile-file input-file :output-file tmp-file + #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) + #-sbcl keywords) + #+ecl (apply 'compile-file input-file :output-file + (if object-file + (list* object-file :system-p t keywords) + (list* tmp-file keywords))) + #+mkcl (apply 'compile-file input-file + :output-file object-file :fasl-p nil keywords))))) (cond ((and output-truename (flet ((check-flag (flag behaviour) diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp index 17971d1788415c10bb0ba0690479022d6ea84ca9..8d1a7a0a51204526776cc63292d0556d9196c9cd 100644 --- a/uiop/pathname.lisp +++ b/uiop/pathname.lisp @@ -28,7 +28,7 @@ #:subpathname #:subpathname* #:ensure-absolute-pathname #:pathname-root #:pathname-host-pathname - #:subpathp + #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname ;; Checking constraints #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints ;; Wildcard pathnames @@ -560,6 +560,29 @@ when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPA (let ((enough (enough-namestring maybe-subpath base-pathname))) (and (relative-pathname-p enough) (pathname enough)))))) + (defun enough-pathname (maybe-subpath base-pathname) + "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that +when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." + (check-type maybe-subpath (or null pathname)) + (check-type base-pathname (or null pathname)) + (when (pathnamep base-pathname) (assert (absolute-pathname-p base-pathname))) + (or (and base-pathname (subpathp maybe-subpath base-pathname)) + maybe-subpath)) + + (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk) + "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null, +or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH +given DEFAULTS-PATHNAME as a base pathname." + (let ((enough (enough-pathname maybe-subpath defaults-pathname)) + (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*))) + (funcall thunk enough))) + + (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var) + (defaults *default-pathname-defaults*)) + &body body) + "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME" + `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body))) + (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) "Given a pathname designator PATH, return an absolute pathname as specified by PATH considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior,