Commit 89d9d140 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Yet more work to make test-stamp-propagation robust.

Introduce physicalize-pathname as an abstraction for translate-logical-pathname,
due to bug in CLISP.
parent bd3e5f5b
......@@ -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))))
......
......@@ -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)))
......
......@@ -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
......
......@@ -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*)))
......
......@@ -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)
......
......@@ -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,
......
......@@ -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.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment