Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Hugo Ishimaru
asdf
Commits
26714b10
Commit
26714b10
authored
Mar 21, 2014
by
Francois-Rene Rideau
Browse files
Tweak ASDF and tests to fix previous commit.
parent
65d72494
Changes
10
Hide whitespace changes
Inline
Side-by-side
cache.lisp
View file @
26714b10
...
...
@@ -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*
)
...
...
find-component.lisp
View file @
26714b10
...
...
@@ -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
)))
...
...
find-system.lisp
View file @
26714b10
...
...
@@ -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
)))))))
test/make-hello-world.lisp
View file @
26714b10
...
...
@@ -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
)))
test/test-program.script
View file @
26714b10
...
...
@@ -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\""
...
...
test/test-retry-loading-component-1.script
View file @
26714b10
...
...
@@ -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*)
)
test/test-sysdef-asdf.script
View file @
26714b10
...
...
@@ -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)
...
...
test/test-touch-system-1.script
View file @
26714b10
...
...
@@ -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))
(
fin
d-system :test1)
(
loa
d-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))
...
...
test/test-touch-system-2.script
View file @
26714b10
...
...
@@ -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)
...
...
test/test1.asd
View file @
26714b10
;;; -*- Lisp -*-
(
asdf:
defsystem
test1
(
defsystem
test1
:components
((
:file
"file2"
:in-order-to
((
compile-op
(
load-op
"file1"
))
(
load-op
(
load-op
"file1"
))))
(
:file
"file1"
)))
...
...
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