Commit 26714b10 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Tweak ASDF and tests to fix previous commit.

parent 65d72494
......@@ -4,7 +4,8 @@
(uiop/package:define-package :asdf/cache
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:set-asdf-cache-entry #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring
#:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
#:do-asdf-cache #:normalize-namestring
#:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
(in-package :asdf/cache)
......@@ -22,6 +23,10 @@
(setf (gethash key *asdf-cache*) value-list)
value-list)))
(defun unset-asdf-cache-entry (key)
(when *asdf-cache*
(remhash key *asdf-cache*)))
(defun consult-asdf-cache (key &optional thunk)
(if *asdf-cache*
(multiple-value-bind (results foundp) (gethash key *asdf-cache*)
......
......@@ -3,7 +3,7 @@
(uiop/package:define-package :asdf/find-component
(:recycle :asdf/find-component :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
:asdf/component :asdf/system :asdf/find-system)
(:export
#:find-component
......@@ -106,7 +106,12 @@
(or (null c)
(and (typep c 'missing-dependency)
(eq (missing-required-by c) component)
(equal (missing-requires c) name))))))))
(equal (missing-requires c) name))))
(unless (component-parent component)
(let ((name (coerce-name name)))
(unset-asdf-cache-entry `(find-system ,name))
(unset-asdf-cache-entry `(locate-system ,name))))))))
(defun resolve-dependency-spec (component dep-spec)
(let ((component (find-component () component)))
......
......@@ -18,7 +18,7 @@
#:find-system-if-being-defined
#:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
#:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
#:clear-defined-systems #:*defined-systems*
#:clear-defined-system #:clear-defined-systems #:*defined-systems*
#:*immutable-systems*
;; defined in source-registry, but specially mentioned here:
#:initialize-source-registry #:sysdef-source-registry-search))
......@@ -89,15 +89,18 @@ of which is a system object.")
(get-file-stamp file))
system)))))
(defun clear-defined-system (system)
(let ((name (coerce-name system)))
(remhash name *defined-systems*)
(unset-asdf-cache-entry `(locate-system ,name))
(unset-asdf-cache-entry `(find-system ,name))
nil))
(defun clear-defined-systems ()
;; Invalidate all systems but ASDF itself, if registered.
(let ((asdf (cdr (system-registered-p :asdf))))
(setf *defined-systems* (make-hash-table :test 'equal))
(when asdf
(setf (component-version asdf) *asdf-version*)
(setf (builtin-system-p asdf) t)
(register-system asdf)))
(values))
(loop :for name :being :the :hash-keys :of *defined-systems*
:unless (equal name "asdf")
:do (clear-defined-system name)))
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
......@@ -256,7 +259,7 @@ Going forward, we recommend new users should be using the source-registry.
(defun find-system-if-being-defined (name)
;; notable side effect: mark the system as being defined, to avoid infinite loops
(values (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
(first (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
(defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
;; Tries to load system definition with canonical NAME from PATHNAME.
......@@ -389,7 +392,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name)
(when (and found-system (eq found-system previous)
(or (gethash `(find-system ,name) *asdf-cache*)
(or (first (gethash `(find-system ,name) *asdf-cache*))
(and *immutable-systems* (gethash name *immutable-systems*))))
(return found-system))
(assert (eq foundp (and (or found-system pathname previous) t)))
......@@ -423,5 +426,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(reinitialize-source-registry-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
(unset-asdf-cache-entry `(locate-system ,name))
(initialize-source-registry)))))))
......@@ -23,4 +23,3 @@
(exe (asdf::output-file 'program-op :hello-world-example))
(dll-dest (subpathname exe dll-orig)))
(copy-file dll-orig dll-dest)))
......@@ -2,7 +2,7 @@
(DBG :foo (current-lisp-file-pathname))
(unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) gcl lispworks mkcl sbcl scl) t)
(unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t)
(DBG "Creating images is not supported on your CL implementation")
(leave-test "Skipping test" 0))
......@@ -38,24 +38,29 @@
0)
(assert (probe-file* img) () "Can't find image file ~S" img)
(assert-equal (run-program
(symbol-call :lisp-invocation :lisp-invocation-arglist
:image-path (native-namestring img)
:eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)")
:output :lines)
'("hello, world"))
(assert-equal
(nest
#+lispworks (last)
(run-program
(symbol-call :lisp-invocation :lisp-invocation-arglist
:image-path (native-namestring img)
:eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)")
:output :lines :error-output t))
'("hello, world"))
(assert-equal (run-program
(symbol-call :lisp-invocation :lisp-invocation-arglist
:image-path (native-namestring img)
:eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)"
:arguments '("a" "b c" "d"))
:output :lines)
'("hello, world"
"You passed 3 arguments:"
" \"a\""
" \"b c\""
" \"d\""))
#-(or lispworks scl) ;; These can't be passed arguments the normal way
(assert-equal
(run-program
(symbol-call :lisp-invocation :lisp-invocation-arglist
:image-path (native-namestring img)
:eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)"
:arguments '("a" "b c" "d"))
:output :lines :error-output t)
'("hello, world"
"You passed 3 arguments:"
" \"a\""
" \"b c\""
" \"d\""))
(DBG "test program-op")
(unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl) t
......@@ -80,10 +85,10 @@
(assert (probe-file* exe) () "Can't find executable file ~S" exe)
(assert-equal (run-program `(,(native-namestring exe)) :output :lines)
(assert-equal (run-program `(,(native-namestring exe)) :output :lines :error-output t)
'("hello, world"))
(assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines)
(assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines :error-output t)
'("hello, world"
"You passed 3 arguments:"
" \"a\""
......
......@@ -4,10 +4,11 @@
(defvar *caught-error* nil)
(delete-file-if-exists "try-reloading-dependency.asd")
(asdf::clear-defined-systems)
(with-asdf-cache (:override t)
(handler-bind
((error #'(lambda (c)
(format t "~&Caught error ~s" c)
(assert (not *caught-error*) () "Déjà vu")
(setf *caught-error* t)
(concatenate-files '("try-reloading-dependency.hidden") "try-reloading-dependency.asd")
(DBG "trlc1 5")
......@@ -17,4 +18,4 @@
(assert restart)
(when restart (invoke-restart restart)))))))
(load-system 'try-reloading-1))
(assert *caught-error*)
(assert *caught-error*))
......@@ -15,22 +15,25 @@
(declare (ignore system))
(subpathname *test-directory* "always-error.lisp"))
(asdf::clear-defined-system "asdf")
(let ((*system-definition-search-functions* '(sysdef-bogus-test-search))
(state "Didn't catch warning"))
(DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore")
(handler-bind
((simple-warning
#'(lambda (c)
(when (search "ASDF will ignore this configured system rather than downgrade itself."
(simple-condition-format-control c))
(setf state "Caught warning")))))
(upgrade-asdf))
#'(lambda (c)
(when (search "ASDF will ignore this configured system rather than downgrade itself."
(simple-condition-format-control c))
(setf state "Caught warning")))))
(asdf::clear-defined-system "asdf")
(upgrade-asdf))
(assert-equal state "Caught warning")
(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
(handler-bind
((simple-warning
#'(lambda (c)
(error "Should not have issued warning, but did issue:~% ~A" c))))
#'(lambda (c)
(error "Should not have issued warning, but did issue:~% ~A" c))))
(asdf::clear-defined-system "asdf")
(upgrade-asdf)))
(DBG "Load ASDF with proper configuration: should find asdf.asd from the source above")
......@@ -39,14 +42,18 @@
(:directory ,*asdf-directory*)
(:directory ,*uiop-directory*)
:ignore-inherited-configuration))
(asdf::clear-defined-system "asdf")
(load-system :asdf)
;; This time we found it, but it was skipped because the version was the same
(assert-equal nil (system-source-file (find-system :asdf)))
;; But if we cheat on our version, that should work
(setf asdf::*asdf-version* "3.0")
(asdf::clear-defined-system "asdf")
#-xcl ;; XCL has trouble with the ASDF upgrade
(load-system :asdf)
(assert-pathname-equal (subpathname *asdf-directory* "asdf.asd")
(system-source-file (find-system :asdf)))
(system-source-file (find-system :asdf)))
(DBG "Checking that Makefile and asdf.asd are in synch")
(defun system-lisp-files (system)
......
......@@ -2,9 +2,9 @@
;;; test system def reloading if touched
;;; system that can be found using *system-definition-search-functions*
(defun system-registered-time (name)
(car (asdf::system-registered-p name)))
(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"))
......@@ -14,11 +14,13 @@
(defparameter date1 (get-file-stamp test1.asd))
(defparameter date2 (- date1 600))
(defparameter date3 (- date1 300))
(asdf::clear-defined-system :test1)
(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)
(load-system :test1)
(defparameter date4 (get-file-stamp file2.fasl))
(defparameter date5 (system-registered-time :test1))
(DBG :blah date1 date2 date3 date4 date5)
......@@ -26,6 +28,8 @@
(assert-equal date2 date5)
(assert-compare (>= date4 date3))
(sleep 1)
(asdf::clear-defined-system :test1)
(touch-file test1.asd)
(find-system :test1)
(defparameter date6 (system-registered-time :test1))
......
......@@ -10,12 +10,16 @@
(assert-pathname-equal test1.asd (test-source "test1.asd"))
(assert test1.asd)
(asdf::clear-defined-systems)
(setf asdf:*central-registry* nil)
(load test1.asd)
(assert (find-system :test1))
(defparameter date1 (system-registered-time :test1))
(assert date1)
(asdf::clear-defined-systems)
(touch-file test1.asd :timestamp date1 :offset +2)
(load test1.asd)
(find-system :test1)
(defparameter date2 (system-registered-time :test1))
(assert date2)
......
;;; -*- Lisp -*-
(asdf:defsystem test1
(defsystem test1
:components ((:file "file2" :in-order-to ((compile-op (load-op "file1"))
(load-op (load-op "file1"))))
(:file "file1")))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment