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

2.26.145: introduce a stamp cache, to reduce filesystem access,

enhance plan consistency and make testing easier.
parent 201861e2
...@@ -17,6 +17,11 @@ endif ...@@ -17,6 +17,11 @@ endif
## Some are manually tested once in a while. ## Some are manually tested once in a while.
## MAJOR FAIL: gclcvs -- Compiler bug fixed upstream, but gcl fails to compile on modern Linuxen. ## MAJOR FAIL: gclcvs -- Compiler bug fixed upstream, but gcl fails to compile on modern Linuxen.
## grep for #+/#- features in the test/ directory to see plenty of disabled tests. ## grep for #+/#- features in the test/ directory to see plenty of disabled tests.
ifdef ASDF_TEST_SYSTEMS
s ?= ${ASDF_TEST_SYSTEMS}
else
s ?= fare-all
endif
l ?= sbcl l ?= sbcl
...@@ -38,7 +43,7 @@ XCL ?= xcl ...@@ -38,7 +43,7 @@ XCL ?= xcl
header_lisp := header.lisp header_lisp := header.lisp
driver_lisp := package.lisp common-lisp.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp driver_lisp := package.lisp common-lisp.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
defsystem_lisp := upgrade.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp defsystem_lisp := upgrade.lisp component.lisp system.lisp stamp-cache.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp
# Making ASDF itself should be our first, default, target: # Making ASDF itself should be our first, default, target:
build/asdf.lisp: $(wildcard *.lisp) build/asdf.lisp: $(wildcard *.lisp)
...@@ -128,17 +133,21 @@ test-lisp: build/asdf.lisp ...@@ -128,17 +133,21 @@ test-lisp: build/asdf.lisp
@cd test; ${MAKE} clean;./run-tests.sh ${l} ${t} @cd test; ${MAKE} clean;./run-tests.sh ${l} ${t}
t: test-lisp t: test-lisp
test: test-lisp test-clean-load doc test: test-lisp test-clean-load test-load-systems doc
test-load-systems:
./test/run-tests.sh -l ${l} ${s}
test-all-lisps: test-all-lisps:
${MAKE} test-load-systems
@for lisp in ${lisps} ; do \ @for lisp in ${lisps} ; do \
${MAKE} test-lisp test-upgrade l=$$lisp || exit 1 ; \ ${MAKE} test-lisp test-upgrade test-clean-load l=$$lisp || exit 1 ; \
done done
# test upgrade is a very long run... This does just the regression tests # test upgrade is a very long run... This does just the regression tests
test-all-noupgrade: test-all-noupgrade:
@for lisp in ${lisps} ; do \ @for lisp in ${lisps} ; do \
${MAKE} test-lisp l=$$lisp || exit 1 ; \ ${MAKE} test-lisp test-clean-load l=$$lisp || exit 1 ; \
done done
test-all-upgrade: test-all-upgrade:
......
...@@ -14,8 +14,9 @@ ...@@ -14,8 +14,9 @@
;; Note that it's polite to sort the defsystem forms in dependency order, ;; Note that it's polite to sort the defsystem forms in dependency order,
;; and compulsory to sort them in defsystem-depends-on order. ;; and compulsory to sort them in defsystem-depends-on order.
:version (:read-file-form "version.lisp-expr") :version (:read-file-form "version.lisp-expr")
:around-compile call-without-redefinition-warnings ;; we need be the same as asdf-driver
:components :components
((:static-file "header.lisp"))) ((:file "header")))
#+asdf2.27 #+asdf2.27
(defsystem :asdf/defsystem (defsystem :asdf/defsystem
...@@ -31,17 +32,18 @@ ...@@ -31,17 +32,18 @@
((:file "upgrade") ((:file "upgrade")
(:file "component" :depends-on ("upgrade")) (:file "component" :depends-on ("upgrade"))
(:file "system" :depends-on ("component")) (:file "system" :depends-on ("component"))
(:file "find-system" :depends-on ("system")) (:file "stamp-cache" :depends-on ("upgrade"))
(:file "find-system" :depends-on ("system" "stamp-cache"))
(:file "find-component" :depends-on ("find-system")) (:file "find-component" :depends-on ("find-system"))
(:file "operation" :depends-on ("upgrade")) (:file "operation" :depends-on ("upgrade"))
(:file "action" :depends-on ("find-component" "operation")) (:file "action" :depends-on ("find-component" "operation"))
(:file "lisp-action" :depends-on ("action")) (:file "lisp-action" :depends-on ("action"))
(:file "plan" :depends-on ("lisp-action")) (:file "plan" :depends-on ("lisp-action" "stamp-cache"))
(:file "operate" :depends-on ("plan")) (:file "operate" :depends-on ("plan"))
(:file "output-translations" :depends-on ("operate")) (:file "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system")) (:file "source-registry" :depends-on ("find-system"))
(:file "backward-internals" :depends-on ("lisp-action" "operate")) (:file "backward-internals" :depends-on ("lisp-action" "operate"))
(:file "defsystem" :depends-on ("backward-internals")) (:file "defsystem" :depends-on ("backward-internals" "stamp-cache"))
(:file "bundle" :depends-on ("lisp-action")) (:file "bundle" :depends-on ("lisp-action"))
(:file "concatenate-source" :depends-on ("bundle")) (:file "concatenate-source" :depends-on ("bundle"))
(:file "backward-interface" :depends-on ("operate" "output-translations")) (:file "backward-interface" :depends-on ("operate" "output-translations"))
...@@ -57,7 +59,7 @@ ...@@ -57,7 +59,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.144" ;; to be automatically updated by make bump-version :version "2.26.145" ;; to be automatically updated by make bump-version
:depends-on () :depends-on ()
:components :components
((:module "build" ((:module "build"
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/defsystem (asdf/package:define-package :asdf/defsystem
(:recycle :asdf/defsystem :asdf) (:recycle :asdf/defsystem :asdf)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/component :asdf/system :asdf/stamp-cache
:asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
:asdf/backward-internals) :asdf/backward-internals)
(:export (:export
...@@ -175,7 +175,7 @@ ...@@ -175,7 +175,7 @@
(source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
(registered (system-registered-p name)) (registered (system-registered-p name))
(registered! (if registered (registered! (if registered
(rplaca registered (safe-file-write-date source-file)) (rplaca registered (get-file-stamp source-file))
(register-system (register-system
(make-instance 'system :name name :source-file source-file)))) (make-instance 'system :name name :source-file source-file))))
(system (reset-system (cdr registered!) (system (reset-system (cdr registered!)
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/find-system (asdf/package:define-package :asdf/find-system
(:recycle :asdf/find-system :asdf) (:recycle :asdf/find-system :asdf)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system) :asdf/component :asdf/system :asdf/stamp-cache)
(:export (:export
#:remove-entry-from-registry #:coerce-entry-to-directory #:remove-entry-from-registry #:coerce-entry-to-directory
#:coerce-name #:primary-system-name #:coerce-name #:primary-system-name
...@@ -93,7 +93,7 @@ of which is a system object.") ...@@ -93,7 +93,7 @@ of which is a system object.")
(unless (eq system (cdr (gethash name *defined-systems*))) (unless (eq system (cdr (gethash name *defined-systems*)))
(setf (gethash name *defined-systems*) (setf (gethash name *defined-systems*)
(cons (if-let (file (ignore-errors (system-source-file system))) (cons (if-let (file (ignore-errors (system-source-file system)))
(safe-file-write-date file)) (get-file-stamp file))
system))))) system)))))
(defun* clear-system (name) (defun* clear-system (name)
...@@ -243,9 +243,9 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -243,9 +243,9 @@ Going forward, we recommend new users should be using the source-registry.
(defun* call-with-system-definitions (thunk) (defun* call-with-system-definitions (thunk)
(if *systems-being-defined* (if *systems-being-defined*
(funcall thunk) (call-with-stamp-cache thunk)
(let ((*systems-being-defined* (make-hash-table :test 'equal))) (let ((*systems-being-defined* (make-hash-table :test 'equal)))
(funcall thunk)))) (call-with-stamp-cache thunk))))
(defmacro with-system-definitions ((&optional) &body body) (defmacro with-system-definitions ((&optional) &body body)
`(call-with-system-definitions #'(lambda () ,@body))) `(call-with-system-definitions #'(lambda () ,@body)))
...@@ -316,7 +316,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -316,7 +316,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(pathname-equal (pathname-equal
(translate-logical-pathname pathname) (translate-logical-pathname pathname)
(translate-logical-pathname previous-pathname)))) (translate-logical-pathname previous-pathname))))
(stamp<= (safe-file-write-date pathname) previous-time)))) (stamp<= (get-file-stamp pathname) previous-time))))
;; only load when it's a pathname that is different or has newer content ;; only load when it's a pathname that is different or has newer content
(load-sysdef name pathname))) (load-sysdef name pathname)))
(let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
...@@ -324,7 +324,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -324,7 +324,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(cond (cond
(in-memory (in-memory
(when pathname (when pathname
(setf (car in-memory) (safe-file-write-date pathname))) (setf (car in-memory) (get-file-stamp pathname)))
(cdr in-memory)) (cdr in-memory))
(error-p (error-p
(error 'missing-component :requires name)))))) (error 'missing-component :requires name))))))
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.26.144: Another System Definition Facility. ;;; This is ASDF 2.26.145: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -10,7 +10,7 @@ ...@@ -10,7 +10,7 @@
#:split #:make-collector #:split #:make-collector
#:loaded-systems ; makes for annoying SLIME completion #:loaded-systems ; makes for annoying SLIME completion
#:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/stamp-cache
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/component :asdf/system :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action :asdf/lisp-action :asdf/operation :asdf/action :asdf/lisp-action
:asdf/output-translations :asdf/source-registry :asdf/output-translations :asdf/source-registry
......
...@@ -4,7 +4,8 @@ ...@@ -4,7 +4,8 @@
(asdf/package:define-package :asdf/plan (asdf/package:define-package :asdf/plan
(:recycle :asdf/plan :asdf) (:recycle :asdf/plan :asdf)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/operation :asdf/system :asdf/find-system :asdf/find-component :asdf/component :asdf/operation :asdf/system
:asdf/stamp-cache :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action) :asdf/operation :asdf/action)
(:export (:export
#:component-operation-time #:mark-operation-done #:component-operation-time #:mark-operation-done
...@@ -196,7 +197,7 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -196,7 +197,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
stamp) stamp)
(defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)
;; In a distant future, safe-file-write-date and component-operation-time ;; In a distant future, get-file-stamp and component-operation-time
;; shall also be parametrized by the plan, or by a second model object. ;; shall also be parametrized by the plan, or by a second model object.
(let* ((stamp-lookup #'(lambda (o c) (let* ((stamp-lookup #'(lambda (o c)
(if-let (it (plan-action-status plan o c)) (action-stamp it) t))) (if-let (it (plan-action-status plan o c)) (action-stamp it) t)))
...@@ -211,8 +212,8 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -211,8 +212,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
;; Accumulated timestamp from dependencies (or T if forced or out-of-date) ;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
(dep-stamp (visit-dependencies plan o c stamp-lookup)) (dep-stamp (visit-dependencies plan o c stamp-lookup))
;; Time stamps from the files at hand, and whether any is missing ;; Time stamps from the files at hand, and whether any is missing
(out-stamps (mapcar #'safe-file-write-date out-files)) (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
(in-stamps (mapcar #'safe-file-write-date in-files)) (in-stamps (mapcar #'get-file-stamp in-files))
(missing-in (missing-in
(loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
(missing-out (missing-out
......
;;;; -------------------------------------------------------------------------
;;;; Stamp cache
(asdf/package:define-package :asdf/stamp-cache
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:call-with-stamp-cache #:with-stamp-cache #:*stamp-cache*))
(in-package :asdf/stamp-cache)
;;; This stamp cache is useful for:
;; * consistency of stamps used within a single run
;; * fewer accesses to the filesystem
;; * the ability to test with fake timestamps, without touching files
(defvar *stamp-cache* nil)
(defun compute-file-stamp (file)
(safe-file-write-date file))
(defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
(if *stamp-cache*
(setf (gethash file *stamp-cache*) stamp)
stamp))
(defun get-file-stamp (file)
(if *stamp-cache*
(multiple-value-bind (stamp foundp) (gethash file *stamp-cache*)
(if foundp
stamp
(register-file-stamp file)))
(compute-file-stamp file)))
(defun call-with-stamp-cache (thunk &key override)
(if (and *stamp-cache* (not override))
(funcall thunk)
(let ((*stamp-cache* (make-hash-table :test 'equal)))
(funcall thunk))))
(defmacro with-stamp-cache ((&key override) &body body)
`(call-with-stamp-cache #'(lambda () ,@body) :override ,override))
...@@ -17,11 +17,13 @@ usage () { ...@@ -17,11 +17,13 @@ usage () {
echo " -d -- debug mode" echo " -d -- debug mode"
echo " -h -- show this message." echo " -h -- show this message."
echo " -u -- upgrade tests." echo " -u -- upgrade tests."
echo " -c -- clean load test"
echo " -l -- load systems tests"
} }
unset DEBUG_ASDF_TEST upgrade clean_load unset DEBUG_ASDF_TEST upgrade clean_load load_systems
while getopts "duhc" OPTION while getopts "cdhulhu" OPTION
do do
case $OPTION in case $OPTION in
d) d)
...@@ -33,6 +35,9 @@ do ...@@ -33,6 +35,9 @@ do
c) c)
clean_load=t clean_load=t
;; ;;
l)
load_systems=t
;;
h) h)
usage usage
exit 1 exit 1
...@@ -354,11 +359,21 @@ test_clean_load () { ...@@ -354,11 +359,21 @@ test_clean_load () {
echo "BAD: Loading ASDF on $lisp produces messages" >&2 ; return 1 echo "BAD: Loading ASDF on $lisp produces messages" >&2 ; return 1
fi fi
} }
test_load_systems () {
case $lisp in
gcl) return 0 ;; # This one is hopeless
esac
${cmd} ${eval} \
"(or #.(load \"test/script-support.lisp\") #.(asdf-test::with-test () (asdf-test::test-load-systems ${s})))" \
2>&1 | tee build/results/${lisp}-systems.text
}
if [ -z "$cmd" ] ; then if [ -z "$cmd" ] ; then
echo "Error: cannot find or do not know how to run Lisp named $lisp" echo "Error: cannot find or do not know how to run Lisp named $lisp"
elif [ -n "$clean_load" ] ; then elif [ -n "$clean_load" ] ; then
test_clean_load test_clean_load
elif [ -n "$load_systems" ] ; then
test_load_systems
elif [ -n "$upgrade" ] ; then elif [ -n "$upgrade" ] ; then
run_upgrade_tests run_upgrade_tests
else else
......
...@@ -13,7 +13,7 @@ Some constraints: ...@@ -13,7 +13,7 @@ Some constraints:
(defpackage :asdf-test (defpackage :asdf-test
(:use :common-lisp) (:use :common-lisp)
(:export (:export
#:asym #:acall #:asym #:acall #:asymval
#:*test-directory* #:*asdf-directory* #:*test-directory* #:*asdf-directory*
#:load-asdf #:maybe-compile-asdf #:load-asdf #:maybe-compile-asdf
#:load-asdf-lisp #:compile-asdf #:load-asdf-fasl #:load-asdf-lisp #:compile-asdf #:load-asdf-fasl
...@@ -75,13 +75,23 @@ Some constraints: ...@@ -75,13 +75,23 @@ Some constraints:
(namestring (make-pathname :name nil :type nil :defaults path)))))) (namestring (make-pathname :name nil :type nil :defaults path))))))
;;; Survival utilities ;;; Survival utilities
(defun asym (name) (defun asym (name &optional package (errorp t))
(let ((asdf (find-package :asdf))) (let* ((pname (or package :asdf))
(unless asdf (error "Can't find package ASDF")) (package (find-package pname)))
(or (find-symbol (string name) asdf) (if package
(error "Can't find symbol ~A in ASDF" name)))) (or (find-symbol (string name) package)
(when errorp (error "Can't find symbol ~A in ~A" name pname)))
(when errorp (error "Can't find package ~A" pname)))))
(defun acall (name &rest args) (defun acall (name &rest args)
(apply (asym name) args)) (apply (apply 'asym (if (consp name) name (list name))) 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
(let ((sym (gensym "SYM")))
`(let ((,sym (asym ,name ,package)))
(if ,sym
(setf (symbol-value ,sym) ,new-value)
(error "NIHIL EX NIHILO")))))
(defun finish-outputs* () (defun finish-outputs* ()
(loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*) (loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*)
...@@ -93,7 +103,49 @@ Some constraints: ...@@ -93,7 +103,49 @@ Some constraints:
(redirect-outputs) ;; Put everything on standard output, for the sake of scripts (redirect-outputs) ;; Put everything on standard output, for the sake of scripts
;;; First, some pathname madness. ;;; Helpful for debugging
(defun pathname-components (p)
(when p
(let ((p (pathname p)))
(list :host (pathname-host p)
:device (pathname-device p)
:directory (pathname-directory p)
:name (pathname-name p)
:type (pathname-type p)
:version (pathname-version p)))))
(defun assert-pathname-equal-helper (qx x qy y)
(cond
((equal x y)
(format t "~S and ~S both evaluate to same path:~% ~S~%" qx qy x))
((acall :pathname-equal x y)
(format t "These two expressions yield pathname-equal yet not equal path~% ~S~%" x)
(format t "the first expression ~S yields this:~% ~S~%" qx (pathname-components x))
(format t "the other expression ~S yields that:~% ~S~%" qy (pathname-components y)))
(t
(format t "These two expressions yield paths that are not pathname-equal~%")
(format t "the first expression ~S yields this:~% ~S~% ~S~%" qx x (pathname-components x))
(format t "the other expression ~S yields that:~% ~S~% ~S~%" qy y (pathname-components y)))))
(defmacro assert-pathname-equal (x y)
`(assert-pathname-equal-helper ',x ,x ',y ,y))
(defun assert-length-equal-helper (qx qy x y)
(unless (= (length x) (length y))
(format t "These two expressions yield sequences of unequal length~%")
(format t "The first, ~S, has value ~S of length ~S~%" qx x (length x))
(format t "The other, ~S, has value ~S of length ~S~%" qy y (length y))))
(defun assert-pathnames-equal-helper (qx x qy y)
(assert-length-equal-helper qx x qy y)
(loop :for n :from 0
:for qpx = `(nth ,n ,qx)
:for qpy = `(nth ,n ,qy)
:for px :in x
:for py :in y :do
(assert-pathname-equal-helper qpx px qpy py)))
(defmacro assert-pathnames-equal (x y)
`(assert-pathnames-equal-helper ',x ,x ',y ,y))
;; More pathname madness.
;; We can't use goodies from asdf/pathnames because ASDF isn't loaded yet. ;; We can't use goodies from asdf/pathnames because ASDF isn't loaded yet.
;; We still want to work despite and host/device funkiness, ;; We still want to work despite and host/device funkiness,
;; so we do it the hard way. ;; so we do it the hard way.
...@@ -143,7 +195,6 @@ Some constraints: ...@@ -143,7 +195,6 @@ Some constraints:
(defun asdf-fasl (&optional tag) (defun asdf-fasl (&optional tag)
(early-compile-file-pathname (asdf-lisp tag))) (early-compile-file-pathname (asdf-lisp tag)))
;;; Test helper functions ;;; Test helper functions
(load (debug-lisp)) (load (debug-lisp))
...@@ -155,21 +206,29 @@ Some constraints: ...@@ -155,21 +206,29 @@ Some constraints:
(defun assert-compare-helper (op qx qy x y) (defun assert-compare-helper (op qx qy x y)
(unless (funcall op x y) (unless (funcall op x y)
(error "These two expressions fail comparison with ~S:~%~ (error "These two expressions fail comparison with ~S:~% ~
~S evaluates to ~S~% ~S evaluates to ~S~%" ~S evaluates to ~S~% ~S evaluates to ~S~%"
op qx x qy y))) op qx x qy y)))
(defmacro assert-equal (x y) (defmacro assert-equal (x y)
`(assert-compare (equal ,x ,y))) `(assert-compare (equal ,x ,y)))
(defun touch-file (file &key (offset 0) timestamp) (defun touch-file (file &key offset timestamp)
(let ((timestamp (or timestamp (+ offset (get-universal-time))))) (let* ((base (or timestamp (get-universal-time)))
(multiple-value-bind (sec min hr day month year) (decode-universal-time timestamp #+gcl2.6 -5) (stamp (if offset (+ base offset) base)))
(acall :run-program (if (asymval :*stamp-cache*)
`("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D" (acall :register-file-stamp file stamp)
year month day hr min sec) (multiple-value-bind (sec min hr day month year)
,(namestring file))) (decode-universal-time stamp #+gcl2.6 -5) ;; -5 is for *my* localtime
(assert-equal (file-write-date file) timestamp)))) (error "Y U NO use stamp cache?")
(acall :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)))
(assert-equal (file-write-date file) stamp)))))
(defun mark-file-deleted (file)
(unless (asymval :*stamp-cache*) (error "Y U NO use stamp cache?"))
(acall :register-file-stamp file nil))
(defun hash-table->alist (table) (defun hash-table->alist (table)
(loop :for key :being :the :hash-keys :of table :using (:hash-value value) (loop :for key :being :the :hash-keys :of table :using (:hash-value value)
...@@ -231,7 +290,7 @@ is bound, write a message and exit on an error. If ...@@ -231,7 +290,7 @@ is bound, write a message and exit on an error. If
(acall :print-condition-backtrace (acall :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 thunk) (funcall (or (asym :call-with-stamp-cache :asdf nil) 'funcall) thunk)
(leave-test "Script succeeded" 0))))) (leave-test "Script succeeded" 0)))))
(when *quit-when-done* (when *quit-when-done*
(exit-lisp result)))) (exit-lisp result))))
...@@ -421,13 +480,23 @@ is bound, write a message and exit on an error. If ...@@ -421,13 +480,23 @@ is bound, write a message and exit on an error. If
:ignore-inherited-configuration)) :ignore-inherited-configuration))
(set (asym :*central-registry*) `(,*test-directory*)) (set (asym :*central-registry*) `(,*test-directory*))
(set (asym :*verbose-out*) *standard-output*) (set (asym :*verbose-out*) *standard-output*)
(set (asym :*asdf-verbose*) t)) (set (asym :*asdf-verbose*) t)
(let ((x (acall :system-source-directory :hello-world-example)))
(assert-pathname-equal *test-directory* x) ;; not always EQUAL (!)
(unless (equal *test-directory* x)
(format t "Interestingly, while *test-directory* has components~% ~S~%~
ASDF finds the ASDs in~% ~S~%Using the latter.~%"
(pathname-components *test-directory*)
(pathname-components x)))
(setf *test-directory* x))
t)
(defun load-asdf (&optional tag) (defun load-asdf (&optional tag)
#+gcl2.6 (load-asdf-lisp tag) #-gcl2.6 #+gcl2.6 (load-asdf-lisp tag) #-gcl2.6
(load-asdf-fasl tag) (load-asdf-fasl tag)
(use-package :asdf :asdf-test) (use-package :asdf :asdf-test)
(use-package :asdf/driver :asdf-test) (use-package :asdf/driver :asdf-test)
(use-package :asdf/stamp-cache :asdf-test)
(configure-asdf) (configure-asdf)
(setf *package* (find-package :asdf-test))) (setf *package* (find-package :asdf-test)))
...@@ -449,48 +518,15 @@ is bound, write a message and exit on an error. If ...@@ -449,48 +518,15 @@ is bound, write a message and exit on an error. If