diff --git a/cache.lisp b/cache.lisp index 13cbc6dae7564a8143a312cf3ce24f2e1390abbf..bb425e279df7c3f88220a8d1946f46704faf8bea 100644 --- a/cache.lisp +++ b/cache.lisp @@ -45,7 +45,7 @@ (defun normalize-namestring (pathname) (let ((resolved (resolve-symlinks* (ensure-absolute-pathname - (translate-logical-pathname pathname) + (physicalize-pathname pathname) 'get-pathname-defaults)))) (with-pathname-defaults () (namestring resolved)))) diff --git a/find-system.lisp b/find-system.lisp index 102be0e16bf5e10edbe0ddbac965fa3106e56d83..9268790527ad042871d0cb630412aecaa5b87ae0 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -292,7 +292,7 @@ Going forward, we recommend new users should be using the source-registry. (*print-readably* nil) (*default-pathname-defaults* ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. - (pathname-directory-pathname (translate-logical-pathname pathname)))) + (pathname-directory-pathname (physicalize-pathname pathname)))) (handler-bind ((error #'(lambda (condition) (error 'load-system-definition-error @@ -401,8 +401,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (or (pathname-equal pathname previous-pathname) (and pathname previous-pathname (pathname-equal - (translate-logical-pathname pathname) - (translate-logical-pathname previous-pathname)))) + (physicalize-pathname pathname) + (physicalize-pathname previous-pathname)))) (stamp<= stamp previous-time)))))) ;; only load when it's a pathname that is different or has newer content, and not an old asdf (load-asd pathname :name name))) diff --git a/test/run-tests.sh b/test/run-tests.sh index 4a1c86575348c07ce23a7168552e49ef4062aea1..4c36c2330a05034611f5e3f7b5ff452e938a2a61 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -84,11 +84,10 @@ do_tests () { scripts="$*" fi env | grep -i asdf - rm -f ~/.cache/common-lisp/"`pwd`"/* || true ## We go through great lengths to avoid " in the command line, - ## the quoting of which some Windows implementations get wrong. + ## the quoting of which many Windows implementations get wrong. ## While we're at it, we also avoid spaces and backslashes. - ( cd .. && DO $bcmd $eval '(or #.(load(string`|test/script-support.lisp|))#.(asdf-test::compile-asdf-script))' ) + ( DO $bcmd $eval '(or`,#.(load(string`|script-support.lisp|))#.(asdf-test::compile-asdf-script))' ) if [ $? -ne 0 ] ; then echo "Compilation FAILED" >&2 echo "you can retry compilation with:" >&2 diff --git a/test/script-support.lisp b/test/script-support.lisp index 5767b63004c159793472f8315bdca3a00d8b948a..09db7a9b5c367fdf30222fc30acf99b1aa8ff233 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -224,7 +224,7 @@ Some constraints: (defun asdf-lisp (&optional tag) (make-pathname :name (asdf-name tag) :type "lisp" :defaults *build-directory*)) (defun debug-lisp () - (make-sub-pathname :directory (relative-dir "contrib") :name "debug" :type "lisp" :defaults *asdf-directory*)) + (make-sub-pathname :directory (relative-dir "contrib") :name "debug" :type "lisp" :defaults *uiop-directory*)) (defun early-compile-file-pathname (file) (compile-file-pathname (make-pathname :name (pathname-name file) :type "lisp" :defaults *early-fasl-directory*))) diff --git a/test/stamp-propagation/test-stamp-propagation.lisp b/test/stamp-propagation/test-stamp-propagation.lisp index 71921abd5ad90cd67bd8a506183adda604832d1b..1ffe1bdf6388d378cff59aad657ca80cdb14fa05 100644 --- a/test/stamp-propagation/test-stamp-propagation.lisp +++ b/test/stamp-propagation/test-stamp-propagation.lisp @@ -92,7 +92,7 @@ "file2.lisp")) (defun reload (&optional (defsystem *default-defsystem*)) - (format t "~&ASDF-CACHE ~S~%" asdf::*asdf-cache*) + (format t "~&ASDF-CACHE before ~S~%" asdf::*asdf-cache*) (setf *eval-notes* nil) (setf *compile-verbose* t *load-verbose* t) (ecase defsystem @@ -118,10 +118,22 @@ #+allegro (excl:load-system :test-stamp-propagation) #+lispworks (scm:load-system :test-stamp-propagation) #+genera (sct:load-system :test-stamp-propagation))) + (format t "~&ASDF-CACHE after ~S~%" asdf::*asdf-cache*) (let ((n (eval-notes))) (format t "~&EVAL-NOTES ~S~%" n) n)) +(defun clear-sys (&optional (defsystem *default-defsystem*)) + #+asdf + (when (eq defsystem :asdf) + (asdf:clear-system :test-stamp-propagation) + (asdf:defsystem :test-stamp-propagation + :pathname #.*tsp* :source-file nil + :serial t + :components + ((:file "file1") + (:file "file2"))))) + (defun touch (filename) #+genera filename ;; TODO: do something with it! #-genera @@ -140,28 +152,33 @@ (remove '(:loading :system) log :test 'equal) :test 'equal :from-end t)) +(defun adjust-stamp-cache (base l1 f1 l2 f2) + (clrhash asdf::*asdf-cache*) + (touch-file (lisppath "file1.lisp") :timestamp base :offset l1) + (touch-file (faslpath "file1.lisp") :timestamp base :offset f1) + (dolist (l (asdf:output-files (make-instance 'asdf:compile-op) + (asdf:find-component :test-stamp-propagation '("file1")))) + (touch-file l :timestamp base :offset f1)) + (touch-file (lisppath "file2.lisp") :timestamp base :offset l2) + (touch-file (faslpath "file2.lisp") :timestamp base :offset f2) + (dolist (l (asdf:output-files (make-instance 'asdf:compile-op) + (asdf:find-component :test-stamp-propagation '("file2")))) + (touch-file l :timestamp base :offset f2))) + (defun test-defsystem (&optional (defsystem *default-defsystem*)) - (format t "~&Testing stamp propagation by defsystem ~S~%" defsystem) - #+allegro (progn (DBG "removing any old fasls from another flavor of allegro") - (clear-fasls defsystem)) + (format t "~%~%Testing stamp propagation by defsystem ~S~%" defsystem) + #+(or allegro clisp) + (progn (DBG "removing any old fasls from another flavor of the implementation") + (clear-fasls defsystem)) (when (use-cache-p defsystem) - (let ((tl1 (file-write-date (lisppath "file1.lisp")))) - (touch-file (lisppath "file1.lisp") :timestamp tl1 :offset -1000) - (touch-file (faslpath "file1.lisp") :timestamp tl1 :offset -10000) - (touch-file (lisppath "file2.lisp") :timestamp tl1 :offset -1000) - (touch-file (faslpath "file2.lisp") :timestamp tl1 :offset -10000))) + (adjust-stamp-cache (file-write-date (lisppath "file1.lisp")) -1000 -10000 -1000 -10000)) (DBG "loading system") (reload defsystem) + (clear-sys defsystem) (cond ((use-cache-p defsystem) (DBG "marking all files old but first source file, and reloading") - (clrhash (asdf::component-operation-times (asdf:find-component :test-stamp-propagation "file1"))) - (clrhash (asdf::component-operation-times (asdf:find-component :test-stamp-propagation "file2"))) - (let ((tf2 (file-write-date (faslpath "file2.lisp")))) - (touch-file (lisppath "file1.lisp") :timestamp tf2 :offset 0) - (touch-file (faslpath "file1.lisp") :timestamp tf2 :offset -200) - (touch-file (lisppath "file2.lisp") :timestamp tf2 :offset -500) - (touch-file (faslpath "file2.lisp") :timestamp tf2 :offset -100))) + (adjust-stamp-cache (file-write-date (lisppath "file1.lisp")) 0 -1000 -1000 -1000)) (t (DBG "touching first source file and reloading") (sleep #-os-windows 3 #+os-windows 5) @@ -170,14 +187,11 @@ (assert-equal (sanitize-log (reload defsystem)) '((:compiling :system) (:compile-toplevel :file1) (:load-toplevel :file1) (:compile-toplevel :file2) (:load-toplevel :file2))) + (clear-sys defsystem) (cond ((use-cache-p defsystem) (DBG "marking the old fasl new, the second one up to date") - (let ((tf2 (file-write-date (faslpath "file2.lisp")))) - (touch-file (lisppath "file1.lisp") :timestamp tf2 :offset 100) - (touch-file (faslpath "file1.lisp") :timestamp tf2 :offset 500) - (touch-file (lisppath "file2.lisp") :timestamp tf2 :offset 100) - (touch-file (faslpath "file2.lisp") :timestamp tf2 :offset 100))) + (adjust-stamp-cache (file-write-date (lisppath "file1.lisp")) 100 500 100 100)) (t (DBG "touching first fasl file and reloading") (sleep #-os-windows 3 #+os-windows 5) diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp index a7b634410dc83dc598fb31c3ac78b592faf46fd8..e62b1dccd1b2726f68dd57ed2ae22b7969a4351b 100644 --- a/uiop/filesystem.lisp +++ b/uiop/filesystem.lisp @@ -78,7 +78,7 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" ;; as if the file were very old. ;; (or should we treat the case in a different, special way?) (and pathname - (handler-case (file-write-date (translate-logical-pathname pathname)) + (handler-case (file-write-date (physicalize-pathname pathname)) (file-error () nil)))) (defun probe-file* (p &key truename) @@ -100,7 +100,7 @@ or the original (parsed) pathname if it is false (the default)." (if truename (probe-file p) (ignore-errors - (let ((pp (translate-logical-pathname p))) + (let ((pp (physicalize-pathname p))) (and #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) #+(and lispworks unix) (system:get-file-stat pp) @@ -384,7 +384,7 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (unless (pathnamep p) (return nil)) (check want-logical (logical-pathname-p p) "Expected a logical pathname") (check want-physical (physical-pathname-p p) "Expected a physical pathname") - (transform ensure-physical () (translate-logical-pathname p)) + (transform ensure-physical () (physicalize-pathname p)) (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname") (check want-relative (relative-pathname-p p) "Expected a relative pathname") (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname") @@ -516,7 +516,7 @@ as per native OS" "Ensure that for every pathname in PATHNAMES, we ensure its directories exist" (dolist (pathname pathnames) (when pathname - (ensure-directories-exist (translate-logical-pathname pathname))))) + (ensure-directories-exist (physicalize-pathname pathname))))) (defun rename-file-overwriting-target (source target) "Rename a file, overwriting any previous file with the TARGET name, diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp index 8d1a7a0a51204526776cc63292d0556d9196c9cd..062b33b0df144869c4e56e137fadae1950a8ae50 100644 --- a/uiop/pathname.lisp +++ b/uiop/pathname.lisp @@ -15,7 +15,7 @@ #:merge-pathnames* #:nil-pathname #:*nil-pathname* #:with-pathname-defaults ;; Predicates - #:pathname-equal #:logical-pathname-p #:physical-pathname-p + #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p ;; Directories #:pathname-directory-pathname #:pathname-parent-directory-pathname @@ -181,6 +181,20 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." :type (funcall unspecific-handler type) :version (funcall unspecific-handler version)))))) + (defun logical-pathname-p (x) + "is X a logical-pathname?" + (typep x 'logical-pathname)) + + (defun physical-pathname-p (x) + "is X a pathname that is not a logical-pathname?" + (and (pathnamep x) (not (logical-pathname-p x)))) + + (defun physicalize-pathname (x) + "if X is a logical pathname, use translate-logical-pathname on it." + ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP + (let ((p (when x (pathname x)))) + (if (logical-pathname-p p) (translate-logical-pathname p) p))) + (defun nil-pathname (&optional (defaults *default-pathname-defaults*)) "A pathname that is as neutral as possible for use as defaults when merging, making or parsing pathnames" @@ -197,7 +211,7 @@ when merging, making or parsing pathnames" ;; the default shouldn't matter, but we really want something physical #-mcl ,@'(:defaults defaults))) - (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))) + (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname))) "A pathname that is as neutral as possible for use as defaults when merging, making or parsing pathnames") @@ -230,14 +244,6 @@ when merging, making or parsing pathnames" (=? pathname-type) (=? pathname-version))))))) - (defun logical-pathname-p (x) - "is X a logical-pathname?" - (typep x 'logical-pathname)) - - (defun physical-pathname-p (x) - "is X a pathname that is not a logical-pathname?" - (and (pathnamep x) (not (logical-pathname-p x)))) - (defun absolute-pathname-p (pathspec) "If PATHSPEC is a pathname or namestring object that parses as a pathname possessing an :ABSOLUTE directory component, return the (parsed) pathname.