Commit 44aa97ed authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Make test-stamp-propagation succeed (at failing!) on ASDF 2.26,

and more reliably work with ASDF3.
parent 848c2059
......@@ -88,6 +88,7 @@ Some constraints:
(when errorp (error "Can't find package ~A" pname)))))
(defun acall (name &rest args)
(apply (apply 'asym (if (consp name) name (list name))) args))
(defun ucall (name &rest args) (apply (asym name :uiop) args))
(defun asymval (name &optional package)
(symbol-value (asym name package)))
(defsetf asymval (name &optional package) (new-value) ;; NB: defun setf won't work on GCL2.6
......@@ -147,7 +148,7 @@ Some constraints:
(cond
((equal x y)
(format t "~S and ~S both evaluate to same path:~% ~S~%" qx qy x))
((acall :pathname-equal x y)
((ucall :pathname-equal x y)
(warn "These two expressions yield pathname-equal yet not equal path~%~
the first expression ~S yields this:~% ~S~% ~S~%
the other expression ~S yields that:~% ~S~% ~S~%"
......@@ -257,10 +258,10 @@ Some constraints:
(decode-universal-time stamp #+gcl2.6 -5) ;; -5 is for *my* localtime
(unless in-filesystem
(error "Y U NO use stamp cache?"))
(acall :run-program
(ucall :run-program
`("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D"
year month day hr min sec)
,(acall :native-namestring file)))
,(ucall :native-namestring file)))
(assert-equal (file-write-date file) stamp)))))
(defun mark-file-deleted (file)
(unless (asymval :*asdf-cache*) (error "Y U NO use asdf cache?"))
......@@ -325,7 +326,7 @@ is bound, write a message and exit on an error. If
(break))
(t
(ignore-errors
(acall :print-condition-backtrace
(ucall :print-condition-backtrace
c :count 69 :stream *error-output*))
(leave-test "Script failed" 1))))))
(funcall (or (asym :call-with-asdf-cache) 'funcall) thunk)
......
......@@ -9,7 +9,8 @@
(unless (find-package :asdf)
(asdf-test::load-asdf)
(asdf-test::frob-packages))
(asdf-test::frob-packages)
(use-package :uiop :asdf))
(in-package :asdf-test)
......@@ -125,7 +126,7 @@
(defun touch (filename)
#+genera filename ;; TODO: do something with it!
#-genera
(uiop:run-program `("touch" ,(native-namestring filename))
(uiop:run-program `("touch" ,(uiop:native-namestring filename))
:output t :error-output t))
(defun clear-fasls (&optional (defsystem *default-defsystem*))
......@@ -166,10 +167,10 @@
((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 0)
(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 0)
(touch-file (faslpath "file2.lisp") :timestamp tf2 :offset 0)))
(touch-file (lisppath "file2.lisp") :timestamp tf2 :offset 100)
(touch-file (faslpath "file2.lisp") :timestamp tf2 :offset 100)))
(t
(DBG "touching first fasl file and reloading")
(sleep #-os-windows 3 #+os-windows 5)
......@@ -182,8 +183,10 @@
(clear-fasls defsystem))
#-(or abcl xcl) ;; TODO: figure out why ABCL and XCL fail to recompile anything.
(test-defsystem :asdf)
(cond
#+(and asdf3 (not abcl) (not xcl)) ;; TODO: figure out why ABCL and XCL fail to recompile anything.
(t (test-defsystem :asdf))
(t (signals error (test-defsystem :asdf))))
#+(or genera lispworks)
(test-defsystem :native)
......
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