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