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

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
## Some are manually tested once in a while.
## 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.
ifdef ASDF_TEST_SYSTEMS
s ?= ${ASDF_TEST_SYSTEMS}
else
s ?= fare-all
endif
l ?= sbcl
......@@ -38,7 +43,7 @@ XCL ?= xcl
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
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:
build/asdf.lisp: $(wildcard *.lisp)
......@@ -128,17 +133,21 @@ test-lisp: build/asdf.lisp
@cd test; ${MAKE} clean;./run-tests.sh ${l} ${t}
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:
${MAKE} test-load-systems
@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
# test upgrade is a very long run... This does just the regression tests
test-all-noupgrade:
@for lisp in ${lisps} ; do \
${MAKE} test-lisp l=$$lisp || exit 1 ; \
${MAKE} test-lisp test-clean-load l=$$lisp || exit 1 ; \
done
test-all-upgrade:
......
......@@ -14,8 +14,9 @@
;; Note that it's polite to sort the defsystem forms in dependency order,
;; and compulsory to sort them in defsystem-depends-on order.
:version (:read-file-form "version.lisp-expr")
:around-compile call-without-redefinition-warnings ;; we need be the same as asdf-driver
:components
((:static-file "header.lisp")))
((:file "header")))
#+asdf2.27
(defsystem :asdf/defsystem
......@@ -31,17 +32,18 @@
((:file "upgrade")
(:file "component" :depends-on ("upgrade"))
(: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 "operation" :depends-on ("upgrade"))
(:file "action" :depends-on ("find-component" "operation"))
(: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 "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system"))
(: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 "concatenate-source" :depends-on ("bundle"))
(:file "backward-interface" :depends-on ("operate" "output-translations"))
......@@ -57,7 +59,7 @@
:licence "MIT"
:description "Another System Definition Facility"
: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 ()
:components
((:module "build"
......
......@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/defsystem
(:recycle :asdf/defsystem :asdf)
(: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/backward-internals)
(:export
......@@ -175,7 +175,7 @@
(source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
(registered (system-registered-p name))
(registered! (if registered
(rplaca registered (safe-file-write-date source-file))
(rplaca registered (get-file-stamp source-file))
(register-system
(make-instance 'system :name name :source-file source-file))))
(system (reset-system (cdr registered!)
......
......@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/find-system
(:recycle :asdf/find-system :asdf)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system)
:asdf/component :asdf/system :asdf/stamp-cache)
(:export
#:remove-entry-from-registry #:coerce-entry-to-directory
#:coerce-name #:primary-system-name
......@@ -93,7 +93,7 @@ of which is a system object.")
(unless (eq system (cdr (gethash name *defined-systems*)))
(setf (gethash name *defined-systems*)
(cons (if-let (file (ignore-errors (system-source-file system)))
(safe-file-write-date file))
(get-file-stamp file))
system)))))
(defun* clear-system (name)
......@@ -243,9 +243,9 @@ Going forward, we recommend new users should be using the source-registry.
(defun* call-with-system-definitions (thunk)
(if *systems-being-defined*
(funcall thunk)
(call-with-stamp-cache thunk)
(let ((*systems-being-defined* (make-hash-table :test 'equal)))
(funcall thunk))))
(call-with-stamp-cache thunk))))
(defmacro with-system-definitions ((&optional) &body 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.
(pathname-equal
(translate-logical-pathname 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
(load-sysdef name pathname)))
(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.
(cond
(in-memory
(when pathname
(setf (car in-memory) (safe-file-write-date pathname)))
(setf (car in-memory) (get-file-stamp pathname)))
(cdr in-memory))
(error-p
(error 'missing-component :requires name))))))
......
;; -*- 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:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -10,7 +10,7 @@
#:split #:make-collector
#:loaded-systems ; makes for annoying SLIME completion
#: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/operation :asdf/action :asdf/lisp-action
:asdf/output-translations :asdf/source-registry
......
......@@ -4,7 +4,8 @@
(asdf/package:define-package :asdf/plan
(:recycle :asdf/plan :asdf)
(: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)
(:export
#:component-operation-time #:mark-operation-done
......@@ -196,7 +197,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
stamp)
(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.
(let* ((stamp-lookup #'(lambda (o c)
(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"))
;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
(dep-stamp (visit-dependencies plan o c stamp-lookup))
;; Time stamps from the files at hand, and whether any is missing
(out-stamps (mapcar #'safe-file-write-date out-files))
(in-stamps (mapcar #'safe-file-write-date in-files))
(out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
(in-stamps (mapcar #'get-file-stamp in-files))
(missing-in
(loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
(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 () {
echo " -d -- debug mode"
echo " -h -- show this message."
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
case $OPTION in
d)
......@@ -33,6 +35,9 @@ do
c)
clean_load=t
;;
l)
load_systems=t
;;
h)
usage
exit 1
......@@ -354,11 +359,21 @@ test_clean_load () {
echo "BAD: Loading ASDF on $lisp produces messages" >&2 ; return 1
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
echo "Error: cannot find or do not know how to run Lisp named $lisp"
elif [ -n "$clean_load" ] ; then
test_clean_load
elif [ -n "$load_systems" ] ; then
test_load_systems
elif [ -n "$upgrade" ] ; then
run_upgrade_tests
else
......
......@@ -13,7 +13,7 @@ Some constraints:
(defpackage :asdf-test
(:use :common-lisp)
(:export
#:asym #:acall
#:asym #:acall #:asymval
#:*test-directory* #:*asdf-directory*
#:load-asdf #:maybe-compile-asdf
#:load-asdf-lisp #:compile-asdf #:load-asdf-fasl
......@@ -75,13 +75,23 @@ Some constraints:
(namestring (make-pathname :name nil :type nil :defaults path))))))
;;; Survival utilities
(defun asym (name)
(let ((asdf (find-package :asdf)))
(unless asdf (error "Can't find package ASDF"))
(or (find-symbol (string name) asdf)
(error "Can't find symbol ~A in ASDF" name))))
(defun asym (name &optional package (errorp t))
(let* ((pname (or package :asdf))
(package (find-package pname)))
(if package
(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)
(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* ()
(loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*)
......@@ -93,7 +103,49 @@ Some constraints:
(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 still want to work despite and host/device funkiness,
;; so we do it the hard way.
......@@ -143,7 +195,6 @@ Some constraints:
(defun asdf-fasl (&optional tag)
(early-compile-file-pathname (asdf-lisp tag)))
;;; Test helper functions
(load (debug-lisp))
......@@ -155,21 +206,29 @@ Some constraints:
(defun assert-compare-helper (op qx qy 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~%"
op qx x qy y)))
(defmacro assert-equal (x y)
`(assert-compare (equal ,x ,y)))
(defun touch-file (file &key (offset 0) timestamp)
(let ((timestamp (or timestamp (+ offset (get-universal-time)))))
(multiple-value-bind (sec min hr day month year) (decode-universal-time timestamp #+gcl2.6 -5)
(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)
,(namestring file)))
(assert-equal (file-write-date file) timestamp))))
(defun touch-file (file &key offset timestamp)
(let* ((base (or timestamp (get-universal-time)))
(stamp (if offset (+ base offset) base)))
(if (asymval :*stamp-cache*)
(acall :register-file-stamp file stamp)
(multiple-value-bind (sec min hr day month year)
(decode-universal-time stamp #+gcl2.6 -5) ;; -5 is for *my* localtime
(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)
(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
(acall :print-condition-backtrace
c :count 69 :stream *error-output*))
(leave-test "Script failed" 1))))))
(funcall thunk)
(funcall (or (asym :call-with-stamp-cache :asdf nil) 'funcall) thunk)
(leave-test "Script succeeded" 0)))))
(when *quit-when-done*
(exit-lisp result))))
......@@ -421,13 +480,23 @@ is bound, write a message and exit on an error. If
:ignore-inherited-configuration))
(set (asym :*central-registry*) `(,*test-directory*))
(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)
#+gcl2.6 (load-asdf-lisp tag) #-gcl2.6
(load-asdf-fasl tag)
(use-package :asdf :asdf-test)
(use-package :asdf/driver :asdf-test)
(use-package :asdf/stamp-cache :asdf-test)
(configure-asdf)
(setf *package* (find-package :asdf-test)))
......@@ -449,48 +518,15 @@ is bound, write a message and exit on an error. If
(defun in-plan-p (plan x) (member x plan :key (asym :action-path) :test 'equal))
;;; 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))
(defmacro test-load-systems (&rest x)
`(do-test-load-systems ',x))
(defun do-test-load-systems (systems)
(load-asdf-lisp)
(dolist (sys systems)
(format t "~&Trying to load ~A~%" sys)
(acall :load-system sys))
(format t "~&Done!~%"))
;; These are shorthands for interactive debugging of test scripts:
(!a
......
......@@ -19,19 +19,19 @@
#+sbcl sb-impl::*default-external-format*
#-(or clozure sbcl) (error "can't determine default external-format")))))
(defmacro with-encoding-test ((encoding &key (op 'asdf:load-source-op) (path "lambda")) def-test-system &body body)
(defmacro with-encoding-test ((encoding &key (op 'load-source-op) (path "lambda")) def-test-system &body body)
(let ((sys (second def-test-system)))
`(progn
`(with-stamp-cache (:override t)
(format t "~&Test ~A: should be ~A~%" ',sys ',encoding)
(setf *lambda-string* nil)
,def-test-system
(let ((c (asdf:find-component ',sys ',path)))
(let ((c (find-component ',sys ',path)))
;; mlisp has an issue of :LATIN-2 vs :latin-2. Smooth things with string-equal.
(assert-compare (string-equal (asdf:component-encoding c) ',encoding))
(loop :for o :in (asdf:output-files (asdf::make-operation 'asdf:compile-op) c)
:do (asdf::delete-file-if-exists o)))
(assert-compare (string-equal (component-encoding c) ',encoding))
(loop :for o :in (output-files 'compile-op c)
:do (delete-file-if-exists o)))
,@(when op
`((asdf:operate ',op ',(second def-test-system))))
`((operate ',op ',(second def-test-system))))
,@body
(eval `(assert-equal (string-char-codes ,*lambda-string*)
(expected-char-codes ',',encoding))))))
......@@ -72,7 +72,7 @@
(initialize-source-registry `(:source-registry :ignore-inherited-configuration))
(asdf:load-system :asdf-encodings)
(load-system :asdf-encodings)
#-lispworks
(with-encoding-test (:latin-2)
(def-test-system :test-encoding-implicit-autodetect
......@@ -90,11 +90,11 @@
(def-test-system :test-file-encoding-l1
:encoding :utf-8
:components ((:file "lambda" :encoding :latin-1))))
(with-encoding-test (:utf-8 :op asdf:load-source-op)
(with-encoding-test (:utf-8 :op load-source-op)
(def-test-system :test-system-encoding-u8
:encoding :utf-8
:components ((:file "lambda"))))
(with-encoding-test (:utf-8 :op asdf:load-op)
(with-encoding-test (:utf-8 :op load-op)
(def-test-system :test-system-encoding-u8-load-op
:encoding :utf-8
:components ((:file "lambda"))))
......@@ -103,7 +103,7 @@
:encoding :latin-1
:components ((:file "lambda"))))
#-ecl-bytecmp
(with-encoding-test (:latin-1 :op asdf:load-op)
(with-encoding-test (:latin-1 :op load-op)
(def-test-system :test-system-encoding-l1-load-op
:encoding :latin-1
:components ((:file "lambda"))))
......
;;; -*- Lisp -*-
(asdf:operate 'asdf:load-op 'test-force)
(load-system 'test-force)
(defparameter file1 (test-fasl "file1"))
(defparameter file1-date (file-write-date file1))
......@@ -16,9 +14,9 @@
(touch-file "test-force.asd" :timestamp date1)
(touch-file "file1.lisp" :timestamp date1)
(touch-file file1 :timestamp date2)
(asdf:operate 'asdf:load-op 'test-force)
(assert (equal (file-write-date file1) date2))
(load-system 'test-force)
(assert (equal (get-file-stamp file1) date2))
;; forced, it should be later
(asdf:operate 'asdf:load-op 'test-force :force t)
(assert (>= (file-write-date file1) file1-date))
(load-system 'test-force :force t)
(assert (>= (get-file-stamp file1) file1-date))
......@@ -26,7 +26,7 @@ don't cause full rebuilds all the time...
(defparameter date3 (- file1-date 150))
(assert file1-date)
(assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package)))
(assert (asymval :*file1* :test-package))
(format t "file: ~S~%date: ~S~%" file1 file1-date)
;; date should stay same
......@@ -38,5 +38,5 @@ don't cause full rebuilds all the time...
(touch-file "file1.lisp" :timestamp date2)
(touch-file file1 :timestamp date3)
(DBG "load again" (oos 'load-op 'static-and-serial))
(assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package)))
(assert-equal (file-write-date file1) date3)
(assert (asymval :*file1* :test-package))
(assert-equal (get-file-stamp file1) date3)
;;; -*- Lisp -*-
(initialize-source-registry
'(:source-registry :ignore-inherited-configuration))
(load-system :asdf)
(progn
(asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration))
(asdf:load-system :asdf)
(asdf:initialize-source-registry `(:source-registry (:directory ,*asdf-directory*) :ignore-inherited-configuration))
(asdf:load-system :asdf))
(initialize-source-registry
`(:source-registry (:directory ,*asdf-directory*) :ignore-inherited-configuration))
(load-system :asdf)
......@@ -3,24 +3,31 @@
;;; test system def reloading if touched
;;; system that can be found using *system-definition-search-functions*
(defun system-load-time (name)
(defun system-registered-time (name)
(if-let (data (asdf::system-registered-p name))
(car data)))
(defparameter file "test1.asd")
(defparameter date1 (file-write-date file))
(defparameter test1.asd (nth-value 2 (locate-system :test1)))
(assert-pathname-equal test1.asd (test-source "test1.asd"))
(defparameter file1.lisp (test-source "file1.lisp"))
(defparameter file2.lisp (test-source "file2.lisp"))
(defparameter file1.fasl (test-fasl "file1.lisp"))
(defparameter file2.fasl (test-fasl "file2.lisp"))
(defparameter date1 (get-file-stamp test1.asd))
(defparameter date2 (- date1 600))
(defparameter date3 (- date1 300))
(touch-file file :timestamp date2)
(asdf:find-system :test1)
(defparameter date4 (file-write-date (test-fasl "file1.lisp")))
(defparameter date5 (system-load-time :test1))
(DBG :blah date2 date3 date4 date5)
(touch-file test1.asd :timestamp date2)
(touch-file file1.lisp :timestamp date3)
(touch-file file2.lisp :timestamp date3)
(assert-equal nil (system-registered-time :test1))
(find-system :test1)
(defparameter date4 (get-file-stamp file2.fasl))
(defparameter date5 (system-registered-time :test1))
(DBG :blah date1 date2 date3 date4 date5)
(assert-equal date2 date5)
(assert-equal date2 date5)
(assert (>= date4 date3))
(sleep 1)
(touch-file file)
(touch-file test1.asd)
(find-system :test1)
(defparameter date6 (system-load-time :test1))
(defparameter date6 (system-registered-time :test1))
(assert (> date6 date4))
......@@ -3,23 +3,23 @@
;;; test system definition reloading if touched
;;; system that canNOT be found using *system-definition-search-functions*
(defun system-registered-time (name)
(let ((data (asdf::system-registered-p name)))
(when data
(car data))))
(defparameter test1.asd (nth-value 2 (locate-system :test1)))
(assert-pathname-equal test1.asd (test-source "test1.asd"))
(assert test1.asd)
(progn
(flet ((system-load-time (name)
(let ((data (asdf::system-registered-p name)))
(when data
(car data)))))
(setf asdf:*central-registry* nil)
(load "test1.asd")
(assert (find-system :test1))
(let ((date1 (system-load-time :test1))
(file "test1.asd"))
(assert date1)
(assert file)
(sleep 2)
(touch-file file)
(asdf:find-system :test1)
(let ((date2 (system-load-time :test1)))
(assert date2)
(assert (> date2 date1))))))
(setf asdf:*central-registry* nil)
(load test1.asd)
(assert (find-system :test1))
(defparameter date1 (system-registered-time :test1))
(assert date1)
(touch-file test1.asd :timestamp date1 :offset +2)
(find-system :test1)
;;(DBG :bloh (hash-table->alist asdf::*stamp-cache*))
(defparameter date2 (system-registered-time :test1))
(assert date2)
(assert (> date2 date1))
;;; -*- Lisp -*-
(touch-file (test-source "test1.asd") :offset -3600) ;; touch test1.asd an hour ago.
(defparameter *date* (file-write-date (test-source "test1.asd")))
(touch-file (test-source "file1.lisp") :timestamp (+ *date* 100))
(touch-file (test-source "file2.lisp") :timestamp (+ *date* 200))
(assert-equal (file-write-date (test-source "file1.lisp")) (+ *date* 100))
(assert-equal (file-write-date (test-source "file2.lisp")) (+ *date* 200))
;; We need use the pathnames used by ASDF.
(defparameter test1.asd (system-source-file 'test1))
(defparameter file1.lisp (component-pathname (find-component 'test1 "file1")))
(defparameter file2.lisp (component-pathname (find-component 'test1 "file2")))
(assert-equal test1.asd (test-source "test1.asd")) ; unhappily, not usually equal.
(assert-equal file1.lisp (test-source "file1.lisp")) ; unhappily, not usually equal.
(assert-equal file2.lisp (test-source "file2.lisp")) ; unhappily, not usually equal.
(defparameter *file1.out* (output-files 'compile-op '(test1 "file1")))
(defparameter *file2.out* (output-files 'compile-op '(test1 "file2")))
(defparameter file1.fasl (first *file1.out*))
(defparameter file2.fasl (first *file2.out*))
(assert-equal file1.fasl (test-fasl "file1"))
(assert-equal file2.fasl (test-fasl "file2"))
(defparameter *date* (- (file-write-date test1.asd) 3600))
(touch-file test1.asd :timestamp *date*) ;; touch test1.asd an hour back.
(touch-file file1.lisp :timestamp *date* :offset 100)