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
Didier Verna
asdf
Commits
c2c17558
Commit
c2c17558
authored
Jan 24, 2013
by
Francois-Rene Rideau
Browse files
2.26.145: introduce a stamp cache, to reduce filesystem access,
enhance plan consistency and make testing easier.
parent
201861e2
Changes
19
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
c2c17558
...
...
@@ -17,6 +17,11 @@ endif
## Some are manually tested once in a while.
## MAJOR FAIL: gclcvs -- Compiler bug fixed upstream, but gcl fails to compile on modern Linuxen.
## grep for #+/#- features in the test/ directory to see plenty of disabled tests.
ifdef
ASDF_TEST_SYSTEMS
s
?=
${ASDF_TEST_SYSTEMS}
else
s
?=
fare-all
endif
l
?=
sbcl
...
...
@@ -38,7 +43,7 @@ XCL ?= xcl
header_lisp
:=
header.lisp
driver_lisp
:=
package.lisp common-lisp.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
defsystem_lisp
:=
upgrade.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp
defsystem_lisp
:=
upgrade.lisp component.lisp system.lisp
stamp-cache.lisp
find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp
# Making ASDF itself should be our first, default, target:
build/asdf.lisp
:
$(wildcard *.lisp)
...
...
@@ -128,17 +133,21 @@ test-lisp: build/asdf.lisp
@
cd test
;
${MAKE}
clean
;
./run-tests.sh
${l}
${t}
t
:
test-lisp
test
:
test-lisp test-clean-load doc
test
:
test-lisp test-clean-load test-load-systems doc
test-load-systems
:
./test/run-tests.sh
-l
${l}
${s}
test-all-lisps
:
${MAKE}
test-load-systems
@
for
lisp
in
${lisps}
;
do
\
${MAKE}
test-lisp test-upgrade
l
=
$$
lisp
||
exit
1
;
\
${MAKE}
test-lisp test-upgrade
test-clean-load
l
=
$$
lisp
||
exit
1
;
\
done
# test upgrade is a very long run... This does just the regression tests
test-all-noupgrade
:
@
for
lisp
in
${lisps}
;
do
\
${MAKE}
test-lisp
l
=
$$
lisp
||
exit
1
;
\
${MAKE}
test-lisp
test-clean-load
l
=
$$
lisp
||
exit
1
;
\
done
test-all-upgrade
:
...
...
asdf.asd
View file @
c2c17558
...
...
@@ -14,8 +14,9 @@
;; Note that it's polite to sort the defsystem forms in dependency order,
;; and compulsory to sort them in defsystem-depends-on order.
:version
(
:read-file-form
"version.lisp-expr"
)
:around-compile
call-without-redefinition-warnings
;; we need be the same as asdf-driver
:components
((
:
static-
file
"header
.lisp
"
)))
((
:file
"header"
)))
#+
asdf2.27
(
defsystem
:asdf/defsystem
...
...
@@ -31,17 +32,18 @@
((
:file
"upgrade"
)
(
:file
"component"
:depends-on
(
"upgrade"
))
(
:file
"system"
:depends-on
(
"component"
))
(
:file
"find-system"
:depends-on
(
"system"
))
(
:file
"stamp-cache"
:depends-on
(
"upgrade"
))
(
:file
"find-system"
:depends-on
(
"system"
"stamp-cache"
))
(
:file
"find-component"
:depends-on
(
"find-system"
))
(
:file
"operation"
:depends-on
(
"upgrade"
))
(
:file
"action"
:depends-on
(
"find-component"
"operation"
))
(
:file
"lisp-action"
:depends-on
(
"action"
))
(
:file
"plan"
:depends-on
(
"lisp-action"
))
(
:file
"plan"
:depends-on
(
"lisp-action"
"stamp-cache"
))
(
:file
"operate"
:depends-on
(
"plan"
))
(
:file
"output-translations"
:depends-on
(
"operate"
))
(
:file
"source-registry"
:depends-on
(
"find-system"
))
(
:file
"backward-internals"
:depends-on
(
"lisp-action"
"operate"
))
(
:file
"defsystem"
:depends-on
(
"backward-internals"
))
(
:file
"defsystem"
:depends-on
(
"backward-internals"
"stamp-cache"
))
(
:file
"bundle"
:depends-on
(
"lisp-action"
))
(
:file
"concatenate-source"
:depends-on
(
"bundle"
))
(
:file
"backward-interface"
:depends-on
(
"operate"
"output-translations"
))
...
...
@@ -57,7 +59,7 @@
:licence
"MIT"
:description
"Another System Definition Facility"
:long-description
"ASDF builds Common Lisp software organized into defined systems."
:version
"2.26.14
4
"
;; to be automatically updated by make bump-version
:version
"2.26.14
5
"
;; to be automatically updated by make bump-version
:depends-on
()
:components
((
:module
"build"
...
...
defsystem.lisp
View file @
c2c17558
...
...
@@ -4,7 +4,7 @@
(
asdf/package:define-package
:asdf/defsystem
(
:recycle
:asdf/defsystem
:asdf
)
(
:use
:asdf/common-lisp
:asdf/driver
:asdf/upgrade
:asdf/component
:asdf/system
:asdf/component
:asdf/system
:asdf/stamp-cache
:asdf/find-system
:asdf/find-component
:asdf/lisp-action
:asdf/operate
:asdf/backward-internals
)
(
:export
...
...
@@ -175,7 +175,7 @@
(
source-file
(
if
sfp
source-file
(
resolve-symlinks*
(
load-pathname
))))
(
registered
(
system-registered-p
name
))
(
registered!
(
if
registered
(
rplaca
registered
(
safe
-file-
write-date
source-file
))
(
rplaca
registered
(
get
-file-
stamp
source-file
))
(
register-system
(
make-instance
'system
:name
name
:source-file
source-file
))))
(
system
(
reset-system
(
cdr
registered!
)
...
...
find-system.lisp
View file @
c2c17558
...
...
@@ -4,7 +4,7 @@
(
asdf/package:define-package
:asdf/find-system
(
:recycle
:asdf/find-system
:asdf
)
(
:use
:asdf/common-lisp
:asdf/driver
:asdf/upgrade
:asdf/component
:asdf/system
)
:asdf/component
:asdf/system
:asdf/stamp-cache
)
(
:export
#:remove-entry-from-registry
#:coerce-entry-to-directory
#:coerce-name
#:primary-system-name
...
...
@@ -93,7 +93,7 @@ of which is a system object.")
(
unless
(
eq
system
(
cdr
(
gethash
name
*defined-systems*
)))
(
setf
(
gethash
name
*defined-systems*
)
(
cons
(
if-let
(
file
(
ignore-errors
(
system-source-file
system
)))
(
safe
-file-
write-date
file
))
(
get
-file-
stamp
file
))
system
)))))
(
defun*
clear-system
(
name
)
...
...
@@ -243,9 +243,9 @@ Going forward, we recommend new users should be using the source-registry.
(
defun*
call-with-system-definitions
(
thunk
)
(
if
*systems-being-defined*
(
fun
call
thunk
)
(
call
-with-stamp-cache
thunk
)
(
let
((
*systems-being-defined*
(
make-hash-table
:test
'equal
)))
(
fun
call
thunk
))))
(
call
-with-stamp-cache
thunk
))))
(
defmacro
with-system-definitions
((
&optional
)
&body
body
)
`
(
call-with-system-definitions
#'
(
lambda
()
,@
body
)))
...
...
@@ -316,7 +316,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(
pathname-equal
(
translate-logical-pathname
pathname
)
(
translate-logical-pathname
previous-pathname
))))
(
stamp<=
(
safe
-file-
write-date
pathname
)
previous-time
))))
(
stamp<=
(
get
-file-
stamp
pathname
)
previous-time
))))
;; only load when it's a pathname that is different or has newer content
(
load-sysdef
name
pathname
)))
(
let
((
in-memory
(
system-registered-p
name
)))
; try again after loading from disk if needed
...
...
@@ -324,7 +324,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(
cond
(
in-memory
(
when
pathname
(
setf
(
car
in-memory
)
(
safe
-file-
write-date
pathname
)))
(
setf
(
car
in-memory
)
(
get
-file-
stamp
pathname
)))
(
cdr
in-memory
))
(
error-p
(
error
'missing-component
:requires
name
))))))
...
...
header.lisp
View file @
c2c17558
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.26.14
4
: Another System Definition Facility.
;;; This is ASDF 2.26.14
5
: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
...
...
interface.lisp
View file @
c2c17558
...
...
@@ -10,7 +10,7 @@
#:split
#:make-collector
#:loaded-systems
; makes for annoying SLIME completion
#:output-files-for-system-and-operation
)
; obsolete ASDF-BINARY-LOCATION function
(
:use
:asdf/common-lisp
:asdf/driver
:asdf/upgrade
(
:use
:asdf/common-lisp
:asdf/driver
:asdf/upgrade
:asdf/stamp-cache
:asdf/component
:asdf/system
:asdf/find-system
:asdf/find-component
:asdf/operation
:asdf/action
:asdf/lisp-action
:asdf/output-translations
:asdf/source-registry
...
...
plan.lisp
View file @
c2c17558
...
...
@@ -4,7 +4,8 @@
(
asdf/package:define-package
:asdf/plan
(
:recycle
:asdf/plan
:asdf
)
(
:use
:asdf/common-lisp
:asdf/driver
:asdf/upgrade
:asdf/component
:asdf/operation
:asdf/system
:asdf/find-system
:asdf/find-component
:asdf/component
:asdf/operation
:asdf/system
:asdf/stamp-cache
:asdf/find-system
:asdf/find-component
:asdf/operation
:asdf/action
)
(
:export
#:component-operation-time
#:mark-operation-done
...
...
@@ -196,7 +197,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
stamp
)
(
defmethod
compute-action-stamp
(
plan
(
o
operation
)
(
c
component
)
&key
just-done
)
;; In a distant future,
safe
-file-
write-date
and component-operation-time
;; In a distant future,
get
-file-
stamp
and component-operation-time
;; shall also be parametrized by the plan, or by a second model object.
(
let*
((
stamp-lookup
#'
(
lambda
(
o
c
)
(
if-let
(
it
(
plan-action-status
plan
o
c
))
(
action-stamp
it
)
t
)))
...
...
@@ -211,8 +212,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
(
dep-stamp
(
visit-dependencies
plan
o
c
stamp-lookup
))
;; Time stamps from the files at hand, and whether any is missing
(
out-stamps
(
mapcar
#'
safe-file-write-date
out-files
))
(
in-stamps
(
mapcar
#'
safe
-file-
write-date
in-files
))
(
out-stamps
(
mapcar
(
if
just-done
'register-file-stamp
'get-file-stamp
)
out-files
))
(
in-stamps
(
mapcar
#'
get
-file-
stamp
in-files
))
(
missing-in
(
loop
:for
f
:in
in-files
:for
s
:in
in-stamps
:unless
s
:collect
f
))
(
missing-out
...
...
stamp-cache.lisp
0 → 100644
View file @
c2c17558
;;;; -------------------------------------------------------------------------
;;;; Stamp cache
(
asdf/package:define-package
:asdf/stamp-cache
(
:use
:asdf/common-lisp
:asdf/driver
:asdf/upgrade
)
(
:export
#:get-file-stamp
#:compute-file-stamp
#:register-file-stamp
#:call-with-stamp-cache
#:with-stamp-cache
#:*stamp-cache*
))
(
in-package
:asdf/stamp-cache
)
;;; This stamp cache is useful for:
;; * consistency of stamps used within a single run
;; * fewer accesses to the filesystem
;; * the ability to test with fake timestamps, without touching files
(
defvar
*stamp-cache*
nil
)
(
defun
compute-file-stamp
(
file
)
(
safe-file-write-date
file
))
(
defun
register-file-stamp
(
file
&optional
(
stamp
(
compute-file-stamp
file
)))
(
if
*stamp-cache*
(
setf
(
gethash
file
*stamp-cache*
)
stamp
)
stamp
))
(
defun
get-file-stamp
(
file
)
(
if
*stamp-cache*
(
multiple-value-bind
(
stamp
foundp
)
(
gethash
file
*stamp-cache*
)
(
if
foundp
stamp
(
register-file-stamp
file
)))
(
compute-file-stamp
file
)))
(
defun
call-with-stamp-cache
(
thunk
&key
override
)
(
if
(
and
*stamp-cache*
(
not
override
))
(
funcall
thunk
)
(
let
((
*stamp-cache*
(
make-hash-table
:test
'equal
)))
(
funcall
thunk
))))
(
defmacro
with-stamp-cache
((
&key
override
)
&body
body
)
`
(
call-with-stamp-cache
#'
(
lambda
()
,@
body
)
:override
,
override
))
test/run-tests.sh
View file @
c2c17558
...
...
@@ -17,11 +17,13 @@ usage () {
echo
" -d -- debug mode"
echo
" -h -- show this message."
echo
" -u -- upgrade tests."
echo
" -c -- clean load test"
echo
" -l -- load systems tests"
}
unset
DEBUG_ASDF_TEST upgrade clean_load
unset
DEBUG_ASDF_TEST upgrade clean_load
load_systems
while
getopts
"
duhc
"
OPTION
while
getopts
"
cdhulhu
"
OPTION
do
case
$OPTION
in
d
)
...
...
@@ -33,6 +35,9 @@ do
c
)
clean_load
=
t
;;
l
)
load_systems
=
t
;;
h
)
usage
exit
1
...
...
@@ -354,11 +359,21 @@ test_clean_load () {
echo
"BAD: Loading ASDF on
$lisp
produces messages"
>
&2
;
return
1
fi
}
test_load_systems
()
{
case
$lisp
in
gcl
)
return
0
;;
# This one is hopeless
esac
${
cmd
}
${
eval
}
\
"(or #.(load
\"
test/script-support.lisp
\"
) #.(asdf-test::with-test () (asdf-test::test-load-systems
${
s
}
)))"
\
2>&1 |
tee
build/results/
${
lisp
}
-systems
.text
}
if
[
-z
"
$cmd
"
]
;
then
echo
"Error: cannot find or do not know how to run Lisp named
$lisp
"
elif
[
-n
"
$clean_load
"
]
;
then
test_clean_load
elif
[
-n
"
$load_systems
"
]
;
then
test_load_systems
elif
[
-n
"
$upgrade
"
]
;
then
run_upgrade_tests
else
...
...
test/script-support.lisp
View file @
c2c17558
...
...
@@ -13,7 +13,7 @@ Some constraints:
(
defpackage
:asdf-test
(
:use
:common-lisp
)
(
:export
#:asym
#:acall
#:asym
#:acall
#:asymval
#:*test-directory*
#:*asdf-directory*
#:load-asdf
#:maybe-compile-asdf
#:load-asdf-lisp
#:compile-asdf
#:load-asdf-fasl
...
...
@@ -75,13 +75,23 @@ Some constraints:
(
namestring
(
make-pathname
:name
nil
:type
nil
:defaults
path
))))))
;;; Survival utilities
(
defun
asym
(
name
)
(
let
((
asdf
(
find-package
:asdf
)))
(
unless
asdf
(
error
"Can't find package ASDF"
))
(
or
(
find-symbol
(
string
name
)
asdf
)
(
error
"Can't find symbol ~A in ASDF"
name
))))
(
defun
asym
(
name
&optional
package
(
errorp
t
))
(
let*
((
pname
(
or
package
:asdf
))
(
package
(
find-package
pname
)))
(
if
package
(
or
(
find-symbol
(
string
name
)
package
)
(
when
errorp
(
error
"Can't find symbol ~A in ~A"
name
pname
)))
(
when
errorp
(
error
"Can't find package ~A"
pname
)))))
(
defun
acall
(
name
&rest
args
)
(
apply
(
asym
name
)
args
))
(
apply
(
apply
'asym
(
if
(
consp
name
)
name
(
list
name
)))
args
))
(
defun
asymval
(
name
&optional
package
)
(
symbol-value
(
asym
name
package
)))
(
defsetf
asymval
(
name
&optional
package
)
(
new-value
)
;; NB: defun setf won't work on GCL2.6
(
let
((
sym
(
gensym
"SYM"
)))
`
(
let
((
,
sym
(
asym
,
name
,
package
)))
(
if
,
sym
(
setf
(
symbol-value
,
sym
)
,
new-value
)
(
error
"NIHIL EX NIHILO"
)))))
(
defun
finish-outputs*
()
(
loop
:for
s
:in
(
list
*standard-output*
*error-output*
*trace-output*
*debug-io*
)
...
...
@@ -93,7 +103,49 @@ Some constraints:
(
redirect-outputs
)
;; Put everything on standard output, for the sake of scripts
;;; First, some pathname madness.
;;; Helpful for debugging
(
defun
pathname-components
(
p
)
(
when
p
(
let
((
p
(
pathname
p
)))
(
list
:host
(
pathname-host
p
)
:device
(
pathname-device
p
)
:directory
(
pathname-directory
p
)
:name
(
pathname-name
p
)
:type
(
pathname-type
p
)
:version
(
pathname-version
p
)))))
(
defun
assert-pathname-equal-helper
(
qx
x
qy
y
)
(
cond
((
equal
x
y
)
(
format
t
"~S and ~S both evaluate to same path:~% ~S~%"
qx
qy
x
))
((
acall
:pathname-equal
x
y
)
(
format
t
"These two expressions yield pathname-equal yet not equal path~% ~S~%"
x
)
(
format
t
"the first expression ~S yields this:~% ~S~%"
qx
(
pathname-components
x
))
(
format
t
"the other expression ~S yields that:~% ~S~%"
qy
(
pathname-components
y
)))
(
t
(
format
t
"These two expressions yield paths that are not pathname-equal~%"
)
(
format
t
"the first expression ~S yields this:~% ~S~% ~S~%"
qx
x
(
pathname-components
x
))
(
format
t
"the other expression ~S yields that:~% ~S~% ~S~%"
qy
y
(
pathname-components
y
)))))
(
defmacro
assert-pathname-equal
(
x
y
)
`
(
assert-pathname-equal-helper
',x
,
x
',y
,
y
))
(
defun
assert-length-equal-helper
(
qx
qy
x
y
)
(
unless
(
=
(
length
x
)
(
length
y
))
(
format
t
"These two expressions yield sequences of unequal length~%"
)
(
format
t
"The first, ~S, has value ~S of length ~S~%"
qx
x
(
length
x
))
(
format
t
"The other, ~S, has value ~S of length ~S~%"
qy
y
(
length
y
))))
(
defun
assert-pathnames-equal-helper
(
qx
x
qy
y
)
(
assert-length-equal-helper
qx
x
qy
y
)
(
loop
:for
n
:from
0
:for
qpx
=
`
(
nth
,
n
,
qx
)
:for
qpy
=
`
(
nth
,
n
,
qy
)
:for
px
:in
x
:for
py
:in
y
:do
(
assert-pathname-equal-helper
qpx
px
qpy
py
)))
(
defmacro
assert-pathnames-equal
(
x
y
)
`
(
assert-pathnames-equal-helper
',x
,
x
',y
,
y
))
;; More pathname madness.
;; We can't use goodies from asdf/pathnames because ASDF isn't loaded yet.
;; We still want to work despite and host/device funkiness,
;; so we do it the hard way.
...
...
@@ -143,7 +195,6 @@ Some constraints:
(
defun
asdf-fasl
(
&optional
tag
)
(
early-compile-file-pathname
(
asdf-lisp
tag
)))
;;; Test helper functions
(
load
(
debug-lisp
))
...
...
@@ -155,21 +206,29 @@ Some constraints:
(
defun
assert-compare-helper
(
op
qx
qy
x
y
)
(
unless
(
funcall
op
x
y
)
(
error
"These two expressions fail comparison with ~S:~%~
(
error
"These two expressions fail comparison with ~S:~%
~
~S evaluates to ~S~% ~S evaluates to ~S~%"
op
qx
x
qy
y
)))
(
defmacro
assert-equal
(
x
y
)
`
(
assert-compare
(
equal
,
x
,
y
)))
(
defun
touch-file
(
file
&key
(
offset
0
)
timestamp
)
(
let
((
timestamp
(
or
timestamp
(
+
offset
(
get-universal-time
)))))
(
multiple-value-bind
(
sec
min
hr
day
month
year
)
(
decode-universal-time
timestamp
#+
gcl2.6
-5
)
(
acall
:run-program
`
(
"touch"
"-t"
,
(
format
nil
"~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D"
year
month
day
hr
min
sec
)
,
(
namestring
file
)))
(
assert-equal
(
file-write-date
file
)
timestamp
))))
(
defun
touch-file
(
file
&key
offset
timestamp
)
(
let*
((
base
(
or
timestamp
(
get-universal-time
)))
(
stamp
(
if
offset
(
+
base
offset
)
base
)))
(
if
(
asymval
:*stamp-cache*
)
(
acall
:register-file-stamp
file
stamp
)
(
multiple-value-bind
(
sec
min
hr
day
month
year
)
(
decode-universal-time
stamp
#+
gcl2.6
-5
)
;; -5 is for *my* localtime
(
error
"Y U NO use stamp cache?"
)
(
acall
:run-program
`
(
"touch"
"-t"
,
(
format
nil
"~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D"
year
month
day
hr
min
sec
)
,
(
acall
:native-namestring
file
)))
(
assert-equal
(
file-write-date
file
)
stamp
)))))
(
defun
mark-file-deleted
(
file
)
(
unless
(
asymval
:*stamp-cache*
)
(
error
"Y U NO use stamp cache?"
))
(
acall
:register-file-stamp
file
nil
))
(
defun
hash-table->alist
(
table
)
(
loop
:for
key
:being
:the
:hash-keys
:of
table
:using
(
:hash-value
value
)
...
...
@@ -231,7 +290,7 @@ is bound, write a message and exit on an error. If
(
acall
:print-condition-backtrace
c
:count
69
:stream
*error-output*
))
(
leave-test
"Script failed"
1
))))))
(
funcall
thunk
)
(
funcall
(
or
(
asym
:call-with-stamp-cache
:asdf
nil
)
'funcall
)
thunk
)
(
leave-test
"Script succeeded"
0
)))))
(
when
*quit-when-done*
(
exit-lisp
result
))))
...
...
@@ -421,13 +480,23 @@ is bound, write a message and exit on an error. If
:ignore-inherited-configuration
))
(
set
(
asym
:*central-registry*
)
`
(
,
*test-directory*
))
(
set
(
asym
:*verbose-out*
)
*standard-output*
)
(
set
(
asym
:*asdf-verbose*
)
t
))
(
set
(
asym
:*asdf-verbose*
)
t
)
(
let
((
x
(
acall
:system-source-directory
:hello-world-example
)))
(
assert-pathname-equal
*test-directory*
x
)
;; not always EQUAL (!)
(
unless
(
equal
*test-directory*
x
)
(
format
t
"Interestingly, while *test-directory* has components~% ~S~%~
ASDF finds the ASDs in~% ~S~%Using the latter.~%"
(
pathname-components
*test-directory*
)
(
pathname-components
x
)))
(
setf
*test-directory*
x
))
t
)
(
defun
load-asdf
(
&optional
tag
)
#+
gcl2.6
(
load-asdf-lisp
tag
)
#-
gcl2.6
(
load-asdf-fasl
tag
)
(
use-package
:asdf
:asdf-test
)
(
use-package
:asdf/driver
:asdf-test
)
(
use-package
:asdf/stamp-cache
:asdf-test
)
(
configure-asdf
)
(
setf
*package*
(
find-package
:asdf-test
)))
...
...
@@ -449,48 +518,15 @@ is bound, write a message and exit on an error. If
(
defun
in-plan-p
(
plan
x
)
(
member
x
plan
:key
(
asym
:action-path
)
:test
'equal
))
;;; Helpful for debugging
(
defun
pathname-components
(
p
)
(
when
p
(
let
((
p
(
pathname
p
)))
(
list
:host
(
pathname-host
p
)
:device
(
pathname-device
p
)
:directory
(
pathname-directory
p
)
:name
(
pathname-name
p
)
:type
(
pathname-type
p
)
:version
(
pathname-version
p
)))))
(
defun
assert-pathname-equal-helper
(
qx
x
qy
y
)
(
cond
((
equal
x
y
)
(
format
t
"~S and ~S both evaluate to same path:~% ~S~%"
qx
qy
x
))
((
acall
:pathname-equal
x
y
)
(
format
t
"These two expressions yield pathname-equal yet not equal path~% ~S~%"
x
)
(
format
t
"the first expression ~S yields this:~% ~S~%"
qx
(
pathname-components
x
))
(
format
t
"the other expression ~S yields that:~% ~S~%"
qy
(
pathname-components
y
)))
(
t
(
format
t
"These two expressions yield paths that are not pathname-equal~%"
)
(
format
t
"the first expression ~S yields this:~% ~S~% ~S~%"
qx
x
(
pathname-components
x
))
(
format
t
"the other expression ~S yields that:~% ~S~% ~S~%"
qy
y
(
pathname-components
y
)))))
(
defmacro
assert-pathname-equal
(
x
y
)
`
(
assert-pathname-equal-helper
',x
,
x
',y
,
y
))
(
defun
assert-length-equal-helper
(
qx
qy
x
y
)
(
unless
(
=
(
length
x
)
(
length
y
))
(
format
t
"These two expressions yield sequences of unequal length~%"
)
(
format
t
"The first, ~S, has value ~S of length ~S~%"
qx
x
(
length
x
))
(
format
t
"The other, ~S, has value ~S of length ~S~%"
qy
y
(
length
y
))))
(
defun
assert-pathnames-equal-helper
(
qx
x
qy
y
)
(
assert-length-equal-helper
qx
x
qy
y
)
(
loop
:for
n
:from
0
:for
qpx
=
`
(
nth
,
n
,
qx
)
:for
qpy
=
`
(
nth
,
n
,
qy
)
:for
px
:in
x
:for
py
:in
y
:do
(
assert-pathname-equal-helper
qpx
px
qpy
py
)))
(
defmacro
assert-pathnames-equal
(
x
y
)
`
(
assert-pathnames-equal-helper
',x
,
x
',y
,
y
))
(
defmacro
test-load-systems
(
&rest
x
)
`
(
do-test-load-systems
',x
))
(
defun
do-test-load-systems
(
systems
)
(
load-asdf-lisp
)
(
dolist
(
sys
systems
)
(
format
t
"~&Trying to load ~A~%"
sys
)
(
acall
:load-system
sys
))
(
format
t
"~&Done!~%"
))
;; These are shorthands for interactive debugging of test scripts:
(
!a
...
...
test/test-encodings.script
View file @
c2c17558
...
...
@@ -19,19 +19,19 @@
#+sbcl sb-impl::*default-external-format*
#-(or clozure sbcl) (error "can't determine default external-format")))))
(defmacro with-encoding-test ((encoding &key (op '
asdf:
load-source-op) (path "lambda")) def-test-system &body body)
(defmacro with-encoding-test ((encoding &key (op 'load-source-op) (path "lambda")) def-test-system &body body)
(let ((sys (second def-test-system)))
`(
progn
`(
with-stamp-cache (:override t)
(format t "~&Test ~A: should be ~A~%" ',sys ',encoding)
(setf *lambda-string* nil)
,def-test-system
(let ((c (
asdf:
find-component ',sys ',path)))
(let ((c (find-component ',sys ',path)))
;; mlisp has an issue of :LATIN-2 vs :latin-2. Smooth things with string-equal.
(assert-compare (string-equal (
asdf:
component-encoding c) ',encoding))
(loop :for o :in (
asdf:
output-files
(asdf::make-operation 'asdf:
compile-op
)
c)
:do (
asdf::
delete-file-if-exists o)))
(assert-compare (string-equal (component-encoding c) ',encoding))
(loop :for o :in (output-files
'
compile-op c)
:do (delete-file-if-exists o)))
,@(when op
`((
asdf:
operate ',op ',(second def-test-system))))
`((operate ',op ',(second def-test-system))))
,@body
(eval `(assert-equal (string-char-codes ,*lambda-string*)
(expected-char-codes ',',encoding))))))
...
...
@@ -72,7 +72,7 @@
(initialize-source-registry `(:source-registry :ignore-inherited-configuration))
(
asdf:
load-system :asdf-encodings)
(load-system :asdf-encodings)
#-lispworks
(with-encoding-test (:latin-2)
(def-test-system :test-encoding-implicit-autodetect
...
...
@@ -90,11 +90,11 @@
(def-test-system :test-file-encoding-l1
:encoding :utf-8
:components ((:file "lambda" :encoding :latin-1))))
(with-encoding-test (:utf-8 :op
asdf:
load-source-op)
(with-encoding-test (:utf-8 :op load-source-op)
(def-test-system :test-system-encoding-u8
:encoding :utf-8
:components ((:file "lambda"))))
(with-encoding-test (:utf-8 :op
asdf:
load-op)
(with-encoding-test (:utf-8 :op load-op)
(def-test-system :test-system-encoding-u8-load-op
:encoding :utf-8
:components ((:file "lambda"))))
...
...
@@ -103,7 +103,7 @@
:encoding :latin-1
:components ((:file "lambda"))))
#-ecl-bytecmp
(with-encoding-test (:latin-1 :op
asdf:
load-op)
(with-encoding-test (:latin-1 :op load-op)
(def-test-system :test-system-encoding-l1-load-op
:encoding :latin-1
:components ((:file "lambda"))))
...
...
test/test-force.script
View file @
c2c17558
;;; -*- Lisp -*-
(asdf:operate 'asdf:load-op 'test-force)
(load-system 'test-force)
(defparameter file1 (test-fasl "file1"))
(defparameter file1-date (file-write-date file1))
...
...
@@ -16,9 +14,9 @@
(touch-file "test-force.asd" :timestamp date1)
(touch-file "file1.lisp" :timestamp date1)
(touch-file file1 :timestamp date2)
(
asdf:operate 'asdf:load-op
'test-force)
(assert (equal (file-
write-date
file1) date2))
(
load-system
'test-force)
(assert (equal (
get-
file-
stamp
file1) date2))
;; forced, it should be later
(
asdf:operate 'asdf:load-op
'test-force :force t)
(assert (>= (file-
write-date
file1) file1-date))
(
load-system
'test-force :force t)
(assert (>= (
get-
file-
stamp
file1) file1-date))
test/test-static-and-serial.script
View file @
c2c17558
...
...
@@ -26,7 +26,7 @@ don't cause full rebuilds all the time...
(defparameter date3 (- file1-date 150))
(assert file1-date)
(assert (sym
bol-value (find-symbol (symbol-name
:*file1*
)
:test-package))
)
(assert (
a
sym
val
:*file1* :test-package))
(format t "file: ~S~%date: ~S~%" file1 file1-date)
;; date should stay same
...
...
@@ -38,5 +38,5 @@ don't cause full rebuilds all the time...
(touch-file "file1.lisp" :timestamp date2)
(touch-file file1 :timestamp date3)
(DBG "load again" (oos 'load-op 'static-and-serial))
(assert (sym
bol-value (find-symbol (symbol-name
:*file1*
)
:test-package))
)
(assert-equal (file-
write-date
file1) date3)
(assert (
a
sym
val
:*file1* :test-package))
(assert-equal (
get-
file-
stamp
file1) date3)
test/test-sysdef-asdf.script
View file @
c2c17558
;;; -*- Lisp -*-
(initialize-source-registry
'(:source-registry :ignore-inherited-configuration))
(load-system :asdf)