Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
asdf
asdf
Commits
ff9e3cb3
Commit
ff9e3cb3
authored
Jan 02, 2013
by
Francois-Rene Rideau
Browse files
2.26.49: Debug GCL 2.6 support, fix tests to work with its limitations.
Remove debugging code from previous commit.
parent
e51b3aca
Changes
14
Hide whitespace changes
Inline
Side-by-side
asdf.asd
View file @
ff9e3cb3
...
@@ -14,7 +14,7 @@
...
@@ -14,7 +14,7 @@
:licence
"MIT"
:licence
"MIT"
:description
"Another System Definition Facility"
:description
"Another System Definition Facility"
:long-description
"ASDF builds Common Lisp software organized into defined systems."
:long-description
"ASDF builds Common Lisp software organized into defined systems."
:version
"2.26.4
8
"
;; to be automatically updated by bin/bump-revision
:version
"2.26.4
9
"
;; to be automatically updated by bin/bump-revision
:depends-on
()
:depends-on
()
:components
:components
((
:file
"asdf"
)))
((
:file
"asdf"
)))
...
...
asdf.lisp
View file @
ff9e3cb3
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.4
8
: Another System Definition Facility.
;;; This is ASDF 2.26.4
9
: Another System Definition Facility.
;;;
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
;;; please mail to <asdf-devel@common-lisp.net>.
...
@@ -79,7 +79,8 @@
...
@@ -79,7 +79,8 @@
(
make-package
:asdf
:use
'
(
:common-lisp
))))
(
make-package
:asdf
:use
'
(
:common-lisp
))))
#+
gcl
(
defpackage
:asdf
(
:use
:cl
)
;; GCL treats defpackage magically and needs this
#+
gcl
(
defpackage
:asdf
(
:use
:cl
)
;; GCL treats defpackage magically and needs this
#+
gcl<2.7
(
:shadowing-import-from
:system
:*load-pathname*
))
#+
gcl<2.7
(
:shadowing-import-from
:system
:*load-pathname*
)
;; GCL 2.6 sucks
#+
gcl<2.7
(
:shadow
:type-of
))
(
in-package
:asdf
)
(
in-package
:asdf
)
...
@@ -119,7 +120,7 @@
...
@@ -119,7 +120,7 @@
;; "2.345.6" would be a development version in the official upstream
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(
asdf-version
"2.26.4
8
"
)
(
asdf-version
"2.26.4
9
"
)
(
existing-asdf
(
find-class
'component
nil
))
(
existing-asdf
(
find-class
'component
nil
))
(
existing-version
*asdf-version*
)
(
existing-version
*asdf-version*
)
(
already-there
(
equal
asdf-version
existing-version
)))
(
already-there
(
equal
asdf-version
existing-version
)))
...
@@ -494,7 +495,7 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
...
@@ -494,7 +495,7 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
(
fs:create-directories-recursively
(
pathname
path
))))
(
fs:create-directories-recursively
(
pathname
path
))))
#+
gcl<2.7
#+
gcl<2.7
(
progn
(
progn
;; Doesn't support either logical-pathnames or output-translations.
(
deftype
logical-pathname
()
nil
)
(
deftype
logical-pathname
()
nil
)
(
defun
wild-pathname-p
(
path
)
(
declare
(
ignore
path
))
nil
)
(
defun
wild-pathname-p
(
path
)
(
declare
(
ignore
path
))
nil
)
(
defun
translate-logical-pathname
(
x
)
x
)
(
defun
translate-logical-pathname
(
x
)
x
)
...
@@ -503,8 +504,9 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
...
@@ -503,8 +504,9 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
(
declare
(
ignore
in-wildname
wild-wildname
))
nil
)
(
declare
(
ignore
in-wildname
wild-wildname
))
nil
)
(
defun
translate-pathname
(
source
from-wildname
to-wildname
&key
)
(
defun
translate-pathname
(
source
from-wildname
to-wildname
&key
)
(
declare
(
ignore
from-wildname
to-wildname
))
source
)
(
declare
(
ignore
from-wildname
to-wildname
))
source
)
(
defun
type-of
(
x
)
(
class-name
(
class-of
x
)))
(
defun
%print-unreadable-object
(
object
stream
type
identity
thunk
)
(
defun
%print-unreadable-object
(
object
stream
type
identity
thunk
)
(
format
stream
"<~@[~S ~]
"
(
when
type
(
class-name
(
class
-of
object
)))
)
(
format
stream
"
#
<~@[~S ~]"
(
when
type
(
type
-of
object
)))
(
funcall
thunk
)
(
funcall
thunk
)
(
format
stream
"~@[ ~X~]>"
(
when
identity
(
system:address
object
))))
(
format
stream
"~@[ ~X~]>"
(
when
identity
(
system:address
object
))))
(
defmacro
with-compilation-unit
(
options
&body
body
)
(
defmacro
with-compilation-unit
(
options
&body
body
)
...
@@ -517,22 +519,6 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
...
@@ -517,22 +519,6 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
;;;; -------------------------------------------------------------------------
;;;; -------------------------------------------------------------------------
;;;; General Purpose Utilities
;;;; General Purpose Utilities
(
defmacro
DBG
(
tag
&rest
exprs
)
"simple debug statement macro:
outputs a tag plus a list of variable and their values, returns the last value"
;"if not in debugging mode, just compute and return last value"
; #-do-test (declare (ignore tag)) #-do-test (car (last exprs)) #+do-test
(
let
((
res
(
gensym
))(
f
(
gensym
)))
`
(
let
(
,
res
(
*print-readably*
nil
))
(
flet
((
,
f
(
fmt
&rest
args
)
(
apply
#'
format
*error-output*
fmt
args
)))
(
,
f
"~&~A~%"
,
tag
)
,@
(
mapcan
#'
(
lambda
(
x
)
`
((
,
f
"~& ~S => "
',x
)
(
,
f
"~{~S~^ ~}~%"
(
setf
,
res
(
multiple-value-list
,
x
)))))
exprs
)
(
apply
'values
,
res
)))))
(
macrolet
(
macrolet
((
defdef
(
def*
def
)
((
defdef
(
def*
def
)
`
(
defmacro
,
def*
(
name
formals
&rest
rest
)
`
(
defmacro
,
def*
(
name
formals
&rest
rest
)
...
@@ -577,18 +563,19 @@ and NIL NAME, TYPE and VERSION components"
...
@@ -577,18 +563,19 @@ and NIL NAME, TYPE and VERSION components"
(
defun*
normalize-pathname-directory-component
(
directory
)
(
defun*
normalize-pathname-directory-component
(
directory
)
"Given a pathname directory component, return an equivalent form that is a list"
"Given a pathname directory component, return an equivalent form that is a list"
#+
gcl<2.7
(
setf
directory
(
substitute
:back
:parent
directory
))
(
cond
(
cond
#-
(
or
cmu
sbcl
scl
)
;; these implementations already normalize directory components.
#-
(
or
cmu
sbcl
scl
)
;; these implementations already normalize directory components.
((
stringp
directory
)
`
(
:absolute
,
directory
))
((
stringp
directory
)
`
(
:absolute
,
directory
))
#+
gcl<2.7
#+
gcl<2.7
((
and
(
consp
directory
)
(
stringp
(
first
directory
)))
`
(
:relative
,@
directory
))
#+
gcl<2.7
((
and
(
consp
directory
)
(
eq
:root
(
first
directory
)))
((
and
(
consp
directory
)
(
eq
:root
(
first
directory
)))
`
(
:absolute
,@
(
rest
directory
)))
`
(
:absolute
,@
(
rest
directory
)))
((
or
(
null
directory
)
((
or
(
null
directory
)
(
and
(
consp
directory
)
(
member
(
first
directory
)
'
(
:absolute
:relative
))))
(
and
(
consp
directory
)
(
member
(
first
directory
)
'
(
:absolute
:relative
))))
directory
)
directory
)
#+
gcl<2.7
((
consp
directory
)
`
(
:relative
,@
directory
))
(
t
(
t
(
error
(
compatfmt
"~@<Unrecognized pathname directory component ~S~@:>"
)
directory
))))
(
error
(
compatfmt
"~@<Unrecognized pathname directory component ~S~@:>"
)
directory
))))
...
@@ -623,16 +610,15 @@ and NIL NAME, TYPE and VERSION components"
...
@@ -623,16 +610,15 @@ and NIL NAME, TYPE and VERSION components"
#+
clisp
(
cons
(
mapcar
'make-pathname-component-logical
x
))
#+
clisp
(
cons
(
mapcar
'make-pathname-component-logical
x
))
(
t
x
)))
(
t
x
)))
(
defun*
denormalize-pathname-directory-component
(
directory
)
(
defun*
denormalize-pathname-directory-component
(
directory
-component
)
#-
gcl<2.7
directory
#-
gcl<2.7
directory
-component
#+
gcl<2.7
#+
gcl<2.7
(
cond
(
let
((
d
(
substitute-if
:parent
(
lambda
(
x
)
(
member
x
'
(
:up
:back
)))
((
and
(
consp
directory
)
(
eq
:relative
(
first
directory
)))
directory-component
)))
(
rest
directory
))
(
cond
((
and
(
consp
directory
)
(
eq
:absolute
(
first
directory
)))
((
and
(
consp
d
)
(
eq
:relative
(
first
d
)))
(
rest
d
))
`
(
:root
,@
(
rest
directory
)))
((
and
(
consp
d
)
(
eq
:absolute
(
first
d
)))
`
(
:root
,@
(
rest
d
)))
(
t
(
t
d
))))
directory
)))
(
defun*
make-pathname*
(
&key
host
device
directory
name
type
version
defaults
)
(
defun*
make-pathname*
(
&key
host
device
directory
name
type
version
defaults
)
(
make-pathname
(
make-pathname
...
@@ -2171,7 +2157,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
...
@@ -2171,7 +2157,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(
format
stream
"~{~S~^ ~}"
(
operation-original-initargs
o
)))))
(
format
stream
"~{~S~^ ~}"
(
operation-original-initargs
o
)))))
(
defun*
node-for
(
o
c
)
(
defun*
node-for
(
o
c
)
(
cons
(
class-name
(
class
-of
o
)
)
c
))
(
cons
(
type
-of
o
)
c
))
(
defmethod
operation-ancestor
((
o
operation
))
(
defmethod
operation-ancestor
((
o
operation
))
(
aif
(
operation-parent
o
)
(
aif
(
operation-parent
o
)
...
@@ -2436,7 +2422,6 @@ If true, an integer indexing the action in the list of actions planned."))
...
@@ -2436,7 +2422,6 @@ If true, an integer indexing the action in the list of actions planned."))
(
operation-description
o
c
)
(
operation-description
o
c
)
missing-in
(
length
missing-in
)
(
and
missing-in
missing-out
)
missing-in
(
length
missing-in
)
(
and
missing-in
missing-out
)
missing-out
(
length
missing-out
)))
missing-out
(
length
missing-out
)))
;;(DBG :cas o c just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c))
;; Note that we use stamp<= instead of stamp< to play nice with generated files.
;; Note that we use stamp<= instead of stamp< to play nice with generated files.
;; Any race condition is intrinsic to the limited timestamp resolution.
;; Any race condition is intrinsic to the limited timestamp resolution.
(
if
(
or
just-done
;; The done-stamp is valid: if we're just done, or
(
if
(
or
just-done
;; The done-stamp is valid: if we're just done, or
...
@@ -2484,7 +2469,6 @@ If true, an integer indexing the action in the list of actions planned."))
...
@@ -2484,7 +2469,6 @@ If true, an integer indexing the action in the list of actions planned."))
(
defmethod
traverse-action
(
plan
operation
component
needed-in-image-p
)
(
defmethod
traverse-action
(
plan
operation
component
needed-in-image-p
)
(
block
nil
(
block
nil
;;(DBG :ta operation component needed-in-image-p (plan-visiting-action-list plan))
(
unless
(
action-valid-p
operation
component
)
(
return
nil
))
(
unless
(
action-valid-p
operation
component
)
(
return
nil
))
(
plan-record-dependency
plan
operation
component
)
(
plan-record-dependency
plan
operation
component
)
(
let*
((
aniip
(
needed-in-image-p
operation
component
))
(
let*
((
aniip
(
needed-in-image-p
operation
component
))
...
@@ -2492,7 +2476,6 @@ If true, an integer indexing the action in the list of actions planned."))
...
@@ -2492,7 +2476,6 @@ If true, an integer indexing the action in the list of actions planned."))
(
status
(
plan-action-status
plan
operation
component
)))
(
status
(
plan-action-status
plan
operation
component
)))
(
when
(
and
status
(
or
(
action-done-p
status
)
(
action-planned-p
status
)
(
not
eniip
)))
(
when
(
and
status
(
or
(
action-done-p
status
)
(
action-planned-p
status
)
(
not
eniip
)))
;; Already visited with sufficient need-in-image level: just return the stamp.
;; Already visited with sufficient need-in-image level: just return the stamp.
;;(DBG :ad status eniip aniip)
(
return
(
action-stamp
status
)))
(
return
(
action-stamp
status
)))
(
labels
((
visit-action
(
niip
)
(
labels
((
visit-action
(
niip
)
(
visit-dependencies
operation
component
(
visit-dependencies
operation
component
...
@@ -2500,7 +2483,6 @@ If true, an integer indexing the action in the list of actions planned."))
...
@@ -2500,7 +2483,6 @@ If true, an integer indexing the action in the list of actions planned."))
(
multiple-value-bind
(
stamp
done-p
)
(
multiple-value-bind
(
stamp
done-p
)
(
compute-action-stamp
operation
component
:plan
plan
)
(
compute-action-stamp
operation
component
:plan
plan
)
(
let
((
add-to-plan-p
(
or
(
eql
stamp
t
)
(
and
niip
(
not
done-p
)))))
(
let
((
add-to-plan-p
(
or
(
eql
stamp
t
)
(
and
niip
(
not
done-p
)))))
;;(DBG :va operation component needed-in-image-p niip aniip eniip done-p stamp add-to-plan-p)
(
cond
(
cond
((
and
add-to-plan-p
(
not
niip
))
;; if we need to do it,
((
and
add-to-plan-p
(
not
niip
))
;; if we need to do it,
(
visit-action
t
))
;; then we need to do it in the image!
(
visit-action
t
))
;; then we need to do it in the image!
...
@@ -2745,7 +2727,8 @@ If true, an integer indexing the action in the list of actions planned."))
...
@@ -2745,7 +2727,8 @@ If true, an integer indexing the action in the list of actions planned."))
(
defmethod
perform
((
o
load-source-op
)
(
c
cl-source-file
))
(
defmethod
perform
((
o
load-source-op
)
(
c
cl-source-file
))
(
declare
(
ignorable
o
))
(
declare
(
ignorable
o
))
(
call-with-around-compile-hook
(
call-with-around-compile-hook
c
#'
(
lambda
()
(
load
(
component-pathname
c
)
:external-format
(
component-external-format
c
)))))
c
#'
(
lambda
()
(
load
(
component-pathname
c
)
#-
gcl<2.7
:external-format
#-
gcl<2.7
(
component-external-format
c
)))))
(
defmethod
perform
((
o
load-source-op
)
(
c
static-file
))
(
defmethod
perform
((
o
load-source-op
)
(
c
static-file
))
(
declare
(
ignorable
o
c
))
(
declare
(
ignorable
o
c
))
...
...
test/script-support.lisp
View file @
ff9e3cb3
...
@@ -51,14 +51,14 @@
...
@@ -51,14 +51,14 @@
#+
scl
:scl
#+
scl
:scl
#+
xcl
:xcl
))))
#+
xcl
:xcl
))))
(
merge-pathnames
(
merge-pathnames
(
make-pathname
:directory
`
(
#-
gcl
:relative
"tmp"
"fasls"
,
impl
)
(
make-pathname
:directory
`
(
#-
gcl
<2.7
:relative
"tmp"
"fasls"
,
impl
)
:defaults
*asdf-directory*
)
:defaults
*asdf-directory*
)
*asdf-lisp*
))))
*asdf-lisp*
))))
(
defun
load-old-asdf
(
tag
)
(
defun
load-old-asdf
(
tag
)
(
let
((
old-asdf
(
let
((
old-asdf
(
merge-pathnames
(
merge-pathnames
(
make-pathname
:directory
`
(
#-
gcl
:relative
"tmp"
)
(
make-pathname
:directory
`
(
#-
gcl
<2.7
:relative
"tmp"
)
:name
(
format
nil
"asdf-~A"
tag
)
:name
(
format
nil
"asdf-~A"
tag
)
:defaults
*asdf-directory*
)
:defaults
*asdf-directory*
)
*asdf-lisp*
)))
*asdf-lisp*
)))
...
@@ -74,7 +74,7 @@
...
@@ -74,7 +74,7 @@
(
defun
load-asdf
()
(
defun
load-asdf
()
(
load
*asdf-fasl*
)
(
load
*asdf-fasl*
)
(
use-package
:asdf
:asdf-test
)
(
use-package
:asdf
:asdf-test
)
;;
(import 'DBG :asdf)
(
import
'DBG
:asdf
)
(
configure-asdf
)
(
configure-asdf
)
(
setf
*package*
(
find-package
:asdf-test
)))
(
setf
*package*
(
find-package
:asdf-test
)))
...
@@ -262,5 +262,5 @@ outputs a tag plus a list of variable and their values, returns the last value"
...
@@ -262,5 +262,5 @@ outputs a tag plus a list of variable and their values, returns the last value"
#|
#|
(DBG :cas o c just-done
base-stamp
stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c))
(DBG :cas o c just-done
plan
stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c))
|#
|#
test/test-bundle.script
View file @
ff9e3cb3
...
@@ -14,7 +14,7 @@
...
@@ -14,7 +14,7 @@
(when (find-package :test-package) (delete-package :test-package))
(when (find-package :test-package) (delete-package :test-package))
(asdf:defsystem :test-bundle-1 :components ((:file "file1") (:file "file3")))
(asdf:defsystem :test-bundle-1 :components ((:file "file1") (:file "file3")))
(asdf:defsystem :test-bundle-2 :depends-on (:test-bundle-1) :components ((:file "file2")))
(asdf:defsystem :test-bundle-2 :depends-on (:test-bundle-1) :components ((:file "file2")))
#-(or abcl (and ecl ecl-bytecmp))
#-(or abcl (and ecl ecl-bytecmp)
gcl
)
(let* ((op (make-instance 'asdf::fasl-op))
(let* ((op (make-instance 'asdf::fasl-op))
(bundle-1 (asdf:output-file op (find-system :test-bundle-1)))
(bundle-1 (asdf:output-file op (find-system :test-bundle-1)))
(bundle-2 (asdf:output-file op (find-system :test-bundle-2))))
(bundle-2 (asdf:output-file op (find-system :test-bundle-2))))
...
...
test/test-compile-file-failure.script
View file @
ff9e3cb3
;;; -*- Lisp -*-
;;; -*- Lisp -*-
(load "script-support.lisp")
(load "script-support.lisp")
(load-asdf)
(load-asdf)
(quit-on-error
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
#-gcl<2.7
(assert (handler-case
(assert (handler-case
(let ((asdf:*compile-file-failure-behaviour* :warn))
(let ((asdf:*compile-file-failure-behaviour* :warn))
(asdf:load-system 'test-compile-file-failure :force t)
(asdf:load-system 'test-compile-file-failure :force t)
t)
t)
(asdf:compile-error () nil)))
(asdf:compile-error () nil)))
#-gcl<2.7
(assert (handler-case
(assert (handler-case
(let ((asdf:*compile-file-failure-behaviour* :error))
(let ((asdf:*compile-file-failure-behaviour* :error))
(asdf:load-system 'test-compile-file-failure :force t)
(asdf:load-system 'test-compile-file-failure :force t)
...
...
test/test-configuration.script
View file @
ff9e3cb3
...
@@ -3,14 +3,11 @@
...
@@ -3,14 +3,11 @@
(load-asdf)
(load-asdf)
(in-package :asdf)
(in-package :asdf)
(use-package :asdf-test)
(use-package :asdf-test)
#+gcl<2.7 (defmacro with-standard-io-syntax (&body body) `(progn ,@body))
(defparameter *test-directory*
(merge-pathnames* (coerce-pathname "tmp/") *asdf-directory*))
(defun under-test-directory (designator &optional (defaults *test-directory*))
(defun under-test-directory (designator &optional (defaults *test-directory*))
(namestring (
merge-
pathname
s* (coerce-pathname
designator)
defaults)
))
(namestring (
sub
pathname
defaults
designator)))
(defun create-conf-files (&optional (path *test-directory*))
(defun create-conf-files (&optional (path *test-directory*))
(let ((v `(("conf.d/conf1.conf"
(let ((v `(("conf.d/conf1.conf"
...
...
test/test-module-pathnames.script
View file @
ff9e3cb3
...
@@ -3,25 +3,16 @@
...
@@ -3,25 +3,16 @@
(load-asdf)
(load-asdf)
(quit-on-error
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:load-system 'test-module-pathnames)
(asdf:load-system 'test-module-pathnames)
(flet ((submodule (module name)
(flet ((pathname-foo (x)
(find name (asdf:module-components module)
(list (or (asdf::normalize-pathname-directory-component (pathname-directory x)) '(:relative))
:key #'asdf:component-name :test #'equal))
(pathname-name x) (pathname-type x))))
(pathname-foo (x)
(let* ((static (find-component "test-module-pathnames" '("sources/level1" "level2/static.file")))
(list (pathname-directory x) (pathname-name x) (pathname-type x))))
(test-tmp (find-component "test-module-pathnames" '("sources/level1" "test-tmp.cl"))))
(let* ((system (asdf:find-system "test-module-pathnames"))
(assert-equal (pathname-foo (asdf:component-relative-pathname test-tmp))
(level1 (submodule system "sources/level1"))
'((:relative) "test-tmp" "cl"))
(static (submodule level1 "level2/static.file"))
(assert-equal (pathname-foo (asdf:component-relative-pathname static))
(test-tmp (submodule level1 "test-tmp.cl")))
'((:relative "level2") "static" "file"))))
(assert (member (pathname-foo (asdf:component-relative-pathname test-tmp))
'(((:relative) "test-tmp" "cl")
(nil "test-tmp" "cl")) :test 'equal)
() "Didn't get the name of test-tmp.cl right")
(assert (equal
(pathname-foo (asdf:component-relative-pathname static))
'((:relative "level2") "static" "file"))
() "Didn't get the name of static.file right")))
(assert (find-package :test-package)
(assert (find-package :test-package)
() "package test-package not found")
() "package test-package not found")
(assert (find-symbol (symbol-name '*file-tmp*) :test-package)
(assert (find-symbol (symbol-name '*file-tmp*) :test-package)
...
@@ -29,28 +20,26 @@
...
@@ -29,28 +20,26 @@
(assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package))
(assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package))
() "symbol `*file-tmp*` has wrong value")
() "symbol `*file-tmp*` has wrong value")
#| ; must be adapted to ABL
(assert (probe-file
(assert (probe-file (merge-pathnames
(asdf::apply-output-translations
(make-pathname
(asdf::merge-pathnames*
:name "file1"
(asdf::make-pathname*
:type (pathname-type (compile-file-pathname "x"))
:name "file1"
:directory '(:relative "sources" "level1"))))
:type (asdf::fasl-type)
nil "compiled file not found")
:directory '(:relative "sources" "level1"))
|#
*test-directory*)))
() "compiled file not found")
(assert (find-symbol (symbol-name '*file-tmp2*) :test-package)
nil
(assert (find-symbol (symbol-name '*file-tmp2*) :test-package)
"symbol `*file-tmp2*` not found")
()
"symbol `*file-tmp2*` not found")
(assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package))
(assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package))
nil
"symbol `*file-tmp2*` has wrong value")
()
"symbol `*file-tmp2*` has wrong value")
#| ; must be adapted to ABL
(assert (probe-file
(asdf::apply-output-translations
(assert (probe-file (merge-pathnames
(asdf::merge-pathnames*
(make-pathname
(asdf::make-pathname*
:name "file2"
:name "file2"
:type (pathname-type (compile-file-pathname "x"))
:type (asdf::fasl-type)
:directory '(:relative "sources" "level1" "level2"))))
:directory '(:relative "sources" "level1" "level2")))))
nil "compiled file not found")
nil "compiled file not found"))
|#
)
test/test-multiple.script
View file @
ff9e3cb3
...
@@ -6,14 +6,11 @@
...
@@ -6,14 +6,11 @@
(use-package :asdf-test)
(use-package :asdf-test)
(quit-on-error
(quit-on-error
(let* ((asd (merge-pathnames* (coerce-pathname "test-multiple.asd")
(let* ((asd (subpathname *test-directory* "test-multiple.asd"))
*test-directory*))
(tmp (subpathname *test-directory* "../tmp/"))
(tmp (merge-pathnames* (coerce-pathname "../tmp/")
(asd2 (subpathname tmp "test-multiple-too.asd"))
*test-directory*))
(asd2 (merge-pathnames* (coerce-pathname "test-multiple-too.asd")
tmp))
(file4 (compile-file-pathname* "file4")))
(file4 (compile-file-pathname* "file4")))
(setf *central-registry* `(
*default-pathname-defaults
* ,tmp))
(setf *central-registry* `(
,*test-directory
* ,tmp))
(assert (= 0 (run-shell-command
(assert (= 0 (run-shell-command
(format nil "/bin/ln -sf ~A ~A"
(format nil "/bin/ln -sf ~A ~A"
(native-namestring asd)
(native-namestring asd)
...
...
test/test-system-pathnames.script
View file @
ff9e3cb3
...
@@ -3,25 +3,7 @@
...
@@ -3,25 +3,7 @@
(load-asdf)
(load-asdf)
(quit-on-error
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:load-system 'test-system-pathnames)
(asdf:load-system 'test-system-pathnames)
(flet ((submodule (module name)
(find name (asdf:module-components module)
:key #'asdf:component-name :test #'equal))
(pathname-foo (x)
(list (pathname-directory x) (pathname-name x) (pathname-type x))))
(let* ((system (asdf:find-system "test-module-pathnames"))
(level1 (submodule system "sources/level1"))
(static (submodule level1 "level2/static.file"))
(test-tmp (submodule level1 "test-tmp.cl")))
(assert (member (pathname-foo (asdf:component-relative-pathname test-tmp))
'(((:relative) "test-tmp" "cl")
(nil "test-tmp" "cl")) :test 'equal)
() "Didn't get the name of test-tmp.cl right")
(assert (equal
(pathname-foo (asdf:component-relative-pathname static))
'((:relative "level2") "static" "file"))
() "Didn't get the name of static.file right")))
(assert (find-package :test-package)
(assert (find-package :test-package)
() "package test-package not found")
() "package test-package not found")
(assert (find-symbol (symbol-name '*file-tmp*) :test-package)
(assert (find-symbol (symbol-name '*file-tmp*) :test-package)
...
@@ -29,28 +11,26 @@
...
@@ -29,28 +11,26 @@
(assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package))
(assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package))
() "symbol `*file-tmp*` has wrong value")
() "symbol `*file-tmp*` has wrong value")
#| ; must be adapted to ABL
(assert (probe-file
(assert (probe-file (merge-pathnames
(asdf::apply-output-translations
(make-pathname
(asdf::merge-pathnames*
:name "file1"
(asdf::make-pathname*
:type (pathname-type (compile-file-pathname "x"))
:name "file1"
:directory '(:relative "sources" "level1"))))
:type (asdf::fasl-type)
nil "compiled file not found")
:directory '(:relative "sources" "level1"))
|#
*test-directory*)))
() "compiled file not found")
(assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil
(assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil
"symbol `*file-tmp2*` not found")
"symbol `*file-tmp2*` not found")
(assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package))
(assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package))
nil "symbol `*file-tmp2*` has wrong value")
nil "symbol `*file-tmp2*` has wrong value")
#| ; must be adapted to ABL
(assert (probe-file
(asdf::apply-output-translations
(assert (probe-file (merge-pathnames
(asdf::merge-pathnames*
(make-pathname
(asdf::make-pathname*
:name "file2"
:name "file2"
:type (pathname-type (compile-file-pathname "x"))
:type (asdf::fasl-type)
:directory '(:relative "sources" "level1" "level2"))))
:directory '(:relative "sources" "level1" "level2")))))
nil "compiled file not found")
nil "compiled file not found"))
|#
)
test/test-try-recompiling-1.script
View file @
ff9e3cb3
...
@@ -7,10 +7,7 @@
...
@@ -7,10 +7,7 @@
(defvar *caught-error* nil)
(defvar *caught-error* nil)
(quit-on-error
(quit-on-error
(run-shell-command "rm -f ~A"
(asdf::delete-file-if-exists (compile-file-pathname "try-recompiling-1"))
(namestring
(compile-file-pathname "try-recompiling-1")))
(setf *central-registry* '(*default-pathname-defaults*))
#-gcl
#-gcl
(handler-bind ((error (lambda (c)
(handler-bind ((error (lambda (c)
(setf *caught-error* t)
(setf *caught-error* t)
...
@@ -26,4 +23,5 @@
...
@@ -26,4 +23,5 @@
(when restart
(when restart
(invoke-restart restart)))))))
(invoke-restart restart)))))))
(oos 'load-op 'try-recompiling-1))
(oos 'load-op 'try-recompiling-1))
#-gcl
(assert *caught-error*))
(assert *caught-error*))
test/test-xach-update-bug.script
View file @
ff9e3cb3
...
@@ -2,17 +2,12 @@
...
@@ -2,17 +2,12 @@
(load "script-support.lisp")
(load "script-support.lisp")
(load-asdf)
(load-asdf)
#+gcl (trace load compile-file asdf:perform asdf::perform-plan)
(quit-on-error
(quit-on-error
(let ((*default-pathname-defaults* (make-pathname :name nil
(setf asdf:*central-registry* (list (asdf::subpathname *test-directory* "xach-foo-1/")))
:type nil
(asdf:load-system "foo")
:defaults *load-truename*)))
(assert (symbol-value (find-symbol (string :loaded) :first-version)))
(setf asdf:*central-registry* nil)
(setf asdf:*central-registry* (list (asdf::subpathname *test-directory* "xach-foo-2/")))
(push (merge-pathnames #p"xach-foo-1/") asdf:*central-registry*)
(asdf:load-system "foo")
(asdf:load-system "foo")
(assert (symbol-value (find-symbol (string :loaded) :second-version)))
(assert (symbol-value (find-symbol (string :loaded) :first-version)))
(assert (eql 42 (funcall (find-symbol (string :wtf) :second-version)))))
(push (merge-pathnames #p"xach-foo-2/") asdf:*central-registry*)
(asdf:load-system "foo")
(assert (symbol-value (find-symbol (string :loaded) :second-version)))
(assert (eql 42 (funcall (find-symbol (string :wtf) :second-version))))))
test/xach-foo-1/a.lisp
View file @
ff9e3cb3
;;;; a.lisp
;;;; a.lisp
(
defpackage
#
:first-version
(
defpackage
:first-version
(
:use
#:cl
)
(
:use
#:cl
)
(
:export
#:loaded
))
(
:export
#:loaded
))