Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
A
asdf
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
1
Issues
1
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Hugo Ishimaru
asdf
Commits
51accff1
Commit
51accff1
authored
Nov 19, 2016
by
Francois-Rene Rideau
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Add out-of-date detection for system definition
parent
017cb992
Changes
11
Hide whitespace changes
Inline
Side-by-side
Showing
11 changed files
with
192 additions
and
139 deletions
+192
-139
action.lisp
action.lisp
+43
-46
find-system.lisp
find-system.lisp
+69
-40
interface.lisp
interface.lisp
+1
-1
plan.lisp
plan.lisp
+27
-18
system.lisp
system.lisp
+8
-6
test/package-inferred-system-test.script
test/package-inferred-system-test.script
+4
-1
test/test-defsystem-depends-on-change.asd
test/test-defsystem-depends-on-change.asd
+1
-0
test/test-defsystem-depends-on-change.script
test/test-defsystem-depends-on-change.script
+5
-0
test/test-defsystem-depends-on.script
test/test-defsystem-depends-on.script
+6
-3
test/test-sysdef-asdf.script
test/test-sysdef-asdf.script
+25
-22
uiop/utility.lisp
uiop/utility.lisp
+3
-2
No files found.
action.lisp
View file @
51accff1
...
...
@@ -16,7 +16,7 @@
#:input-files
#:output-files
#:output-file
#:operation-done-p
#:action-operation
#:action-component
#:make-action
#:component-operation-time
#:mark-operation-done
#:compute-action-stamp
#:perform
#:perform-with-restarts
#:retry
#:accept
#:*action*
#:perform
#:perform-with-restarts
#:retry
#:accept
#:action-path
#:find-action
#:stamp
#:done-p
#:operation-definition-warning
#:operation-definition-error
;; condition
#:action-valid-p
...
...
@@ -50,9 +50,10 @@ and a class-name or class designates the canonical instance of the designated cl
(
with-upgradability
()
(
defun
action-path
(
action
)
"A readable data structure that identifies the action."
(
let
((
o
(
action-operation
action
))
(
c
(
action-component
action
)))
(
cons
(
type-of
o
)
(
component-find-path
c
))))
(
when
action
(
let
((
o
(
action-operation
action
))
(
c
(
action-component
action
)))
(
cons
(
type-of
o
)
(
component-find-path
c
)))))
(
defun
find-action
(
path
)
"Reconstitute an action from its action-path"
(
destructuring-bind
(
o
.
c
)
path
(
make-action
(
make-operation
o
)
(
find-component
()
c
)))))
...
...
@@ -110,7 +111,7 @@ and a class-name or class designates the canonical instance of the designated cl
,
if-no-component
))))))))
;;;;
s
elf-description
;;;;
S
elf-description
(
with-upgradability
()
(
defgeneric
action-description
(
operation
component
)
(
:documentation
"returns a phrase that describes performing this operation
...
...
@@ -128,6 +129,42 @@ Use it in FORMAT control strings as ~/asdf-action:format-action/"
(
princ
(
action-description
operation
component
)
stream
))))
;;;; Detection of circular dependencies
(
with-upgradability
()
(
defun
(
action-valid-p
)
(
operation
component
)
"Is this action valid to include amongst dependencies?"
;; If either the operation or component was resolved to nil, the action is invalid.
;; :if-feature will invalidate actions on components for which the features don't apply.
(
and
operation
component
(
if-let
(
it
(
component-if-feature
component
))
(
featurep
it
)
t
)))
(
define-condition
circular-dependency
(
system-definition-error
)
((
actions
:initarg
:actions
:reader
circular-dependency-actions
))
(
:report
(
lambda
(
c
s
)
(
format
s
(
compatfmt
"~@<Circular dependency: ~3i~_~S~@:>"
)
(
circular-dependency-actions
c
)))))
(
defun
call-while-visiting-action
(
operation
component
fun
)
"Detect circular dependencies"
(
with-asdf-session
()
(
with-accessors
((
action-set
visiting-action-set
)
(
action-list
visiting-action-list
))
*asdf-session*
(
let
((
action
(
cons
operation
component
)))
(
when
(
gethash
action
action-set
)
(
error
'circular-dependency
:actions
(
member
action
(
reverse
action-list
)
:test
'equal
)))
(
setf
(
gethash
action
action-set
)
t
)
(
push
action
action-list
)
(
unwind-protect
(
funcall
fun
)
(
pop
action-list
)
(
setf
(
gethash
action
action-set
)
nil
))))))
;; Syntactic sugar for call-while-visiting-action
(
defmacro
while-visiting-action
((
o
c
)
&body
body
)
`
(
call-while-visiting-action
,
o
,
c
#'
(
lambda
()
,@
body
))))
;;;; Dependencies
(
with-upgradability
()
(
defgeneric
component-depends-on
(
operation
component
)
;; ASDF4: rename to component-dependencies
...
...
@@ -410,11 +447,8 @@ Returns two values:
(
:documentation
"PERFORM an action, consuming its input-files and building its output-files"
))
(
define-convenience-action-methods
perform
(
operation
component
))
(
defvar
*action*
nil
"Action being performed"
)
(
defmethod
perform
:around
((
o
operation
)
(
c
component
))
(
let
((
*action*
(
cons
o
c
)))
(
call-next-method
)))
(
while-visiting-action
(
o
c
)
(
call-next-method
)))
(
defmethod
perform
:before
((
o
operation
)
(
c
component
))
(
ensure-all-directories-exist
(
output-files
o
c
)))
(
defmethod
perform
:after
((
o
operation
)
(
c
component
))
...
...
@@ -452,40 +486,3 @@ Returns two values:
(
action-description
operation
component
)))
(
mark-operation-done
operation
component
)
(
return
))))))
;;;; Detection of circular dependencies
(
with-upgradability
()
(
defun
(
action-valid-p
)
(
operation
component
)
"Is this action valid to include amongst dependencies?"
;; If either the operation or component was resolved to nil, the action is invalid.
;; :if-feature will invalidate actions on components for which the features don't apply.
(
and
operation
component
(
if-let
(
it
(
component-if-feature
component
))
(
featurep
it
)
t
)))
(
define-condition
circular-dependency
(
system-definition-error
)
((
actions
:initarg
:actions
:reader
circular-dependency-actions
))
(
:report
(
lambda
(
c
s
)
(
format
s
(
compatfmt
"~@<Circular dependency: ~3i~_~S~@:>"
)
(
circular-dependency-actions
c
)))))
(
defun
call-while-visiting-action
(
operation
component
fun
)
"Detect circular dependencies"
(
when
(
action-valid-p
operation
component
)
(
with-accessors
((
action-set
visiting-action-set
)
(
action-list
visiting-action-list
))
*asdf-session*
(
let
((
action
(
cons
operation
component
)))
(
when
(
gethash
action
action-set
)
(
error
'circular-dependency
:actions
(
member
action
(
reverse
action-list
)
:test
'equal
)))
(
setf
(
gethash
action
action-set
)
t
)
(
push
action
action-list
)
(
unwind-protect
(
funcall
fun
)
(
pop
action-list
)
(
setf
(
gethash
action
action-set
)
nil
))))))
;; Syntactic sugar for call-while-visiting-action
(
defmacro
while-visiting-action
((
o
c
)
&body
body
)
`
(
call-while-visiting-action
,
o
,
c
#'
(
lambda
()
,@
body
))))
find-system.lisp
View file @
51accff1
...
...
@@ -8,7 +8,7 @@
:asdf/find-component
:asdf/system-registry
:asdf/plan
:asdf/operate
)
(
:export
#:find-system
#:locate-system
#:load-asd
#:define-op
#:load-system-definition-error
#:error-name
#:error-pathname
#:error-condition
))
#:load-system-definition-error
#:error-name
#:error-pathname
#:error-condition
#:system-out-of-date
))
(
in-package
:asdf/find-system
)
(
with-upgradability
()
...
...
@@ -20,6 +20,13 @@
(
format
s
(
compatfmt
"~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>"
)
(
error-name
c
)
(
error-pathname
c
)
(
error-condition
c
)))))
(
define-condition
system-out-of-date
(
condition
)
;; NB: not an error, not a warning, but a normal expected condition
((
name
:initarg
:name
:reader
component-name
))
(
:documentation
"condition signaled when a system is detected as being out of date"
)
(
:report
(
lambda
(
c
s
)
(
format
s
"system ~A is out of date"
(
component-name
c
)))))
;;; Methods for find-system
...
...
@@ -50,13 +57,13 @@
(
and
(
typep
operation
'load-op
)
(
typep
component
'system
)
(
equal
"asdf"
(
coerce-name
component
))))
(
when
*action*
(
let
((
parent-operation
(
car
*action*
))
(
parent-component
(
cdr
*action*
)))
(
if-let
((
action
(
first
(
visiting-action-list
*asdf-session*
))))
(
let
((
parent-operation
(
action-operation
action
))
(
parent-component
(
action-component
action
)))
(
unless
(
and
(
typep
parent-operation
'define-op
)
(
typep
parent-component
'system
))
(
error
"Invalid recursive use of (OPERATE ~S ~S) while visiting ~S ~
- please use proper dependencies instead."
operation
component
*action*
))
operation
component
action
))
(
let
((
action
(
cons
operation
component
)))
(
unless
(
gethash
action
(
definition-dependency-set
parent-component
))
(
push
(
cons
operation
component
)
(
definition-dependency-list
parent-component
))
...
...
@@ -106,8 +113,8 @@
(
asdf-message
(
compatfmt
"~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%"
)
(
coerce-name
s
)
pathname
)
;; dependencies will depend on what's loaded via definition-dependency-list
(
unset-asdf-cache-entry
`
(
component-depends-on
,
o
,
s
))
(
load*
pathname
:external-format
(
encoding-external-format
(
detect-encoding
pathname
)
)))))
(
unset-asdf-cache-entry
`
(
component-depends-on
,
o
,
s
))
)
(
load*
pathname
:external-format
(
encoding-external-format
(
detect-encoding
pathname
)))))
(
defun
load-asd
(
pathname
&key
name
)
"Load system definitions from PATHNAME.
...
...
@@ -123,7 +130,9 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
(
progn
;; We already determine this to be obsolete ---
;; or should we move some tests from find-system to check for up-to-date-ness here?
(
setf
(
component-operation-time
operation
system
)
nil
)
(
setf
(
component-operation-time
operation
system
)
nil
(
definition-dependency-list
system
)
nil
(
definition-dependency-set
system
)
(
list-to-hash-set
nil
))
(
do-it
operation
system
))
(
let
((
system
(
make-instance
'undefined-system
:name
primary-name
:source-file
pathname
)))
...
...
@@ -214,38 +223,58 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
;; preloaded, with a previous configuration, or before filesystem changes), and
;; load a found .asd if appropriate. Finally, update registration table and return results.
(
defmethod
find-system
((
name
string
)
&optional
(
error-p
t
))
(
with-asdf-session
(
:key
`
(
find-system
,
name
))
(
let
((
primary-name
(
primary-system-name
name
)))
(
unless
(
equal
name
primary-name
)
(
find-system
primary-name
nil
)))
(
or
(
and
*immutable-systems*
(
gethash
name
*immutable-systems*
)
(
registered-system
name
))
(
multiple-value-bind
(
foundp
found-system
pathname
previous
previous-time
)
(
locate-system
name
)
(
assert
(
eq
foundp
(
and
(
or
found-system
pathname
previous
)
t
)))
(
let
((
previous-pathname
(
system-source-file
previous
))
(
system
(
or
previous
found-system
)))
(
when
(
and
found-system
(
not
previous
))
(
register-system
found-system
))
(
when
(
and
system
pathname
)
(
setf
(
system-source-file
system
)
pathname
))
(
if-let
((
stamp
(
get-file-stamp
pathname
)))
(
let
((
up-to-date-p
(
and
previous
(
or
(
pathname-equal
pathname
previous-pathname
)
(
and
pathname
previous-pathname
(
pathname-equal
(
physicalize-pathname
pathname
)
(
physicalize-pathname
previous-pathname
))))
(
stamp<=
stamp
previous-time
)
;; TODO: check that all dependencies are up-to-date.
;; This necessitates traversing them without triggering
;; the adding of nodes to the plan.
)))
(
unless
up-to-date-p
(
load-asd
pathname
:name
name
)))))
;; Try again after having loaded from disk if needed
(
or
(
registered-system
name
)
(
when
error-p
(
error
'missing-component
:requires
name
)))))))
(
nest
(
with-asdf-session
(
:key
`
(
find-system
,
name
)))
(
let*
((
name-primary-p
(
primary-system-p
name
))
(
primary-system
(
unless
name-primary-p
(
find-system
(
primary-system-name
name
)
nil
)))))
(
or
(
and
*immutable-systems*
(
gethash
name
*immutable-systems*
)
(
registered-system
name
)))
(
multiple-value-bind
(
foundp
found-system
pathname
previous
previous-time
)
(
locate-system
name
)
(
assert
(
eq
foundp
(
and
(
or
found-system
pathname
previous
)
t
))))
(
let
((
previous-pathname
(
system-source-file
previous
))
(
system
(
or
previous
found-system
)))
(
when
(
and
found-system
(
not
previous
))
(
register-system
found-system
))
(
when
(
and
system
pathname
)
(
setf
(
system-source-file
system
)
pathname
))
(
if-let
((
stamp
(
get-file-stamp
pathname
)))
(
let
((
up-to-date-p
(
and
previous
(
or
(
pathname-equal
pathname
previous-pathname
)
(
and
pathname
previous-pathname
(
pathname-equal
(
physicalize-pathname
pathname
)
(
physicalize-pathname
previous-pathname
))))
(
stamp<=
stamp
previous-time
)
;; TODO: check that all dependencies are up-to-date.
;; This necessitates traversing them without triggering
;; the adding of nodes to the plan.
(
loop
:with
plan
=
(
or
(
and
*asdf-session*
(
session-plan
*asdf-session*
))
(
make-instance
*plan-class*
))
:for
action
:in
(
definition-dependency-list
previous
)
:always
(
handler-bind
((
system-out-of-date
(
lambda
(
c
)
(
declare
(
ignore
c
))
(
return
nil
))))
(
action-up-to-date-p
plan
(
action-operation
action
)
(
action-component
action
)))
:finally
(
let
((
o
(
make-operation
'define-op
))
(
s
(
if
name-primary-p
previous
primary-system
)))
(
when
s
(
multiple-value-bind
(
stamp
done-p
)
(
compute-action-stamp
plan
o
s
)
(
return
(
and
(
stamp<=
stamp
(
component-operation-time
o
s
))
done-p
)))))))))
(
unless
up-to-date-p
(
restart-case
(
signal
'system-out-of-date
:name
name
)
(
continue
()
:report
"continue"
))
(
load-asd
pathname
:name
name
)))))
;; Try again after having loaded from disk if needed
(
or
(
registered-system
name
)
(
when
error-p
(
error
'missing-component
:requires
name
)))))
;; Resolved forward reference for asdf/system-registry.
(
defun
mark-component-preloaded
(
component
)
...
...
interface.lisp
View file @
51accff1
...
...
@@ -123,7 +123,7 @@
#:missing-dependency
#:missing-dependency-of-version
#:circular-dependency
; errors
#:duplicate-names
#:non-toplevel-system
#:non-system-system
#:bad-system-name
#:duplicate-names
#:non-toplevel-system
#:non-system-system
#:bad-system-name
#:system-out-of-date
#:package-inferred-system-missing-package-error
#:operation-definition-warning
#:operation-definition-error
...
...
plan.lisp
View file @
51accff1
...
...
@@ -18,7 +18,7 @@
#:record-dependency
#:normalize-forced-systems
#:action-forced-p
#:action-forced-not-p
#:map-direct-dependencies
#:reduce-direct-dependencies
#:direct-dependencies
#:compute-action-stamp
#:traverse-action
#:compute-action-stamp
#:traverse-action
#:action-up-to-date-p
#:make-plan
#:plan-actions
#:perform-plan
#:plan-operates-on-p
#:planned-p
#:index
#:forced
#:forced-not
#:plan-actions-r
...
...
@@ -73,6 +73,9 @@ in some previous image, or T if it needs to be done.")
+action-status-out-of-date+
(
make-instance
'action-status
:stamp
stamp
:done-p
done-p
:planned-p
planned-p
:index
index
)))
(
defun
action-status-out-of-date-p
(
status
)
(
eq
(
action-stamp
status
)
t
))
(
defmethod
print-object
((
status
action-status
)
stream
)
(
print-unreadable-object
(
status
stream
:type
t
)
(
with-slots
(
stamp
done-p
planned-p
index
)
status
...
...
@@ -104,6 +107,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
(
setf
(
gethash
o
times
)
(
action-stamp
new-status
))))
new-status
))
;;;; forcing
(
with-upgradability
()
(
defgeneric
action-forced-p
(
plan
operation
component
)
...
...
@@ -346,8 +350,9 @@ initialized with SEED."
(
defun
action-up-to-date-p
(
plan
operation
component
)
"Check whether a node is up-to-date, and mark it so if such. But don't add anything to the plan."
(
while-visiting-action
(
operation
component
)
; maintain context, handle circularity.
(
block
nil
(
block
nil
(
unless
(
action-valid-p
operation
component
)
(
return
nil
))
(
while-visiting-action
(
operation
component
)
; maintain context, handle circularity.
;; Do NOT record the dependency: it might be out of date.
(
let
((
status
(
action-status
plan
operation
component
)))
(
when
status
...
...
@@ -369,12 +374,13 @@ initialized with SEED."
(
not
(
eq
(
action-stamp
status
)
t
))))))
(
defmethod
traverse-action
(
plan
operation
component
needed-in-image-p
)
(
while-visiting-action
(
operation
component
)
; maintain context, handle circularity.
(
block
nil
;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph,
;; instead of just a dependency order as in vanilla ASDF.
;; TODO: It is also needed to detect OPERATE-in-PERFORM.
(
record-dependency
plan
operation
component
)
(
block
nil
(
unless
(
action-valid-p
operation
component
)
(
return
nil
))
;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph,
;; instead of just a dependency order as in vanilla ASDF.
;; TODO: It is also needed to detect OPERATE-in-PERFORM.
(
record-dependency
plan
operation
component
)
(
while-visiting-action
(
operation
component
)
; maintain context, handle circularity.
;; needed-in-image distinguishes b/w things that must happen in the
;; current image and those things that simply need to have been done in a previous one.
(
let*
((
aniip
(
needed-in-image-p
operation
component
))
; action-specific needed-in-image
...
...
@@ -451,6 +457,8 @@ initialized with SEED."
(
with-asdf-session
()
(
let
((
plan
(
apply
'make-instance
(
or
plan-class
*plan-class*
)
:system
(
component-system
c
)
keys
)))
(
when
(
and
(
null
(
session-plan
*asdf-session*
))
(
plan-performable-p
plan
))
(
setf
(
session-plan
*asdf-session*
)
plan
))
(
traverse-action
plan
o
c
t
)
plan
)))
...
...
@@ -506,15 +514,16 @@ initialized with SEED."
:collect
(
cons
o
c
))))
(
defun
collect-action-dependencies
(
plan
operation
component
)
(
while-visiting-action
(
operation
component
)
; maintain context, handle circularity.
(
let
((
action
(
make-action
operation
component
)))
(
unless
(
gethash
action
(
visited-actions
*asdf-session*
))
(
setf
(
gethash
action
(
visited-actions
*asdf-session*
))
t
)
(
when
(
and
(
typep
component
(
plan-component-type
plan
))
(
not
(
action-forced-not-p
plan
operation
component
)))
(
map-direct-dependencies
operation
component
#'
(
lambda
(
o
c
)
(
collect-action-dependencies
plan
o
c
)))
(
push
action
(
plan-actions-r
plan
)))))))
(
when
(
action-valid-p
operation
component
)
(
while-visiting-action
(
operation
component
)
; maintain context, handle circularity.
(
let
((
action
(
make-action
operation
component
)))
(
unless
(
gethash
action
(
visited-actions
*asdf-session*
))
(
setf
(
gethash
action
(
visited-actions
*asdf-session*
))
t
)
(
when
(
and
(
typep
component
(
plan-component-type
plan
))
(
not
(
action-forced-not-p
plan
operation
component
)))
(
map-direct-dependencies
operation
component
#'
(
lambda
(
o
c
)
(
collect-action-dependencies
plan
o
c
)))
(
push
action
(
plan-actions-r
plan
))))))))
(
defgeneric
collect-dependencies
(
operation
component
&key
&allow-other-keys
)
(
:documentation
"Given an action, build a plan for all of its dependencies."
))
...
...
system.lisp
View file @
51accff1
...
...
@@ -60,7 +60,14 @@ NB: This interface is subject to change. Please contact ASDF maintainers if you
(
defclass
proto-system
()
; slots to keep when resetting a system
;; To preserve identity for all objects, we'd need keep the components slots
;; but also to modify parse-component-form to reset the recycled objects.
((
name
)
(
source-file
))
((
name
)
(
source-file
)
;; These two slots contains the *inferred* dependencies of define-op,
;; from loading the .asd file, as list and as set.
(
definition-dependency-list
:initform
nil
:accessor
definition-dependency-list
)
(
definition-dependency-set
:initform
(
list-to-hash-set
nil
)
:accessor
definition-dependency-set
))
(
:documentation
"PROTO-SYSTEM defines the elements of identity that are preserved when
a SYSTEM is redefined and its class is modified."
))
...
...
@@ -89,11 +96,6 @@ a SYSTEM is redefined and its class is modified."))
;; This slot contains the *declared* defsystem-depends-on dependencies
(
defsystem-depends-on
:reader
system-defsystem-depends-on
:initarg
:defsystem-depends-on
:initform
nil
)
;; These slots contains the *inferred* dependencies of define-op, as list and as set
(
definition-dependency-list
:initform
nil
:accessor
definition-dependency-list
)
(
definition-dependency-set
:initform
(
list-to-hash-set
nil
)
:accessor
definition-dependency-set
)
;; these two are specially set in parse-component-form, so have no :INITARGs.
(
depends-on
:reader
system-depends-on
:initform
nil
)
(
weakly-depends-on
:reader
system-weakly-depends-on
:initform
nil
))
...
...
test/package-inferred-system-test.script
View file @
51accff1
;;-*- Lisp -*-
(register-directory (subpathname *test-directory* "package-inferred-system-test/"))
(load-system :package-inferred-system-test/a/x)
(load-system :package-inferred-system-test/d)
...
...
@@ -5,7 +7,8 @@
(signals package-inferred-system-missing-package-error (load-system :package-inferred-system-test/e))
;; No such file.
(signals missing-component (load-system :package-inferred-system-test/f))
(signals missing-component
(handler-bind ((system-out-of-date 'continue)) (load-system :package-inferred-system-test/f)))
;; Test that around-compile is inherited by inferred systems.
(assert-equal 3 (symbol-call :package-inferred-system-test/a :add10 1)) ;; add10 must have been compiled in base 2
test/test-defsystem-depends-on-change.asd
View file @
51accff1
(
defvar
*tddoc*
0
)
(
incf
*tddoc*
)
(
format
t
"tddoc loaded ~D times.~%"
*tddoc*
)
(
if
(
=
*tddoc*
1
)
(
defsystem
"test-defsystem-depends-on-change"
...
...
test/test-defsystem-depends-on-change.script
View file @
51accff1
...
...
@@ -8,10 +8,12 @@
(defparameter tddoc "test-defsystem-depends-on-change")
(defparameter talc "test-asdf-location-change")
(defparameter asdf-user::*tddoc* 0)
(DBG "Load the system, using xach-foo-1")
(push (subpathname *test-directory* "xach-foo-1/") *central-registry*)
(clear-system tddoc)
(load-system tddoc)
(assert-equal asdf-user::*tddoc* 1)
(assert-equal test-asdf-system::*times-loaded* 1)
...
...
@@ -39,9 +41,12 @@
(subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd")
(system-source-file talc))
(DBG "Now, change a defsystem-depends-on dependency and try again")
(setf (first *central-registry*) (subpathname *test-directory* "xach-foo-2/"))
(DBG :before asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*)
(load-system "test-defsystem-depends-on-change")
(DBG :after asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*)
(assert-equal asdf-user::*tddoc* 2)
(assert-equal test-asdf-system::*times-loaded* 1) ;; from test-asdf.asd
(assert-equal test-asdf-system::*ta/dcc* 2)
...
...
test/test-defsystem-depends-on.script
View file @
51accff1
...
...
@@ -31,7 +31,8 @@
:components ((:file "file3")))
(reset-session)
(signals asdf::formatted-system-definition-error (make :test-defsystem-depends-on-3))
(signals asdf::formatted-system-definition-error
(handler-bind ((system-out-of-date 'continue)) (make :test-defsystem-depends-on-3)))
(defparameter *newsym* (gentemp (symbol-name 'feature) :keyword))
...
...
@@ -49,9 +50,11 @@
(assert (not (system-registered-p "unloadable-system"))))
(progn
(signals missing-dependency (find-system "test-defsystem-depends-on-missing-system"))
(signals missing-dependency
(handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-missing-system")))
(assert (not (asdf::registered-system "test-defsystem-depends-on-missing-system"))))
(progn
(signals asdf::system-definition-error (find-system "test-defsystem-depends-on-circular"))
(signals asdf::system-definition-error
(handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-circular")))
(assert (not (asdf::registered-system "test-defsystem-depends-on-circular"))))
test/test-sysdef-asdf.script
View file @
51accff1
...
...
@@ -2,16 +2,17 @@
(format! t "~%Using ASDF ~A~%" (asdf-version))
(assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF
(setf *asdf-session* nil)
(DBG "Let's define some methods on input-files, to later check what an upgrade does to them.")
(with-asdf-session (:override t)
(def-test-system "fooey")
(defparameter *ticks* 0)
(defun tick () (incf *ticks*))
(defsystem "foo")
(defmethod input-files :after ((o load-op) (c system)) (tick))
(def-test-system "foo")
(defmethod input-files :after ((o load-op) (c system))
(tick))
(assert-equal *ticks* 0)
(input-files 'load-op "foo")
(assert-equal *ticks* 1)
...
...
@@ -19,6 +20,7 @@
(assert-equal *ticks* 1) ;; It was cached.
(assert (find-system "fooey" nil)))
(DBG "Try load ASDF with an empty configuration")
(initialize-source-registry
'(:source-registry :ignore-inherited-configuration))
...
...
@@ -26,15 +28,15 @@
;; We haven't found it, and got the fallback
(assert-equal nil (system-source-file (find-system :asdf)))
(DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore")
(clear-system "asdf")
;; Bogus sysdef finding function, for the sake of testing no-load-old-version.
(defun sysdef-bogus-test-search (system)
(declare (ignore system))
(subpathname *test-directory* "always-error.lisp"))
(clear-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)
...
...
@@ -43,8 +45,11 @@
(setf state "Caught warning")))))
(clear-system "asdf")
(upgrade-asdf))
(assert-equal state "Caught warning")
(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
(assert-equal state "Caught warning"))
(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
(let ((*system-definition-search-functions* '(sysdef-bogus-test-search)))
(handler-bind
((simple-warning
#'(lambda (c)
...
...
@@ -53,6 +58,7 @@
(upgrade-asdf)))
(assert-equal nil (system-source-file (find-system :asdf)))
(DBG "Load ASDF with proper configuration: should find asdf.asd from the source above")
(initialize-source-registry
`(:source-registry
...
...
@@ -60,18 +66,17 @@
(:directory ,*uiop-directory*)
:ignore-inherited-configuration))
(clear-system "asdf")
(with-asdf-session (:override t)
(with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade
(load-system :asdf)
(assert-pathname-equal (subpathname *asdf-directory* "asdf.asd")
(system-source-file (find-system :asdf))))
(DBG "Loading from the same version shouldn't have reset methods")
(setf *ticks* 2)
(input-files 'load-op "foo")
(assert-equal *ticks* 3))
(DBG "Loading from an ancient version WILL reset methods")
(assert (find-system "fooey" nil))
(defparameter *current-version* (asdf-version))
...
...
@@ -79,7 +84,6 @@
(assert (asdf/upgrade::upgrading-p))
(clear-system "asdf")
(reset-session)
(with-expected-failure (#+xcl t)
;; expected-failure: XCL has trouble with the ASDF upgrade
(load-system :asdf)
...
...
@@ -88,7 +92,7 @@
(system-source-file (find-system :asdf))))
;; Upgrading from an old-enough version redefined away the input-files method!
(DBG "Upgrading from an old-enough version should have redefined away the input-files method!")
(setf *ticks* 4)
(input-files 'load-op "asdf")
(assert-equal *ticks* 4)
...
...
@@ -96,38 +100,37 @@
(assert (not (find-system "fooey" nil)))
(DBG "Actually upgrade, from a different but forward-compatible version")
;; The data-punting upgrade will mess up component identity, so clear the cache
(reset-session)
(setf asdf::*asdf-version* asdf/upgrade::*oldest-forward-compatible-asdf-version*)
(clear-system "asdf")
(def-test-system "fooey")
(setf *ticks* 5)
(defmethod input-files :after ((load-op operation) (c system))
(setf *ticks* 10)
(defmethod input-files :after ((o load-op) (c system))
(DBG :input-files o c)
(incf *ticks*))
(input-files 'load-op "uiop")
(assert-equal *ticks*
8
)
(assert-equal *ticks*
11
)
(with-expected-failure (#+xcl t)
;; expected-failure: XCL has trouble with the ASDF upgrade
(load-system :asdf))
;; Upgrading from a recent-enough version, the input-files method was preserved!
;; But we need to clear the cache for it not to be short-circuited.
(reset-session)
(assert (find-system "fooey" nil))
(setf *ticks* 9)
(setf *ticks* 20)
(eval '(input-files 'load-op "uiop"))
(assert-equal *ticks* 12)
(assert-equal *ticks* 21)
(DBG "Checking that the bootstrap script and asdf.asd are in synch")
(defun bootstrap-lisp-files (file line-prefix)
(with-input-file (input (subpathname *asdf-directory* file))
(loop :for line = (read-line input)
:when (string-prefix-p line-prefix line)
:return (subseq line (length line-prefix))
:finally (error "Didn't find ~a in ~a" line-prefix file))))
(DBG "Checking that the bootstrap script and asdf.asd are in synch")
(defun system-lisp-files (system)
(loop :for f :in (input-files 'concatenate-source-op system)
:collect (unix-namestring (enough-pathname f *asdf-directory*))))
...
...
uiop/utility.lisp
View file @
51accff1
...
...
@@ -82,8 +82,9 @@ to supersede any previous definition."
(
with-upgradability
()
(
defvar
*uiop-debug-utility*
'
(
or
(
ignore-errors
(
symbol-call
:asdf
:system-relative-pathname
:uiop
"contrib/debug.lisp"
))
(
symbol-call
:uiop/pathname
:subpathname
(
user-homedir-pathname
)
"common-lisp/asdf/uiop/contrib/debug.lisp"
))
(
probe-file
(
symbol-call
:asdf
:system-relative-pathname
:uiop
"contrib/debug.lisp"
)))
(
probe-file
(
symbol-call
:uiop/pathname
:subpathname
(
user-homedir-pathname
)
"common-lisp/asdf/uiop/contrib/debug.lisp"
)))
"form that evaluates to the pathname to your favorite debugging utilities"
)
(
defmacro
uiop-debug
(
&rest
keys
)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add