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
0
Issues
0
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
Jan Moringen
asdf
Commits
bb89039c
Commit
bb89039c
authored
Jan 16, 2018
by
Robert Goldman
Browse files
Options
Browse Files
Download
Plain Diff
Merge branch 'misnamed-secondary' into 'master'
Misnamed secondary See merge request
!91
parents
53f72684
069cd2a6
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
77 additions
and
58 deletions
+77
-58
find-system.lisp
find-system.lisp
+34
-31
system.lisp
system.lisp
+19
-7
test/file2.lisp
test/file2.lisp
+1
-0
test/test-multiple.asd
test/test-multiple.asd
+9
-6
test/test-multiple.script
test/test-multiple.script
+14
-14
No files found.
find-system.lisp
View file @
bb89039c
...
...
@@ -82,11 +82,9 @@
;; TODO: could this file be refactored so that locate-system is merely
;; the cache-priming call to input-files here?
(
defmethod
input-files
((
o
define-op
)
(
s
system
))
(
assert
(
equal
(
coerce-name
s
)
(
primary-system-name
s
)))
(
if-let
((
asd
(
system-source-file
s
)))
(
list
asd
)))
(
defmethod
perform
((
o
define-op
)
(
s
system
))
(
assert
(
equal
(
coerce-name
s
)
(
primary-system-name
s
)))
(
nest
(
if-let
((
pathname
(
first
(
input-files
o
s
)))))
(
let
((
readtable
*readtable*
)
;; save outer syntax tables. TODO: proper syntax-control
...
...
@@ -195,21 +193,25 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
(
defun
locate-system
(
name
)
"Given a system NAME designator, try to locate where to load the system from.
Returns
five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
Returns
six values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME PREVIOUS-PRIMARY
FOUNDP is true when a system was found,
either a new unregistered one or a previously registered one.
FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed.
PATHNAME when not null is a path from which to load the system,
either associated with FOUND-SYSTEM, or with the PREVIOUS system.
PREVIOUS when not null is a previously loaded SYSTEM object of same name.
PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
PREVIOUS-PRIMARY when not null is the primary system for the PREVIOUS system."
(
with-asdf-session
()
;; NB: We don't cache the results. We once used to, but it wasn't useful,
;; and keeping a negative cache was a bug (see lp#1335323), which required
;; explicit invalidation in clear-system and find-system (when unsucccessful).
(
let*
((
name
(
coerce-name
name
))
(
previous
(
registered-system
name
))
; load from disk if absent or newer on disk
(
primary
(
registered-system
(
primary-system-name
name
)))
(
previous-time
(
and
previous
primary
(
component-operation-time
'define-op
primary
)))
(
previous-primary-name
(
and
previous
(
primary-system-name
previous
)))
(
previous-primary-system
(
and
previous-primary-name
(
registered-system
previous-primary-name
)))
(
previous-time
(
and
previous-primary-system
(
component-operation-time
'define-op
previous-primary-system
)))
(
found
(
search-for-system-definition
name
))
(
found-system
(
and
(
typep
found
'system
)
found
))
(
pathname
(
ensure-pathname
...
...
@@ -222,37 +224,38 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(
unless
(
check-not-old-asdf-system
name
pathname
)
(
check-type
previous
system
)
;; asdf is preloaded, so there should be a previous one.
(
setf
found-system
nil
pathname
nil
))
(
values
foundp
found-system
pathname
previous
previous-time
))))
(
values
foundp
found-system
pathname
previous
previous-time
previous-primary-system
))))
;; TODO: make a prepare-define-op node for this
;; so we can properly cache the answer rather than recompute it.
(
defun
definition-dependencies-up-to-date-p
(
system
)
(
check-type
system
system
)
(
or
(
not
(
primary-system-p
system
))
(
handler-case
(
loop
:with
plan
=
(
make-instance
*plan-class*
)
:for
action
:in
(
definition-dependency-list
system
)
:always
(
action-up-to-date-p
plan
(
action-operation
action
)
(
action-component
action
))
:finally
(
let
((
o
(
make-operation
'define-op
)))
(
multiple-value-bind
(
stamp
done-p
)
(
compute-action-stamp
plan
o
system
)
(
return
(
and
(
timestamp<=
stamp
(
component-operation-time
o
system
))
done-p
)))))
(
system-out-of-date
()
nil
))))
;; Main method for find-system: first, make sure the computation is memoized in a session cache.
;; Unless the system is immutable, use locate-system to find the primary system;
;; reconcile the finding (if any) with any previous definition (in a previous session,
;; preloaded, with a previous configuration, or before filesystem changes), and
;; load a found .asd if appropriate. Finally, update registration table and return results.
(
defun
definition-dependencies-up-to-date-p
(
system
)
(
check-type
system
system
)
(
assert
(
primary-system-p
system
))
(
handler-case
(
loop
:with
plan
=
(
make-instance
*plan-class*
)
:for
action
:in
(
definition-dependency-list
system
)
:always
(
action-up-to-date-p
plan
(
action-operation
action
)
(
action-component
action
))
:finally
(
let
((
o
(
make-operation
'define-op
)))
(
multiple-value-bind
(
stamp
done-p
)
(
compute-action-stamp
plan
o
system
)
(
return
(
and
(
timestamp<=
stamp
(
component-operation-time
o
system
))
done-p
)))))
(
system-out-of-date
()
nil
)))
(
defmethod
find-system
((
name
string
)
&optional
(
error-p
t
))
(
nest
(
with-asdf-session
(
:key
`
(
find-system
,
name
)))
(
let
((
name-primary-p
(
primary-system-p
name
)))
(
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
)
(
multiple-value-bind
(
foundp
found-system
pathname
previous
previous-time
previous-primary
)
(
locate-system
name
)
(
assert
(
eq
foundp
(
and
(
or
found-system
pathname
previous
)
t
))))
(
let
((
previous-pathname
(
system-source-file
previous
))
...
...
@@ -263,18 +266,18 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(
setf
(
system-source-file
system
)
pathname
))
(
if-let
((
stamp
(
get-file-stamp
pathname
)))
(
let
((
up-to-date-p
(
and
previous
(
and
previous
previous-primary
(
or
(
pathname-equal
pathname
previous-pathname
)
(
and
pathname
previous-pathname
(
pathname-equal
(
physicalize-pathname
pathname
)
(
physicalize-pathname
previous-pathname
))))
(
timestamp<=
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.
(
or
(
not
name-primary-p
)
(
definition-dependencies-up-to-date-p
previous
)
))))
;;
Check that all previous definition-dependencies are up-to-date,
;;
traversing them without triggering the adding of nodes to the plan.
;;
TODO: actually have a prepare-define-op, extract its timestamp,
;; and check that it is less than the stamp of the previous define-op ?
(
definition-dependencies-up-to-date-p
previous-primary
))))
(
unless
up-to-date-p
(
restart-case
(
signal
'system-out-of-date
:name
name
)
...
...
system.lisp
View file @
bb89039c
...
...
@@ -126,21 +126,33 @@ a SYMBOL (designing its name, downcased), or a STRING (designing itself)."
(
t
(
sysdef-error
(
compatfmt
"~@<Invalid component designator: ~3i~_~A~@:>"
)
name
))))
(
defun
primary-system-name
(
system-designator
)
"Given a system designator NAME, return the name of the corresponding primary system,
after which the .asd file is named. That's the first component when dividing the name
as a string by / slashes. A component designates its system."
"Given a system designator NAME, return the name of the corresponding
primary system, after which the .asd file in which it is defined is named.
If given a string or symbol (to downcase), do it syntactically
by stripping anything from the first slash on.
If given a component, do it semantically by extracting
the system-primary-system-name of its system."
(
etypecase
system-designator
(
string
(
if-let
(
p
(
position
#\/
system-designator
))
(
subseq
system-designator
0
p
)
system-designator
))
(
symbol
(
primary-system-name
(
coerce-name
system-designator
)))
(
component
(
primary-system-name
(
coerce-name
(
component-system
system-designator
))))))
(
component
(
let*
((
system
(
component-system
system-designator
))
(
source-file
(
physicalize-pathname
(
system-source-file
system
))))
(
and
source-file
(
equal
(
pathname-type
source-file
)
"asd"
)
(
pathname-name
source-file
))))))
(
defun
primary-system-p
(
system
)
"Given a system designator SYSTEM, return T if it designates a primary system, or else NIL.
Also return NIL if system is neither a SYSTEM nor a string designating one."
(
typecase
system
If given a string, do it syntactically and return true if the name does not contain a slash.
If given a symbol, downcase to a string then fallback to previous case (NB: for NIL return T).
If given a component, do it semantically and return T if it's a SYSTEM and its primary-system-name
is the same as its component-name."
(
etypecase
system
(
string
(
not
(
find
#\/
system
)))
(
system
(
primary-system-p
(
coerce-name
system
)))))
(
symbol
(
primary-system-p
(
coerce-name
system
)))
(
component
(
and
(
typep
system
'system
)
(
equal
(
component-name
system
)
(
primary-system-name
system
))))))
(
defun
coerce-filename
(
name
)
"Coerce a system designator NAME into a string suitable as a filename component.
...
...
test/file2.lisp
View file @
bb89039c
(
in-package
:test-package
)
(
assert
*file1*
)
(
defparameter
*file2*
t
)
(
defvar
*f2c*
0
)
(
incf
*f2c*
)
test/test-multiple.asd
View file @
bb89039c
;;; -*- Lisp -*-
(
asdf:
defsystem
test-multiple
(
defsystem
test-multiple
:components
((
:file
"file3"
)))
(
asdf:
defsystem
test-multiple-too
(
defsystem
test-multiple-too
:components
((
:file
"file1"
)
(
:file
"file2"
:depends-on
(
"file1"
))
(
:file
"file3"
:depends-on
(
"file1"
"file2"
))))
(
:file
"file2"
:depends-on
(
"file1"
))))
(
asdf:
defsystem
test-multiple-free
:depends-on
(
:test-multiple
)
(
defsystem
test-multiple-free
:depends-on
(
:test-multiple
:test-multiple-dep
)
:components
((
:file
"file4"
)))
(
defsystem
test-multiple-dep
:depends-on
(
:test-multiple
)
:components
((
:file
"file3"
)))
test/test-multiple.script
View file @
bb89039c
...
...
@@ -7,19 +7,19 @@
(setf *central-registry* `(,*test-directory* ,tmp))
;; Don't rely on ln -s on Windows
(cond
((os-unix-p)
(multiple-value-bind (output error-output return-code)
(uiop:run-program
(format nil "ln -sf ~A ~A"
(native-namestring asd)
(native-namestring asd2)) :ignore-error-status t)
(declare (ignore output error-output))
(oos 'load-source-op (if (zerop return-code)
'test-multiple-too
'test-multiple))))
(t
(oos 'load-source-op 'test-multiple)))
(assert (asymval :*file3* :test-package))
(defparameter symlinkp
(progn
#+os-unix
(zerop
(nth-value 2
(run-program
`("ln" "-sf" ,(native-namestring asd) ,(native-namestring asd2))
:output t :error-output t :input nil :ignore-error-status t)))))
(oos 'load-source-op (if symlinkp 'test-multiple-too 'test-multiple))
(assert (asymval :*file2* :test-package))
(load-system 'test-multiple-free)
(assert (probe-file* file4))
(assert (asymval :*file4* :test-package))
(setf test-package::*file4* nil)
(load-system 'test-multiple-free)
(assert-equal test-package::*file4* nil)
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment