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
30bb39c6
Commit
30bb39c6
authored
14 years ago
by
Francois-Rene Rideau
Browse files
Options
Downloads
Patches
Plain Diff
1.715: support gcl 2.7.0
parent
95c5ffb8
No related branches found
Branches containing commit
Tags
1.715
Tags containing commit
No related merge requests found
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
.gitignore
+1
-0
1 addition, 0 deletions
.gitignore
asdf.lisp
+304
-274
304 additions, 274 deletions
asdf.lisp
test/asdf-pathname-test.script
+4
-4
4 additions, 4 deletions
test/asdf-pathname-test.script
test/try-reloading-dependency.asd
+0
-5
0 additions, 5 deletions
test/try-reloading-dependency.asd
with
309 additions
and
283 deletions
.gitignore
+
1
−
0
View file @
30bb39c6
...
@@ -35,3 +35,4 @@ tmp/
...
@@ -35,3 +35,4 @@ tmp/
*.a
*.a
*.*fsl
*.*fsl
*.bak
*.bak
*.data
This diff is collapsed.
Click to expand it.
asdf.lisp
+
304
−
274
View file @
30bb39c6
...
@@ -49,7 +49,8 @@
...
@@ -49,7 +49,8 @@
(
cl:in-package
:cl-user
)
(
cl:in-package
:cl-user
)
(
declaim
(
optimize
(
speed
2
)
(
debug
2
)
(
safety
3
)))
(
declaim
(
optimize
(
speed
2
)
(
debug
2
)
(
safety
3
))
#+
sbcl
(
sb-ext:muffle-conditions
sb-ext:compiler-note
))
#+
ecl
(
require
:cmp
)
#+
ecl
(
require
:cmp
)
...
@@ -57,228 +58,248 @@
...
@@ -57,228 +58,248 @@
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;; See more at the end of the file.
;;;; See more at the end of the file.
#+
gcl
(
eval-when
(
:compile-toplevel
:load-toplevel
)
(
defpackage
:asdf-utilities
(
:use
:cl
))
(
defpackage
:asdf
(
:use
:cl
:asdf-utilities
)))
(
eval-when
(
:load-toplevel
:compile-toplevel
:execute
)
(
eval-when
(
:load-toplevel
:compile-toplevel
:execute
)
#+
allegro
#+
allegro
(
setf
excl::*autoload-package-name-alist*
(
setf
excl::*autoload-package-name-alist*
(
remove
"asdf"
excl::*autoload-package-name-alist*
:test
'equalp
:key
'car
))
(
remove
"asdf"
excl::*autoload-package-name-alist*
:test
'equalp
:key
'car
))
(
let*
((
asdf-version
(
let*
((
asdf-version
;; the 1+ h
air is to ensure that we don't do an inadvertent find and replac
e
;; the 1+ h
elps the version bumping script discriminat
e
(
subseq
"VERSION:1.71
4
"
(
1+
(
length
"VERSION"
))))
(
subseq
"VERSION:1.71
5
"
(
1+
(
length
"VERSION"
))))
(
existing-asdf
(
find-package
:asdf
))
(
existing-asdf
(
find-package
:asdf
))
(
versym
'
#:*asdf-version*
)
(
vername
'
#:*asdf-version*
)
(
existing-version
(
and
existing-asdf
(
versym
(
and
existing-asdf
(
symbol-value
(
find-symbol
(
string
vername
)
existing-asdf
)))
(
find-symbol
(
string
versym
)
existing-asdf
))))
(
existing-version
(
and
versym
(
boundp
versym
)
(
symbol-value
versym
)))
(
redefined-functions
'
(
#:perform
#:explain
#:output-files
#:operation-done-p
#:perform-with-restarts
#:component-relative-pathname
#:system-source-file
#:operate
#:find-component
))
(
already-there
(
equal
asdf-version
existing-version
)))
(
already-there
(
equal
asdf-version
existing-version
)))
(
unless
(
and
existing-asdf
already-there
)
(
unless
(
and
existing-asdf
already-there
)
#-
gcl
(
when
existing-asdf
(
when
existing-asdf
(
format
*error-output*
(
format
*error-output*
"~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
"~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
existing-version
asdf-version
))
existing-version
asdf-version
))
(
labels
((
rename-away
(
package
)
(
labels
(
loop
:with
name
=
(
package-name
package
)
((
rename-away
(
package
)
:for
i
:from
1
:for
new
=
(
format
nil
"~A.~D"
name
i
)
(
loop
:with
name
=
(
package-name
package
)
:unless
(
find-package
new
)
:do
:for
i
:from
1
:for
new
=
(
format
nil
"~A.~D"
name
i
)
(
rename-package-name
package
name
new
)))
:unless
(
find-package
new
)
:do
(
rename-package-name
(
package
old
new
)
(
rename-package-name
package
name
new
)))
(
let*
((
old-names
(
cons
(
package-name
package
)
(
package-nicknames
package
)))
(
rename-package-name
(
package
old
new
)
(
new-names
(
subst
new
old
old-names
:test
'equal
))
(
let*
((
old-names
(
cons
(
package-name
package
)
(
new-name
(
car
new-names
))
(
package-nicknames
package
)))
(
new-nicknames
(
cdr
new-names
)))
(
new-names
(
subst
new
old
old-names
:test
'equal
))
(
rename-package
package
new-name
new-nicknames
)))
(
new-name
(
car
new-names
))
(
ensure-exists
(
name
nicknames
use
)
(
new-nicknames
(
cdr
new-names
)))
(
let*
((
previous
(
rename-package
package
new-name
new-nicknames
)))
(
remove-duplicates
(
ensure-exists
(
name
nicknames
use
)
(
remove-if
(
let*
((
previous
#'
null
(
remove-duplicates
(
mapcar
#'
find-package
(
cons
name
nicknames
)))
(
remove-if
:from-end
t
)))
#'
null
(
cond
(
mapcar
#'
find-package
(
cons
name
nicknames
)))
(
previous
:from-end
t
)))
(
map
()
#'
rename-away
(
cdr
previous
))
;; packages with conflicting (nick)names
(
cond
(
let
((
p
(
car
previous
)))
;; previous package with same name
(
previous
(
rename-package
p
name
nicknames
)
;; do away with packages with conflicting (nick)names
(
ensure-use
p
use
)
(
map
()
#'
rename-away
(
cdr
previous
))
p
))
;; reuse previous package with same name
(
t
(
let
((
p
(
car
previous
)))
(
make-package
name
:nicknames
nicknames
:use
use
)))))
(
rename-package
p
name
nicknames
)
(
find-sym
(
symbol
package
)
(
ensure-use
p
use
)
(
find-symbol
(
string
symbol
)
package
))
p
))
(
intern*
(
symbol
package
)
(
t
(
intern
(
string
symbol
)
package
))
(
make-package
name
:nicknames
nicknames
:use
use
)))))
(
remove-symbol
(
symbol
package
)
(
find-sym
(
symbol
package
)
(
let
((
sym
(
find-sym
symbol
package
)))
(
find-symbol
(
string
symbol
)
package
))
(
when
sym
(
intern*
(
symbol
package
)
(
unexport
sym
package
)
(
intern
(
string
symbol
)
package
))
(
unintern
sym
package
))))
(
remove-symbol
(
symbol
package
)
(
ensure-unintern
(
package
symbols
)
(
let
((
sym
(
find-sym
symbol
package
)))
(
dolist
(
sym
symbols
)
(
remove-symbol
sym
package
)))
(
when
sym
(
ensure-shadow
(
package
symbols
)
(
unexport
sym
package
)
(
shadow
symbols
package
))
(
unintern
sym
package
))))
(
ensure-use
(
package
use
)
(
ensure-unintern
(
package
symbols
)
(
dolist
(
used
(
reverse
use
))
(
dolist
(
sym
symbols
)
(
remove-symbol
sym
package
)))
(
do-external-symbols
(
sym
used
)
(
ensure-shadow
(
package
symbols
)
(
unless
(
eq
sym
(
find-sym
sym
package
))
(
shadow
symbols
package
))
(
remove-symbol
sym
package
)))
(
ensure-use
(
package
use
)
(
use-package
used
package
)))
(
dolist
(
used
(
reverse
use
))
(
ensure-fmakunbound
(
package
symbols
)
(
do-external-symbols
(
sym
used
)
(
loop
:for
name
:in
symbols
(
unless
(
eq
sym
(
find-sym
sym
package
))
:for
sym
=
(
find-sym
name
package
)
(
remove-symbol
sym
package
)))
:when
sym
:do
(
fmakunbound
sym
)))
(
use-package
used
package
)))
(
ensure-export
(
package
export
)
(
ensure-fmakunbound
(
package
symbols
)
(
let
((
syms
(
loop
:for
x
:in
export
:collect
(
loop
:for
name
:in
symbols
(
intern*
x
package
))))
:for
sym
=
(
find-sym
name
package
)
(
do-external-symbols
(
sym
package
)
:when
sym
:do
(
fmakunbound
sym
)))
(
unless
(
member
sym
syms
)
(
ensure-export
(
package
export
)
(
remove-symbol
sym
package
)))
(
let
((
syms
(
loop
:for
x
:in
export
:collect
(
dolist
(
sym
syms
)
(
intern*
x
package
))))
(
export
sym
package
))))
(
do-external-symbols
(
sym
package
)
(
ensure-package
(
name
&key
nicknames
use
unintern
fmakunbound
shadow
export
)
(
unless
(
member
sym
syms
)
(
let
((
p
(
ensure-exists
name
nicknames
use
)))
(
remove-symbol
sym
package
)))
(
ensure-unintern
p
unintern
)
(
dolist
(
sym
syms
)
(
ensure-shadow
p
shadow
)
(
export
sym
package
))))
(
ensure-export
p
export
)
(
ensure-package
(
name
&key
nicknames
use
unintern
fmakunbound
shadow
export
)
(
ensure-fmakunbound
p
fmakunbound
)
(
let
((
p
(
ensure-exists
name
nicknames
use
)))
p
)))
(
ensure-unintern
p
unintern
)
(
ensure-package
(
ensure-shadow
p
shadow
)
'
:asdf-utilities
(
ensure-export
p
export
)
:nicknames
'
(
#:asdf-extensions
)
(
ensure-fmakunbound
p
fmakunbound
)
:use
'
(
#:common-lisp
)
p
)))
:unintern
'
(
#:split
#:make-collector
)
(
macrolet
:export
((
pkgdcl
(
name
&key
nicknames
use
export
'
(
#:absolute-pathname-p
redefined-functions
unintern
fmakunbound
shadow
)
#:aif
`
(
ensure-package
#:appendf
',name
:nicknames
',nicknames
:use
',use
:export
',export
#:asdf-message
:shadow
',shadow
#:coerce-name
:unintern
',
(
append
#-
(
or
gcl
ecl
)
redefined-functions
#:directory-pathname-p
unintern
)
#:ends-with
:fmakunbound
',
(
append
#+
(
or
gcl
ecl
)
redefined-functions
#:ensure-directory-pathname
fmakunbound
))))
#:getenv
(
pkgdcl
#:get-uid
:asdf-utilities
#:length=n-p
:nicknames
(
#:asdf-extensions
)
#:merge-pathnames*
:use
(
#:common-lisp
)
#:pathname-directory-pathname
:unintern
(
#:split
#:make-collector
)
#:pathname-sans-name+type
;; deprecated. Use pathname-directory-pathname
:export
#:read-file-forms
(
#:absolute-pathname-p
#:remove-keys
#:aif
#:remove-keyword
#:appendf
#:resolve-symlinks
#:asdf-message
#:split-string
#:coerce-name
#:component-name-to-pathname-components
#:directory-pathname-p
#:split-name-type
#:ends-with
#:system-registered-p
#:ensure-directory-pathname
#:truenamize
#:getenv
#:while-collecting
))
#:get-uid
(
ensure-package
#:length=n-p
'
:asdf
#:merge-pathnames*
:use
'
(
:common-lisp
:asdf-utilities
)
#:pathname-directory-pathname
:unintern
`
(
#-
(
or
gcl
ecl
)
,@
redefined-functions
#:read-file-forms
#:*asdf-revision*
#:around
#:asdf-method-combination
#:remove-keys
#:split
#:make-collector
)
#:remove-keyword
:fmakunbound
`
(
#+
(
or
gcl
ecl
)
,@
redefined-functions
#:resolve-symlinks
#:system-source-file
#:split-string
#:component-relative-pathname
#:system-relative-pathname
#:component-name-to-pathname-components
#:process-source-registry
#:split-name-type
#:inherit-source-registry
#:process-source-registry-directive
)
#:system-registered-p
:export
#:truenamize
'
(
#:defsystem
#:oos
#:operate
#:find-system
#:run-shell-command
#:while-collecting
))
#:system-definition-pathname
#:find-component
; miscellaneous
(
pkgdcl
#:compile-system
#:load-system
#:test-system
:asdf
#:compile-op
#:load-op
#:load-source-op
:use
(
:common-lisp
:asdf-utilities
)
#:test-op
:redefined-functions
#:operation
; operations
(
#:perform
#:explain
#:output-files
#:operation-done-p
#:feature
; sort-of operation
#:perform-with-restarts
#:component-relative-pathname
#:version
; metaphorically sort-of an operation
#:system-source-file
#:operate
#:find-component
)
#:version-satisfies
:unintern
(
#:*asdf-revision*
#:around
#:asdf-method-combination
#:input-files
#:output-files
#:perform
; operation methods
#:split
#:make-collector
)
#:operation-done-p
#:explain
:fmakunbound
(
#:system-source-file
#:component
#:source-file
#:component-relative-pathname
#:system-relative-pathname
#:c-source-file
#:cl-source-file
#:java-source-file
#:process-source-registry
#:static-file
#:inherit-source-registry
#:process-source-registry-directive
)
#:doc-file
:export
#:html-file
(
#:defsystem
#:oos
#:operate
#:find-system
#:run-shell-command
#:text-file
#:system-definition-pathname
#:find-component
; miscellaneous
#:source-file-type
#:compile-system
#:load-system
#:test-system
#:module
; components
#:compile-op
#:load-op
#:load-source-op
#:system
#:test-op
#:unix-dso
#:operation
; operations
#:feature
; sort-of operation
#:module-components
; component accessors
#:version
; metaphorically sort-of an operation
#:module-components-by-name
; component accessors
#:version-satisfies
#:component-pathname
#:component-relative-pathname
#:input-files
#:output-files
#:perform
; operation methods
#:component-name
#:operation-done-p
#:explain
#:component-version
#:component-parent
#:component
#:source-file
#:component-property
#:c-source-file
#:cl-source-file
#:java-source-file
#:component-system
#:static-file
#:doc-file
#:component-depends-on
#:html-file
#:text-file
#:system-description
#:source-file-type
#:system-long-description
#:module
; components
#:system-author
#:system
#:system-maintainer
#:unix-dso
#:system-license
#:system-licence
#:module-components
; component accessors
#:system-source-file
#:module-components-by-name
; component accessors
#:system-source-directory
#:component-pathname
#:system-relative-pathname
#:component-relative-pathname
#:map-systems
#:component-name
#:component-version
#:operation-on-warnings
#:component-parent
#:operation-on-failure
#:component-property
;#:*component-parent-pathname*
#:component-system
#:*system-definition-search-functions*
#:*central-registry*
; variables
#:component-depends-on
#:*compile-file-warnings-behaviour*
#:*compile-file-failure-behaviour*
#:system-description
#:*resolve-symlinks*
#:system-long-description
#:*asdf-verbose*
#:system-author
#:system-maintainer
#:asdf-version
#:system-license
#:system-licence
#:operation-error
#:compile-failed
#:compile-warned
#:compile-error
#:system-source-file
#:error-name
#:system-source-directory
#:error-pathname
#:system-relative-pathname
#:load-system-definition-error
#:map-systems
#:error-component
#:error-operation
#:system-definition-error
#:operation-on-warnings
#:missing-component
#:operation-on-failure
#:missing-component-of-version
;;#:*component-parent-pathname*
#:missing-dependency
#:*system-definition-search-functions*
#:missing-dependency-of-version
#:*central-registry*
; variables
#:circular-dependency
; errors
#:*compile-file-warnings-behaviour*
#:duplicate-names
#:*compile-file-failure-behaviour*
#:*resolve-symlinks*
#:try-recompiling
#:*asdf-verbose*
#:retry
#:accept
; restarts
#:asdf-version
#:coerce-entry-to-directory
#:remove-entry-from-registry
#:operation-error
#:compile-failed
#:compile-warned
#:compile-error
#:error-name
#:initialize-output-translations
#:error-pathname
#:disable-output-translations
#:load-system-definition-error
#:clear-output-translations
#:error-component
#:error-operation
#:ensure-output-translations
#:system-definition-error
#:apply-output-translations
#:missing-component
#:compile-file-pathname*
#:missing-component-of-version
#:enable-asdf-binary-locations-compatibility
#:missing-dependency
#:missing-dependency-of-version
#:*default-source-registries*
#:circular-dependency
; errors
#:initialize-source-registry
#:duplicate-names
#:compute-source-registry
#:clear-source-registry
#:try-recompiling
#:ensure-source-registry
#:retry
#:process-source-registry
))
#:accept
; restarts
(
let*
((
version
(
intern*
versym
:asdf
))
#:coerce-entry-to-directory
#:remove-entry-from-registry
#:initialize-output-translations
#:disable-output-translations
#:clear-output-translations
#:ensure-output-translations
#:apply-output-translations
#:compile-file-pathname*
#:enable-asdf-binary-locations-compatibility
#:*default-source-registries*
#:initialize-source-registry
#:compute-source-registry
#:clear-source-registry
#:ensure-source-registry
#:process-source-registry
)))
(
let*
((
version
(
intern*
vername
:asdf
))
(
upvar
(
intern*
'
#:*upgraded-p*
:asdf
))
(
upvar
(
intern*
'
#:*upgraded-p*
:asdf
))
(
upval0
(
and
(
boundp
upvar
)
(
symbol-value
upvar
)))
(
upval0
(
and
(
boundp
upvar
)
(
symbol-value
upvar
)))
(
upval1
(
if
existing-version
(
cons
existing-version
upval0
)
upval0
)))
(
upval1
(
if
existing-version
(
cons
existing-version
upval0
)
upval0
)))
...
@@ -289,6 +310,10 @@
...
@@ -289,6 +310,10 @@
(
in-package
:asdf
)
(
in-package
:asdf
)
;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
#+
gcl
(
eval-when
(
:compile-toplevel
:load-toplevel
)
(
defvar
*asdf-version*
nil
)
(
defvar
*upgraded-p*
nil
))
(
when
*upgraded-p*
(
when
*upgraded-p*
#+
ecl
#+
ecl
(
defmethod
update-instance-for-redefined-class
:after
(
defmethod
update-instance-for-redefined-class
:after
...
@@ -449,14 +474,6 @@ processed in order by `operate`."))
...
@@ -449,14 +474,6 @@ processed in order by `operate`."))
(
defmacro
aif
(
test
then
&optional
else
)
(
defmacro
aif
(
test
then
&optional
else
)
`
(
let
((
it
,
test
))
(
if
it
,
then
,
else
)))
`
(
let
((
it
,
test
))
(
if
it
,
then
,
else
)))
(
defun
pathname-sans-name+type
(
pathname
)
"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME and TYPE components.
Issue: doesn't override the VERSION component.
Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead."
(
make-pathname
:name
nil
:type
nil
:defaults
pathname
))
(
defun
pathname-directory-pathname
(
pathname
)
(
defun
pathname-directory-pathname
(
pathname
)
"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
and NIL NAME, TYPE and VERSION components"
...
@@ -498,6 +515,13 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
...
@@ -498,6 +515,13 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
(
values
(
pathname-host
defaults
)
(
values
(
pathname-host
defaults
)
(
pathname-device
defaults
)
(
pathname-device
defaults
)
(
append
(
pathname-directory
defaults
)
(
cdr
directory
))
(
append
(
pathname-directory
defaults
)
(
cdr
directory
))
(
unspecific-handler
defaults
)))
#+
gcl
(
t
(
assert
(
stringp
(
first
directory
)))
(
values
(
pathname-host
defaults
)
(
pathname-device
defaults
)
(
append
(
pathname-directory
defaults
)
directory
)
(
unspecific-handler
defaults
))))
(
unspecific-handler
defaults
))))
(
make-pathname
:host
host
:device
device
:directory
directory
(
make-pathname
:host
host
:device
device
:directory
directory
:name
(
funcall
unspecific-handler
name
)
:name
(
funcall
unspecific-handler
name
)
...
@@ -539,7 +563,7 @@ starting the separation from the end, e.g. when called with arguments
...
@@ -539,7 +563,7 @@ starting the separation from the end, e.g. when called with arguments
;; Giving :unspecific as argument to make-pathname is not portable.
;; Giving :unspecific as argument to make-pathname is not portable.
;; See CLHS make-pathname and 19.2.2.2.3.
;; See CLHS make-pathname and 19.2.2.2.3.
;; We only use it on implementations that support it.
;; We only use it on implementations that support it.
(
or
#+
(
or
sbcl
ccl
ecl
lispworks
)
:unspecific
)))
(
or
#+
(
or
ccl
ecl
gcl
lispworks
sbcl
)
:unspecific
)))
(
destructuring-bind
(
name
&optional
(
type
unspecific
))
(
destructuring-bind
(
name
&optional
(
type
unspecific
))
(
split-string
filename
:max
2
:separator
"."
)
(
split-string
filename
:max
2
:separator
"."
)
(
if
(
equal
name
""
)
(
if
(
equal
name
""
)
...
@@ -711,28 +735,27 @@ actually-existing directory."
...
@@ -711,28 +735,27 @@ actually-existing directory."
(
return
p
))
(
return
p
))
(
let
((
sofar
(
ignore-errors
(
truename
(
pathname-root
p
)))))
(
let
((
sofar
(
ignore-errors
(
truename
(
pathname-root
p
)))))
(
unless
sofar
(
return
p
))
(
unless
sofar
(
return
p
))
(
loop
:for
component
:in
(
cdr
directory
)
(
flet
((
solution
(
directory
)
:for
rest
:on
(
cdr
directory
)
(
merge-pathnames*
:for
more
=
(
ignore-errors
(
make-pathname
:host
nil
:device
nil
(
truename
:directory
directory
(
merge-pathnames*
:name
(
pathname-name
p
)
(
make-pathname
:directory
`
(
:relative
,
component
))
:type
(
pathname-type
p
)
sofar
)))
:do
:version
(
pathname-version
p
)
(
if
more
:defaults
"/"
:case
:local
)
(
setf
sofar
more
)
sofar
)))
(
return
(
loop
:for
component
:in
(
cdr
directory
)
(
merge-pathnames*
:for
rest
:on
(
cdr
directory
)
(
make-pathname
:host
nil
:device
nil
:for
more
=
(
ignore-errors
:directory
`
(
:relative
,@
rest
)
(
truename
:defaults
p
)
(
merge-pathnames*
sofar
)))
(
make-pathname
:directory
`
(
:relative
,
component
))
:finally
sofar
)))
:do
(
return
(
if
more
(
merge-pathnames*
(
setf
sofar
more
)
(
make-pathname
:host
nil
:device
nil
(
return
(
solution
`
(
:relative
,@
rest
))))
:directory
nil
:finally
:defaults
p
)
(
return
(
solution
nil
))))))))
sofar
)))))))
(
defun
lispize-pathname
(
input-file
)
(
defun
lispize-pathname
(
input-file
)
(
make-pathname
:type
"lisp"
:defaults
input-file
))
(
make-pathname
:type
"lisp"
:defaults
input-file
))
...
@@ -2021,7 +2044,7 @@ Returns the new tree (which probably shares structure with the old one)"
...
@@ -2021,7 +2044,7 @@ Returns the new tree (which probably shares structure with the old one)"
(
defun
sysdef-error-component
(
msg
type
name
value
)
(
defun
sysdef-error-component
(
msg
type
name
value
)
(
sysdef-error
(
concatenate
'string
msg
(
sysdef-error
(
concatenate
'string
msg
"~&The value specified for ~(~A~) ~A is ~
W
"
)
"~&The value specified for ~(~A~) ~A is ~
S
"
)
type
name
value
))
type
name
value
))
(
defun
check-component-input
(
type
name
weakly-depends-on
(
defun
check-component-input
(
type
name
weakly-depends-on
...
@@ -2157,20 +2180,9 @@ synchronously execute the result using a Bourne-compatible shell, with
...
@@ -2157,20 +2180,9 @@ synchronously execute the result using a Bourne-compatible shell, with
output to `*verbose-out*`. Returns the shell's exit code."
output to `*verbose-out*`. Returns the shell's exit code."
(
let
((
command
(
apply
#'
format
nil
control-string
args
)))
(
let
((
command
(
apply
#'
format
nil
control-string
args
)))
(
asdf-message
"; $ ~A~%"
command
)
(
asdf-message
"; $ ~A~%"
command
)
#+
sbcl
(
sb-ext:process-exit-code
(
apply
#'
sb-ext:run-program
#+
win32
"sh"
#-
win32
"/bin/sh"
(
list
"-c"
command
)
:input
nil
:output
*verbose-out*
#+
win32
'
(
:search
t
)
#-
win32
nil
))
#+
(
or
cmu
scl
)
#+
abcl
(
ext:process-exit-code
(
ext:run-shell-command
command
:output
*verbose-out*
)
(
ext:run-program
"/bin/sh"
(
list
"-c"
command
)
:input
nil
:output
*verbose-out*
))
#+
allegro
#+
allegro
;; will this fail if command has embedded quotes - it seems to work
;; will this fail if command has embedded quotes - it seems to work
...
@@ -2184,18 +2196,10 @@ output to `*verbose-out*`. Returns the shell's exit code."
...
@@ -2184,18 +2196,10 @@ output to `*verbose-out*`. Returns the shell's exit code."
(
format
*verbose-out*
"~{~&; ~a~%~}~%"
stdout
)
(
format
*verbose-out*
"~{~&; ~a~%~}~%"
stdout
)
exit-code
)
exit-code
)
#+
lispworks
(
system:call-system-showing-output
command
:shell-type
"/bin/sh"
:show-cmd
nil
:prefix
""
:output-stream
*verbose-out*
)
#+
clisp
;XXX not exactly *verbose-out*, I know
#+
clisp
;XXX not exactly *verbose-out*, I know
(
ext:run-shell-command
command
:output
:terminal
:wait
t
)
(
ext:run-shell-command
command
:output
:terminal
:wait
t
)
#+
openmcl
#+
clozure
(
nth-value
1
(
nth-value
1
(
ccl:external-process-status
(
ccl:external-process-status
(
ccl:run-program
"/bin/sh"
(
list
"-c"
command
)
(
ccl:run-program
"/bin/sh"
(
list
"-c"
command
)
...
@@ -2205,12 +2209,34 @@ output to `*verbose-out*`. Returns the shell's exit code."
...
@@ -2205,12 +2209,34 @@ output to `*verbose-out*`. Returns the shell's exit code."
#+
ecl
;; courtesy of Juan Jose Garcia Ripoll
#+
ecl
;; courtesy of Juan Jose Garcia Ripoll
(
si:system
command
)
(
si:system
command
)
#+
abcl
#+
gcl
(
ext:run-shell-command
command
:output
*verbose-out*
)
(
lisp:system
command
)
#+
lispworks
(
system:call-system-showing-output
command
:shell-type
"/bin/sh"
:show-cmd
nil
:prefix
""
:output-stream
*verbose-out*
)
#+
sbcl
(
sb-ext:process-exit-code
(
apply
#'
sb-ext:run-program
#+
win32
"sh"
#-
win32
"/bin/sh"
(
list
"-c"
command
)
:input
nil
:output
*verbose-out*
#+
win32
'
(
:search
t
)
#-
win32
nil
))
#-
(
or
openmcl
clisp
lispworks
allegro
scl
cmu
sbcl
ecl
abcl
)
#+
(
or
cmu
scl
)
(
error
"RUN-SHELL-COMMAND not implemented for this Lisp"
)
(
ext:process-exit-code
))
(
ext:run-program
"/bin/sh"
(
list
"-c"
command
)
:input
nil
:output
*verbose-out*
))
#-
(
or
abcl
allegro
clisp
clozure
cmu
ecl
gcl
lispworks
sbcl
scl
)
(
error
"RUN-SHELL-COMMAND not implemented for this Lisp"
)))
;;;; ---------------------------------------------------------------------------
;;;; ---------------------------------------------------------------------------
;;;; system-relative-pathname
;;;; system-relative-pathname
...
@@ -2229,9 +2255,13 @@ located."
...
@@ -2229,9 +2255,13 @@ located."
:defaults
(
system-source-file
system-designator
)))
:defaults
(
system-source-file
system-designator
)))
(
defun
relativize-directory
(
directory
)
(
defun
relativize-directory
(
directory
)
(
if
(
eq
(
car
directory
)
:absolute
)
(
cond
(
cons
:relative
(
cdr
directory
))
((
stringp
directory
)
directory
))
(
list
:relative
directory
))
((
eq
(
car
directory
)
:absolute
)
(
cons
:relative
(
cdr
directory
)))
(
t
directory
)))
(
defun
relativize-pathname-directory
(
pathspec
)
(
defun
relativize-pathname-directory
(
pathspec
)
(
let
((
p
(
pathname
pathspec
)))
(
let
((
p
(
pathname
pathspec
)))
...
...
This diff is collapsed.
Click to expand it.
test/asdf-pathname-test.script
+
4
−
4
View file @
30bb39c6
...
@@ -185,11 +185,11 @@
...
@@ -185,11 +185,11 @@
(handler-bind
(handler-bind
((error (lambda (c)
((error (lambda (c)
(incf system-failures)
(incf system-failures)
(format *error-output* "~&error! ~a~%sysdef:~% ~
W
~%" c system-definition)
(format *error-output* "~&error! ~a~%sysdef:~% ~
S
~%" c system-definition)
#+sbcl (sb-debug:backtrace 69)
#+sbcl (sb-debug:backtrace 69)
#+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
#+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
#+clisp (system::print-backtrace)
#+clisp (system::print-backtrace)
(format result-stream "~&~%***~%error: ~a~%~
:w
"
(format result-stream "~&~%***~%error: ~a~%~
s
"
c system-definition)
c system-definition)
(return-from :test-system))))
(return-from :test-system))))
(unless (and (or (typep system-pathname 'logical-pathname)
(unless (and (or (typep system-pathname 'logical-pathname)
...
@@ -241,9 +241,9 @@
...
@@ -241,9 +241,9 @@
:missing)))
:missing)))
test-files))
test-files))
(format result-stream "~&~%~% translations: ~a: ~
:w
" "ASDFTEST" (logical-pathname-translations "ASDFTEST"))
(format result-stream "~&~%~% translations: ~a: ~
s
" "ASDFTEST" (logical-pathname-translations "ASDFTEST"))
(format result-stream "~&~%~% variations:~% systems: ~
:w
~% modules: ~
:w
~% files: ~
:w
"
(format result-stream "~&~%~% variations:~% systems: ~
s
~% modules: ~
s
~% files: ~
s
"
systems modules files)
systems modules files)
(let ((homogeneous-failures 0) (*print-length* nil))
(let ((homogeneous-failures 0) (*print-length* nil))
...
...
This diff is collapsed.
Click to expand it.
test/try-reloading-dependency.asd
deleted
100644 → 0
+
0
−
5
View file @
95c5ffb8
;;; -*- Lisp -*-
(
asdf:defsystem
try-reloading-dependency
:components
((
:file
"file3"
)))
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