Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
A
asdf
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Tarn Burton
asdf
Commits
c713e0a0
Commit
c713e0a0
authored
10 years ago
by
Francois-Rene Rideau
Browse files
Options
Downloads
Patches
Plain Diff
Remove loop and restart-case from find-system;
the functionality was moved to call-with-asdf-cache before where it belongs.
parent
00256418
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
find-system.lisp
+56
-59
56 additions, 59 deletions
find-system.lisp
with
56 additions
and
59 deletions
find-system.lisp
+
56
−
59
View file @
c713e0a0
...
@@ -359,68 +359,65 @@ either associated with FOUND-SYSTEM, or with the PREVIOUS system.
...
@@ -359,68 +359,65 @@ either associated with FOUND-SYSTEM, or with the PREVIOUS system.
PREVIOUS when not null is a previously loaded SYSTEM object of same name.
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."
(
let*
((
name
(
coerce-name
name
))
(
let*
((
name
(
coerce-name
name
))
(
in-memory
(
system-registered-p
name
))
; load from disk if absent or newer on disk
(
in-memory
(
system-registered-p
name
))
; load from disk if absent or newer on disk
(
previous
(
cdr
in-memory
))
(
previous
(
cdr
in-memory
))
(
previous
(
and
(
typep
previous
'system
)
previous
))
(
previous
(
and
(
typep
previous
'system
)
previous
))
(
previous-time
(
car
in-memory
))
(
previous-time
(
car
in-memory
))
(
found
(
search-for-system-definition
name
))
(
found
(
search-for-system-definition
name
))
(
found-system
(
and
(
typep
found
'system
)
found
))
(
found-system
(
and
(
typep
found
'system
)
found
))
(
pathname
(
ensure-pathname
(
pathname
(
ensure-pathname
(
or
(
and
(
typep
found
'
(
or
pathname
string
))
(
pathname
found
))
(
or
(
and
(
typep
found
'
(
or
pathname
string
))
(
pathname
found
))
(
and
found-system
(
system-source-file
found-system
))
(
and
found-system
(
system-source-file
found-system
))
(
and
previous
(
system-source-file
previous
)))
(
and
previous
(
system-source-file
previous
)))
:want-absolute
t
:resolve-symlinks
*resolve-symlinks*
))
:want-absolute
t
:resolve-symlinks
*resolve-symlinks*
))
(
foundp
(
and
(
or
found-system
pathname
previous
)
t
)))
(
foundp
(
and
(
or
found-system
pathname
previous
)
t
)))
(
check-type
found
(
or
null
pathname
system
))
(
check-type
found
(
or
null
pathname
system
))
(
unless
(
check-not-old-asdf-system
name
pathname
)
(
unless
(
check-not-old-asdf-system
name
pathname
)
(
cond
(
cond
(
previous
(
setf
found
nil
pathname
nil
))
(
previous
(
setf
found
nil
pathname
nil
))
(
t
(
t
(
setf
found
(
sysdef-preloaded-system-search
"asdf"
))
(
setf
found
(
sysdef-preloaded-system-search
"asdf"
))
(
assert
(
typep
found
'system
))
(
assert
(
typep
found
'system
))
(
setf
found-system
found
pathname
nil
))))
(
setf
found-system
found
pathname
nil
))))
(
values
foundp
found-system
pathname
previous
previous-time
)))
(
values
foundp
found-system
pathname
previous
previous-time
)))
(
defmethod
find-system
((
name
string
)
&optional
(
error-p
t
))
(
defmethod
find-system
((
name
string
)
&optional
(
error-p
t
))
(
with-asdf-cache
(
:key
`
(
find-system
,
name
))
(
with-asdf-cache
(
:key
`
(
find-system
,
name
))
(
let
((
primary-name
(
primary-system-name
name
)))
(
let
((
primary-name
(
primary-system-name
name
)))
(
unless
(
equal
name
primary-name
)
(
unless
(
equal
name
primary-name
)
(
find-system
primary-name
nil
)))
(
find-system
primary-name
nil
)))
(
loop
(
if-let
(
x
(
and
*immutable-systems*
(
gethash
name
*immutable-systems*
)
(
restart-case
(
cdr
(
system-registered-p
name
))))
(
multiple-value-bind
(
foundp
found-system
pathname
previous
previous-time
)
x
(
locate-system
name
)
(
multiple-value-bind
(
foundp
found-system
pathname
previous
previous-time
)
(
when
(
and
found-system
(
eq
found-system
previous
)
(
locate-system
name
)
(
or
(
first
(
gethash
`
(
find-system
,
name
)
*asdf-cache*
))
(
assert
(
eq
foundp
(
and
(
or
found-system
pathname
previous
)
t
)))
(
and
*immutable-systems*
(
gethash
name
*immutable-systems*
))))
(
let
((
previous-pathname
(
and
previous
(
system-source-file
previous
)))
(
return
found-system
))
(
system
(
or
previous
found-system
)))
(
assert
(
eq
foundp
(
and
(
or
found-system
pathname
previous
)
t
)))
(
when
(
and
found-system
(
not
previous
))
(
let
((
previous-pathname
(
and
previous
(
system-source-file
previous
)))
(
register-system
found-system
))
(
system
(
or
previous
found-system
)))
(
when
(
and
system
pathname
)
(
when
(
and
found-system
(
not
previous
))
(
setf
(
system-source-file
system
)
pathname
))
(
register-system
found-system
))
(
when
(
and
pathname
(
when
(
and
system
pathname
)
(
let
((
stamp
(
get-file-stamp
pathname
)))
(
setf
(
system-source-file
system
)
pathname
))
(
and
stamp
(
when
(
and
pathname
(
not
(
and
previous
(
let
((
stamp
(
get-file-stamp
pathname
)))
(
or
(
pathname-equal
pathname
previous-pathname
)
(
and
stamp
(
and
pathname
previous-pathname
(
not
(
and
previous
(
pathname-equal
(
or
(
pathname-equal
pathname
previous-pathname
)
(
physicalize-pathname
pathname
)
(
and
pathname
previous-pathname
(
physicalize-pathname
previous-pathname
))))
(
pathname-equal
(
stamp<=
stamp
previous-time
))))))
(
physicalize-pathname
pathname
)
;; only load when it's a pathname that is different or has newer content, and not an old asdf
(
physicalize-pathname
previous-pathname
))))
(
load-asd
pathname
:name
name
)))
(
stamp<=
stamp
previous-time
))))))
(
let
((
in-memory
(
system-registered-p
name
)))
; try again after loading from disk if needed
;; only load when it's a pathname that is different or has newer content, and not an old asdf
(
cond
(
load-asd
pathname
:name
name
)))
(
in-memory
(
let
((
in-memory
(
system-registered-p
name
)))
; try again after loading from disk if needed
(
when
pathname
(
return
(
setf
(
car
in-memory
)
(
get-file-stamp
pathname
)))
(
cond
(
cdr
in-memory
))
(
in-memory
(
error-p
(
when
pathname
(
error
'missing-component
:requires
name
))
(
setf
(
car
in-memory
)
(
get-file-stamp
pathname
)))
(
t
;; not found: don't keep negative cache, see lp#1335323
(
cdr
in-memory
))
(
unset-asdf-cache-entry
`
(
locate-system
,
name
))
(
error-p
(
return-from
find-system
nil
)))))))))
(
error
'missing-component
:requires
name
))
(
t
(
return-from
find-system
nil
)))))))))))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment