From c2c175585c61206ac16f03de5c2019071d11d060 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Thu, 24 Jan 2013 15:21:05 -0500 Subject: [PATCH] 2.26.145: introduce a stamp cache, to reduce filesystem access, enhance plan consistency and make testing easier. --- Makefile | 17 +++- asdf.asd | 12 ++- defsystem.lisp | 4 +- find-system.lisp | 12 +-- header.lisp | 2 +- interface.lisp | 2 +- plan.lisp | 9 +- stamp-cache.lisp | 40 ++++++++ test/run-tests.sh | 19 +++- test/script-support.lisp | 158 ++++++++++++++++++----------- test/test-encodings.script | 22 ++-- test/test-force.script | 12 +-- test/test-static-and-serial.script | 6 +- test/test-sysdef-asdf.script | 12 +-- test/test-touch-system-1.script | 31 +++--- test/test-touch-system-2.script | 36 +++---- test/test1.script | 55 +++++----- upgrade.lisp | 2 +- version.lisp-expr | 2 +- 19 files changed, 283 insertions(+), 170 deletions(-) create mode 100644 stamp-cache.lisp diff --git a/Makefile b/Makefile index e3d4dee77..c60e263e6 100644 --- a/Makefile +++ b/Makefile @@ -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: diff --git a/asdf.asd b/asdf.asd index 0e6ec6add..c60c43495 100644 --- a/asdf.asd +++ b/asdf.asd @@ -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" diff --git a/defsystem.lisp b/defsystem.lisp index f6f42f7a3..9b6de6dc2 100644 --- a/defsystem.lisp +++ b/defsystem.lisp @@ -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!) diff --git a/find-system.lisp b/find-system.lisp index 028fa5dfb..eb28230ff 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -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)))))) diff --git a/header.lisp b/header.lisp index e07a054d2..77ac05262 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;; -*- 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>. diff --git a/interface.lisp b/interface.lisp index b446a0cfd..8fb39ab82 100644 --- a/interface.lisp +++ b/interface.lisp @@ -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 diff --git a/plan.lisp b/plan.lisp index 9a1c9f7b4..4d70a0bef 100644 --- a/plan.lisp +++ b/plan.lisp @@ -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 diff --git a/stamp-cache.lisp b/stamp-cache.lisp new file mode 100644 index 000000000..b2806abb2 --- /dev/null +++ b/stamp-cache.lisp @@ -0,0 +1,40 @@ +;;;; ------------------------------------------------------------------------- +;;;; 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)) diff --git a/test/run-tests.sh b/test/run-tests.sh index 71ef084a4..2952e732f 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -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 diff --git a/test/script-support.lisp b/test/script-support.lisp index cd7f171bd..9c6dccd45 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -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 diff --git a/test/test-encodings.script b/test/test-encodings.script index 25bf4a724..d0ad897d9 100644 --- a/test/test-encodings.script +++ b/test/test-encodings.script @@ -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")))) diff --git a/test/test-force.script b/test/test-force.script index 014a4d172..8404b7b49 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -1,8 +1,6 @@ ;;; -*- 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)) diff --git a/test/test-static-and-serial.script b/test/test-static-and-serial.script index e075e40ca..504fa9613 100644 --- a/test/test-static-and-serial.script +++ b/test/test-static-and-serial.script @@ -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) diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script index 60f0c7113..a1bf114d3 100644 --- a/test/test-sysdef-asdf.script +++ b/test/test-sysdef-asdf.script @@ -1,9 +1,9 @@ ;;; -*- 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) diff --git a/test/test-touch-system-1.script b/test/test-touch-system-1.script index cd218634a..b95eadb70 100644 --- a/test/test-touch-system-1.script +++ b/test/test-touch-system-1.script @@ -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)) diff --git a/test/test-touch-system-2.script b/test/test-touch-system-2.script index 106598109..cb9b6cd30 100644 --- a/test/test-touch-system-2.script +++ b/test/test-touch-system-2.script @@ -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)) diff --git a/test/test1.script b/test/test1.script index 4b25d4495..026dc1465 100644 --- a/test/test1.script +++ b/test/test1.script @@ -1,38 +1,43 @@ ;;; -*- 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) +(touch-file file2.lisp :timestamp *date* :offset 200) +(assert-equal (get-file-stamp file1.lisp) (+ *date* 100)) +(assert-equal (get-file-stamp file2.lisp) (+ *date* 200)) (DBG "loading test1") (load-system 'test1) -(defparameter *file1.out* (output-files 'compile-op '(test1 "file1"))) -(defparameter *file2.out* (output-files 'compile-op '(test1 "file2"))) -(assert-equal (first *file1.out*) (test-fasl "file1")) -(assert-equal (first *file2.out*) (test-fasl "file2")) - -(assert-equal *date* (file-write-date (test-source "test1.asd"))) (defparameter *then* (file-write-date (first *file2.out*))) -(assert-compare (< *date* *then*)) +(assert-compare (<= (+ *date* 3600) *then*)) (DBG "test that it compiled" *date* *then*) (dolist (f (append *file1.out* *file2.out*)) (eval `(assert (probe-file ,f)))) (DBG "and loaded") -(assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) +(assert (asymval :*file1* :test-package)) (DBG "now remove file2 that depends-on file1") (dolist (f *file1.out*) (touch-file f :timestamp (+ *date* 500))) -(assert-equal (+ *date* 500) (file-write-date (first *file1.out*))) -(map () 'delete-file-if-exists *file2.out*) +(assert-equal (+ *date* 500) (get-file-stamp file1.fasl)) +(map () 'mark-file-deleted *file2.out*) (clear-system 'test1) (DBG "load again") @@ -42,17 +47,17 @@ (assert (in-plan-p *plan* '(compile-op "test1" "file2"))) (assert (not (in-plan-p *plan* '(compile-op "test1" "file1")))) -(assert-equal (+ *date* 500) (file-write-date (first *file1.out*))) -(assert-compare (<= *then* (file-write-date (first *file2.out*)))) +(assert-equal (+ *date* 500) (get-file-stamp file1.fasl)) +(defparameter *before* (get-file-stamp file2.fasl)) +(assert-compare (<= *then* *before*)) (DBG "now touch file1 and check that file2 _is_ also recompiled") ;; XXX run-shell-command loses if *default-pathname-defaults* is not the ;; unix cwd. this is not a problem for run-tests.sh, but can be in general -(defparameter *before* (file-write-date (first *file2.out*))) -(touch-file (test-source "file1.lisp") :timestamp (+ *date* 3000)) ;; touch file1 a minute ago. +(touch-file file1.lisp :timestamp (+ *date* 3000)) ;; touch file1 a minute ago. (dolist (f *file2.out*) (touch-file f :timestamp (+ *date* 2000))) ;; touch file2.fasl some time before. (asdf:clear-system 'test1) (asdf:operate 'asdf:load-op 'test1) -(DBG :foo (file-write-date (first *file2.out*)) *before*) -(assert-compare (>= (file-write-date (first *file2.out*)) *before*)) +(DBG :foo (file-write-date file2.fasl) *before*) +(assert-compare (>= (file-write-date file2.fasl) *before*)) diff --git a/upgrade.lisp b/upgrade.lisp index 2511df285..9a474e4cd 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -35,7 +35,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.144") + (asdf-version "2.26.145") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version)) diff --git a/version.lisp-expr b/version.lisp-expr index fb113c1ec..a9f10eea6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.144" +"2.26.145" -- GitLab