Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
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
Carl Shapiro
cmucl
Commits
a90ddc62
Commit
a90ddc62
authored
11 years ago
by
Raymond Toy
Browse files
Options
Downloads
Patches
Plain Diff
Update to asdf 3.0.2.
parent
d2e0e8e2
Branches
Branches containing commit
Tags
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
src/contrib/asdf/asdf.lisp
+167
-92
167 additions, 92 deletions
src/contrib/asdf/asdf.lisp
with
167 additions
and
92 deletions
src/contrib/asdf/asdf.lisp
+
167
−
92
View file @
a90ddc62
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 3.0.
1
: Another System Definition Facility.
;;; This is ASDF 3.0.
2
: 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>.
...
@@ -70,8 +70,8 @@
...
@@ -70,8 +70,8 @@
(
existing-major-minor
(
subseq
existing-version
0
second-dot
))
(
existing-major-minor
(
subseq
existing-version
0
second-dot
))
(
existing-version-number
(
and
existing-version
(
read-from-string
existing-major-minor
)))
(
existing-version-number
(
and
existing-version
(
read-from-string
existing-major-minor
)))
(
away
(
format
nil
"~A-~A"
:asdf
existing-version
)))
(
away
(
format
nil
"~A-~A"
:asdf
existing-version
)))
(
when
(
and
existing-version
(
<
existing-version-number
(
when
(
and
existing-version
(
o
r
#+
abcl
2.25
#+
cmu
2.018
#-
(
or
abcl
cmu
)
2.27
))
)
(
<
existing-version-numbe
r
#+
abcl
2.25
#+
cmu
2.018
#-
(
or
abcl
cmu
)
2.27
))
(
rename-package
:asdf
away
)
(
rename-package
:asdf
away
)
(
when
*load-verbose*
(
when
*load-verbose*
(
format
t
"~&; Renamed old ~A package away to ~A~%"
:asdf
away
))))))
(
format
t
"~&; Renamed old ~A package away to ~A~%"
:asdf
away
))))))
...
@@ -1514,20 +1514,23 @@ or a string describing the format-control of a simple-condition."
...
@@ -1514,20 +1514,23 @@ or a string describing the format-control of a simple-condition."
(
defun
os-windows-p
()
(
defun
os-windows-p
()
(
or
#+
abcl
(
featurep
:windows
)
(
or
#+
abcl
(
featurep
:windows
)
#+
(
and
(
not
(
or
unix
cygwin
darwin
))
(
or
win32
windows
mswindows
mingw32
))
t
))
#+
(
and
(
not
(
or
abcl
unix
cygwin
darwin
))
(
or
win32
windows
mswindows
mingw32
))
t
))
(
defun
os-genera-p
()
(
defun
os-genera-p
()
(
or
#+
genera
t
))
(
or
#+
genera
t
))
(
defun
os-oldmac-p
()
(
or
#+
mcl
t
))
(
defun
detect-os
()
(
defun
detect-os
()
(
flet
((
yes
(
yes
)
(
pushnew
yes
*features*
))
(
loop*
:with
o
(
no
(
no
)
(
setf
*features*
(
remove
no
*features*
)))
)
:for
(
feature
.
detect
)
:in
'
((
:os-unix
.
os-unix-p
)
(
:os-windows
.
os-windows-p
)
(
cond
(
:genera
.
os-genera-p
)
(
:os-oldmac
.
os-oldmac-p
))
((
os-unix-p
)
(
yes
:os-unix
)
(
no
:os-windows
)
(
no
:genera
)
)
:when
(
and
(
not
o
)
(
funcall
detect
))
:do
(
setf
o
feature
)
(
pushnew
o
*features*
)
((
os-windows-p
)
(
yes
:os-windows
)
(
no
:os-unix
)
(
no
:genera
))
:else
:do
(
setf
*features*
(
remove
feature
*features*
))
((
os-genera-p
)
(
no
:os-unix
)
(
no
:os-windows
)
(
yes
:genera
))
:finally
(
t
(
error
"Congratulations for trying
XCVB
on an operating system~%~
(
return
(
or
o
(
error
"Congratulations for trying
ASDF
on an operating system~%~
that is neither Unix, nor Windows, nor
even
Genera.~%Now you port it."
)))))
that is neither Unix, nor Windows, nor Genera
, nor even old MacOS
.~%Now you port it."
)))))
(
detect-os
))
(
detect-os
))
...
@@ -1911,6 +1914,7 @@ then returning the non-empty string value of the variable"
...
@@ -1911,6 +1914,7 @@ then returning the non-empty string value of the variable"
"Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
"Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
tries hard to make a pathname that will actually behave as documented,
tries hard to make a pathname that will actually behave as documented,
despite the peculiarities of each implementation"
despite the peculiarities of each implementation"
;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults.
(
declare
(
ignorable
host
device
directory
name
type
version
defaults
))
(
declare
(
ignorable
host
device
directory
name
type
version
defaults
))
(
apply
'make-pathname
(
apply
'make-pathname
(
append
(
append
...
@@ -1986,12 +1990,14 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
...
@@ -1986,12 +1990,14 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
;; see also "valid physical pathname host" in the CLHS glossary, that suggests
;; see also "valid physical pathname host" in the CLHS glossary, that suggests
;; strings and lists of strings or :unspecific
;; strings and lists of strings or :unspecific
;; But CMUCL decides to die on NIL.
;; But CMUCL decides to die on NIL.
;; MCL has issues with make-pathname, nil and defaulting
(
declare
(
ignorable
defaults
))
#.`
(
make-pathname*
:directory
nil
:name
nil
:type
nil
:version
nil
:device
nil
#.`
(
make-pathname*
:directory
nil
:name
nil
:type
nil
:version
nil
:device
nil
:host
(
or
#+
cmu
lisp::*unix-host*
)
:host
(
or
#+
cmu
lisp::*unix-host*
)
#+
scl
,@'
(
:scheme
nil
:scheme-specific-part
nil
#+
scl
,@'
(
:scheme
nil
:scheme-specific-part
nil
:username
nil
:password
nil
:parameters
nil
:query
nil
:fragment
nil
)
:username
nil
:password
nil
:parameters
nil
:query
nil
:fragment
nil
)
;; the default shouldn't matter, but we really want something physical
;; the default shouldn't matter, but we really want something physical
:defaults
defaults
))
#-
mcl
,@'
(
:defaults
defaults
))
)
(
defvar
*nil-pathname*
(
nil-pathname
(
translate-logical-pathname
(
user-homedir-pathname
))))
(
defvar
*nil-pathname*
(
nil-pathname
(
translate-logical-pathname
(
user-homedir-pathname
))))
...
@@ -2259,7 +2265,7 @@ to throw an error if the pathname is absolute"
...
@@ -2259,7 +2265,7 @@ to throw an error if the pathname is absolute"
(
make-pathname*
(
make-pathname*
:directory
(
unless
file-only
(
cons
relative
path
))
:directory
(
unless
file-only
(
cons
relative
path
))
:name
name
:type
type
:name
name
:type
type
:defaults
(
or
defaults
*nil-pathname*
))
:defaults
(
or
#-
mcl
defaults
*nil-pathname*
))
(
remove-plist-keys
'
(
:type
:dot-dot
:defaults
)
keys
))))))
(
remove-plist-keys
'
(
:type
:dot-dot
:defaults
)
keys
))))))
(
defun
unix-namestring
(
pathname
)
(
defun
unix-namestring
(
pathname
)
...
@@ -3143,7 +3149,7 @@ hopefully, if done consistently, that won't affect program behavior too much.")
...
@@ -3143,7 +3149,7 @@ hopefully, if done consistently, that won't affect program behavior too much.")
and implementation-defined external-format's"
)
and implementation-defined external-format's"
)
(
defun
encoding-external-format
(
encoding
)
(
defun
encoding-external-format
(
encoding
)
(
funcall
*encoding-external-format-hook*
encoding
)))
(
funcall
*encoding-external-format-hook*
(
or
encoding
*default-encoding*
)
)))
;;; Safe syntax
;;; Safe syntax
...
@@ -3613,7 +3619,7 @@ This is designed to abstract away the implementation specific quit forms."
...
@@ -3613,7 +3619,7 @@ This is designed to abstract away the implementation specific quit forms."
#+
gcl
(
lisp:quit
code
)
#+
gcl
(
lisp:quit
code
)
#+
genera
(
error
"You probably don't want to Halt the Machine. (code: ~S)"
code
)
#+
genera
(
error
"You probably don't want to Halt the Machine. (code: ~S)"
code
)
#+
lispworks
(
lispworks:quit
:status
code
:confirm
nil
:return
nil
:ignore-errors-p
t
)
#+
lispworks
(
lispworks:quit
:status
code
:confirm
nil
:return
nil
:ignore-errors-p
t
)
#+
mcl
(
ccl:quit
)
;; or should we use FFI to call libc's exit(3) ?
#+
mcl
(
progn
code
(
ccl:quit
)
)
;; or should we use FFI to call libc's exit(3) ?
#+
mkcl
(
mk-ext:quit
:exit-code
code
)
#+
mkcl
(
mk-ext:quit
:exit-code
code
)
#+
sbcl
#.
(
let
((
exit
(
find-symbol*
:exit
:sb-ext
nil
))
#+
sbcl
#.
(
let
((
exit
(
find-symbol*
:exit
:sb-ext
nil
))
(
quit
(
find-symbol*
:quit
:sb-ext
nil
)))
(
quit
(
find-symbol*
:quit
:sb-ext
nil
)))
...
@@ -3627,9 +3633,7 @@ This is designed to abstract away the implementation specific quit forms."
...
@@ -3627,9 +3633,7 @@ This is designed to abstract away the implementation specific quit forms."
"Die in error with some error message"
"Die in error with some error message"
(
with-safe-io-syntax
()
(
with-safe-io-syntax
()
(
ignore-errors
(
ignore-errors
(
fresh-line
*stderr*
)
(
format!
*stderr*
"~&~?~&"
format
arguments
)))
(
apply
#'
format
*stderr*
format
arguments
)
(
format!
*stderr*
"~&"
)))
(
quit
code
))
(
quit
code
))
(
defun
raw-print-backtrace
(
&key
(
stream
*debug-io*
)
count
)
(
defun
raw-print-backtrace
(
&key
(
stream
*debug-io*
)
count
)
...
@@ -3651,7 +3655,8 @@ This is designed to abstract away the implementation specific quit forms."
...
@@ -3651,7 +3655,8 @@ This is designed to abstract away the implementation specific quit forms."
(
system::print-backtrace
:out
stream
:limit
count
)
(
system::print-backtrace
:out
stream
:limit
count
)
#+
(
or
clozure
mcl
)
#+
(
or
clozure
mcl
)
(
let
((
*debug-io*
stream
))
(
let
((
*debug-io*
stream
))
(
ccl:print-call-history
:count
count
:start-frame-number
1
)
#+
clozure
(
ccl:print-call-history
:count
count
:start-frame-number
1
)
#+
mcl
(
ccl:print-call-history
:detailed-p
nil
)
(
finish-output
stream
))
(
finish-output
stream
))
#+
(
or
cmu
scl
)
#+
(
or
cmu
scl
)
(
let
((
debug:*debug-print-level*
*print-level*
)
(
let
((
debug:*debug-print-level*
*print-level*
)
...
@@ -3742,11 +3747,11 @@ This is designed to abstract away the implementation specific quit forms."
...
@@ -3742,11 +3747,11 @@ This is designed to abstract away the implementation specific quit forms."
#+
(
or
cmu
scl
)
extensions:*command-line-strings*
#+
(
or
cmu
scl
)
extensions:*command-line-strings*
#+
ecl
(
loop
:for
i
:from
0
:below
(
si:argc
)
:collect
(
si:argv
i
))
#+
ecl
(
loop
:for
i
:from
0
:below
(
si:argc
)
:collect
(
si:argv
i
))
#+
gcl
si:*command-args*
#+
gcl
si:*command-args*
#+
genera
nil
#+
(
or
genera
mcl
)
nil
#+
lispworks
sys:*line-arguments-list*
#+
lispworks
sys:*line-arguments-list*
#+
sbcl
sb-ext:*posix-argv*
#+
sbcl
sb-ext:*posix-argv*
#+
xcl
system:*argv*
#+
xcl
system:*argv*
#-
(
or
abcl
allegro
clisp
clozure
cmu
ecl
gcl
genera
lispworks
sbcl
scl
xcl
)
#-
(
or
abcl
allegro
clisp
clozure
cmu
ecl
gcl
genera
lispworks
mcl
sbcl
scl
xcl
)
(
error
"raw-command-line-arguments not implemented yet"
))
(
error
"raw-command-line-arguments not implemented yet"
))
(
defun
command-line-arguments
(
&optional
(
arguments
(
raw-command-line-arguments
)))
(
defun
command-line-arguments
(
&optional
(
arguments
(
raw-command-line-arguments
)))
...
@@ -4139,10 +4144,22 @@ return the exit status code of the process that was called.
...
@@ -4139,10 +4144,22 @@ return the exit status code of the process that was called.
if it was NIL, the output is discarded;
if it was NIL, the output is discarded;
if it was :INTERACTIVE, the output and the input are inherited from the current process.
if it was :INTERACTIVE, the output and the input are inherited from the current process.
Otherwise, the output will be processed by SLURP-INPUT-STREAM,
Otherwise, OUTPUT should be a value that is a suitable first argument to
using OUTPUT as the first argument, and return whatever it returns,
SLURP-INPUT-STREAM. In this case, RUN-PROGRAM will create a temporary stream
e.g. using :OUTPUT :STRING will have it return the entire output stream as a string.
for the program output. The program output, in that stream, will be processed
Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
by SLURP-INPUT-STREAM, according to the using OUTPUT as the first argument.
RUN-PROGRAM will return whatever SLURP-INPUT-STREAM returns. E.g., using
:OUTPUT :STRING will have it return the entire output stream as a string. Use
ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
;; TODO: The current version does not honor :OUTPUT NIL on Allegro. Setting
;; the :INPUT and :OUTPUT arguments to RUN-SHELL-COMMAND on ACL actually do
;; what :OUTPUT :INTERACTIVE is advertised to do here. To get the behavior
;; specified for :OUTPUT NIL, one would have to grab up the process output
;; into a stream and then throw it on the floor. The consequences of
;; getting this wrong seemed so much worse than having excess output that it
;; is not currently implemented.
;; TODO: specially recognize :output pathname ?
;; TODO: specially recognize :output pathname ?
(
declare
(
ignorable
ignore-error-status
element-type
external-format
))
(
declare
(
ignorable
ignore-error-status
element-type
external-format
))
#-
(
or
abcl
allegro
clisp
clozure
cmu
cormanlisp
ecl
gcl
lispworks
mcl
sbcl
scl
xcl
)
#-
(
or
abcl
allegro
clisp
clozure
cmu
cormanlisp
ecl
gcl
lispworks
mcl
sbcl
scl
xcl
)
...
@@ -4184,7 +4201,8 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
...
@@ -4184,7 +4201,8 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
(
excl:run-shell-command
(
excl:run-shell-command
#+
os-unix
(
coerce
(
cons
(
first
command
)
command
)
'vector
)
#+
os-unix
(
coerce
(
cons
(
first
command
)
command
)
'vector
)
#+
os-windows
command
#+
os-windows
command
:input
interactive
:output
(
or
(
and
pipe
:stream
)
interactive
)
:wait
wait
:input
nil
:output
(
and
pipe
:stream
)
:wait
wait
#+
os-windows
:show-window
#+
os-windows
(
and
(
or
(
null
output
)
pipe
)
:hide
))
#+
os-windows
:show-window
#+
os-windows
(
and
(
or
(
null
output
)
pipe
)
:hide
))
#+
clisp
#+
clisp
(
flet
((
run
(
f
&rest
args
)
(
flet
((
run
(
f
&rest
args
)
...
@@ -4276,8 +4294,12 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
...
@@ -4276,8 +4294,12 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
#+
(
or
abcl
xcl
)
(
ext:run-shell-command
command
)
#+
(
or
abcl
xcl
)
(
ext:run-shell-command
command
)
#+
allegro
#+
allegro
(
excl:run-shell-command
(
excl:run-shell-command
command
:input
interactive
:output
interactive
:wait
t
command
#+
os-windows
:show-window
#+
os-windows
(
unless
(
or
interactive
(
eq
output
t
))
:hide
))
:input
nil
:output
nil
:error-output
:output
; write STDERR to output, too
:wait
t
#+
os-windows
:show-window
#+
os-windows
(
unless
(
or
interactive
(
eq
output
t
))
:hide
))
#+
(
or
clisp
clozure
cmu
(
and
lispworks
os-unix
)
sbcl
scl
)
#+
(
or
clisp
clozure
cmu
(
and
lispworks
os-unix
)
sbcl
scl
)
(
process-result
(
run-program
command
:pipe
nil
:interactive
interactive
)
nil
)
(
process-result
(
run-program
command
:pipe
nil
:interactive
interactive
)
nil
)
#+
ecl
(
ext:system
command
)
#+
ecl
(
ext:system
command
)
...
@@ -4626,7 +4648,7 @@ using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently
...
@@ -4626,7 +4648,7 @@ using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently
WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
#+
allegro
#+
allegro
(
list
:functions-defined
excl::.functions-defined.
(
list
:functions-defined
excl::.functions-defined.
:functions-called
excl::.functions-called.
)
:functions-called
excl::.functions-called.
)
#+
clozure
#+
clozure
(
mapcar
'reify-deferred-warning
(
mapcar
'reify-deferred-warning
(
if-let
(
dw
ccl::*outstanding-deferred-warnings*
)
(
if-let
(
dw
ccl::*outstanding-deferred-warnings*
)
...
@@ -4668,7 +4690,7 @@ One of three functions required for deferred-warnings support in ASDF."
...
@@ -4668,7 +4690,7 @@ One of three functions required for deferred-warnings support in ASDF."
(
declare
(
ignorable
reified-deferred-warnings
))
(
declare
(
ignorable
reified-deferred-warnings
))
#+
allegro
#+
allegro
(
destructuring-bind
(
&key
functions-defined
functions-called
)
(
destructuring-bind
(
&key
functions-defined
functions-called
)
reified-deferred-warnings
reified-deferred-warnings
(
setf
excl::.functions-defined.
(
setf
excl::.functions-defined.
(
append
functions-defined
excl::.functions-defined.
)
(
append
functions-defined
excl::.functions-defined.
)
excl::.functions-called.
excl::.functions-called.
...
@@ -4883,7 +4905,7 @@ possibly in a different process. Otherwise just run the BODY."
...
@@ -4883,7 +4905,7 @@ possibly in a different process. Otherwise just run the BODY."
(
defun*
(
compile-file*
)
(
input-file
&rest
keys
(
defun*
(
compile-file*
)
(
input-file
&rest
keys
&key
compile-check
output-file
warnings-file
&key
compile-check
output-file
warnings-file
#+
clisp
lib-file
#+
(
or
ecl
mkcl
)
object-file
#+
clisp
lib-file
#+
(
or
ecl
mkcl
)
object-file
#+
sbcl
emit-cfasl
&allow-other-keys
)
&allow-other-keys
)
"This function provides a portable wrapper around COMPILE-FILE.
"This function provides a portable wrapper around COMPILE-FILE.
It ensures that the OUTPUT-FILE value is only returned and
It ensures that the OUTPUT-FILE value is only returned and
...
@@ -4924,12 +4946,23 @@ it will filter them appropriately."
...
@@ -4924,12 +4946,23 @@ it will filter them appropriately."
(
or
object-file
(
or
object-file
(
compile-file-pathname
output-file
:fasl-p
nil
)))
(
compile-file-pathname
output-file
:fasl-p
nil
)))
(
tmp-file
(
tmpize-pathname
output-file
))
(
tmp-file
(
tmpize-pathname
output-file
))
#+
sbcl
(
cfasl-file
(
etypecase
emit-cfasl
(
null
nil
)
((
eql
t
)
(
make-pathname
:type
"cfasl"
:defaults
output-file
))
(
string
(
parse-namestring
emit-cfasl
))
(
pathname
emit-cfasl
)))
#+
sbcl
(
tmp-cfasl
(
when
cfasl-file
(
make-pathname
:type
"cfasl"
:defaults
tmp-file
)))
#+
clisp
#+
clisp
(
tmp-lib
(
make-pathname
:type
"lib"
:defaults
tmp-file
)))
(
tmp-lib
(
make-pathname
:type
"lib"
:defaults
tmp-file
)))
(
multiple-value-bind
(
output-truename
warnings-p
failure-p
)
(
multiple-value-bind
(
output-truename
warnings-p
failure-p
)
(
with-saved-deferred-warnings
(
warnings-file
)
(
with-saved-deferred-warnings
(
warnings-file
)
(
with-muffled-compiler-conditions
()
(
with-muffled-compiler-conditions
()
(
or
#-
(
or
ecl
mkcl
)
(
apply
'compile-file
input-file
:output-file
tmp-file
keywords
)
(
or
#-
(
or
ecl
mkcl
)
(
apply
'compile-file
input-file
:output-file
tmp-file
#+
sbcl
(
if
emit-cfasl
(
list*
:emit-cfasl
tmp-cfasl
keywords
)
keywords
)
#-
sbcl
keywords
)
#+
ecl
(
apply
'compile-file
input-file
:output-file
#+
ecl
(
apply
'compile-file
input-file
:output-file
(
if
object-file
(
if
object-file
(
list*
object-file
:system-p
t
keywords
)
(
list*
object-file
:system-p
t
keywords
)
...
@@ -4954,11 +4987,14 @@ it will filter them appropriately."
...
@@ -4954,11 +4987,14 @@ it will filter them appropriately."
(
delete-file-if-exists
output-file
)
(
delete-file-if-exists
output-file
)
(
when
output-truename
(
when
output-truename
#+
clisp
(
when
lib-file
(
rename-file-overwriting-target
tmp-lib
lib-file
))
#+
clisp
(
when
lib-file
(
rename-file-overwriting-target
tmp-lib
lib-file
))
#+
sbcl
(
when
cfasl-file
(
rename-file-overwriting-target
tmp-cfasl
cfasl-file
))
(
rename-file-overwriting-target
output-truename
output-file
)
(
rename-file-overwriting-target
output-truename
output-file
)
(
setf
output-truename
(
truename
output-file
)))
(
setf
output-truename
(
truename
output-file
)))
#+
clisp
(
delete-file-if-exists
tmp-lib
))
#+
clisp
(
delete-file-if-exists
tmp-lib
))
(
t
;; error or failed check
(
t
;; error or failed check
(
delete-file-if-exists
output-truename
)
(
delete-file-if-exists
output-truename
)
#+
clisp
(
delete-file-if-exists
tmp-lib
)
#+
sbcl
(
delete-file-if-exists
tmp-cfasl
)
(
setf
output-truename
nil
)))
(
setf
output-truename
nil
)))
(
values
output-truename
warnings-p
failure-p
))))
(
values
output-truename
warnings-p
failure-p
))))
...
@@ -5421,7 +5457,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
...
@@ -5421,7 +5457,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
(
asdf-version
"3.0.
1
"
)
(
asdf-version
"3.0.
2
"
)
(
existing-version
(
asdf-version
)))
(
existing-version
(
asdf-version
)))
(
setf
*asdf-version*
asdf-version
)
(
setf
*asdf-version*
asdf-version
)
(
when
(
and
existing-version
(
not
(
equal
asdf-version
existing-version
)))
(
when
(
and
existing-version
(
not
(
equal
asdf-version
existing-version
)))
...
@@ -5439,7 +5475,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
...
@@ -5439,7 +5475,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
#:find-component
;; find-component
#:find-component
;; find-component
#:explain
#:perform
#:perform-with-restarts
#:input-files
#:output-files
;; action
#:explain
#:perform
#:perform-with-restarts
#:input-files
#:output-files
;; action
#:component-depends-on
#:operation-done-p
#:component-depends-on
#:component-depends-on
#:operation-done-p
#:component-depends-on
#:traverse
;;
plan
#:traverse
;;
backward-interface
#:operate
;; operate
#:operate
;; operate
#:parse-component-form
;; defsystem
#:parse-component-form
;; defsystem
#:apply-output-translations
;; output-translations
#:apply-output-translations
;; output-translations
...
@@ -6618,17 +6654,26 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
...
@@ -6618,17 +6654,26 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
;;;; Convenience methods
;;;; Convenience methods
(
with-upgradability
()
(
with-upgradability
()
(
defmacro
define-convenience-action-methods
(
defmacro
define-convenience-action-methods
(
function
(
operation
component
&optional
keyp
)
(
function
formals
&key
if-no-operation
if-no-component
operation-initargs
)
&key
if-no-operation
if-no-component
operation-initargs
)
(
let*
((
rest
(
gensym
"REST"
))
(
let*
((
rest
(
gensym
"REST"
))
(
found
(
gensym
"FOUND"
))
(
found
(
gensym
"FOUND"
))
(
keyp
(
equal
(
last
formals
)
'
(
&key
)))
(
formals-no-key
(
if
keyp
(
butlast
formals
)
formals
))
(
len
(
length
formals-no-key
))
(
operation
'operation
)
(
component
'component
)
(
opix
(
position
operation
formals
))
(
coix
(
position
component
formals
))
(
prefix
(
subseq
formals
0
opix
))
(
suffix
(
subseq
formals
(
1+
coix
)
len
))
(
more-args
(
when
keyp
`
(
&rest
,
rest
&key
&allow-other-keys
))))
(
more-args
(
when
keyp
`
(
&rest
,
rest
&key
&allow-other-keys
))))
(
assert
(
and
(
integerp
opix
)
(
integerp
coix
)
(
=
coix
(
1+
opix
))))
(
flet
((
next-method
(
o
c
)
(
flet
((
next-method
(
o
c
)
(
if
keyp
(
if
keyp
`
(
apply
',function
,
o
,
c
,
rest
)
`
(
apply
',function
,
@
prefix
,
o
,
c
,@
suffix
,
rest
)
`
(
,
function
,
o
,
c
))))
`
(
,
function
,
@
prefix
,
o
,
c
,@
suffix
))))
`
(
progn
`
(
progn
(
defmethod
,
function
((
,
operation
symbol
)
,
component
,@
more-args
)
(
defmethod
,
function
(
,@
prefix
(
,
operation
symbol
)
component
,@
suffix
,@
more-args
)
(
if
,
operation
(
if
,
operation
,
(
next-method
,
(
next-method
(
if
operation-initargs
;backward-compatibility with ASDF1's operate. Yuck.
(
if
operation-initargs
;backward-compatibility with ASDF1's operate. Yuck.
...
@@ -6636,14 +6681,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
...
@@ -6636,14 +6681,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
`
(
make-operation
,
operation
))
`
(
make-operation
,
operation
))
`
(
or
(
find-component
()
,
component
)
,
if-no-component
))
`
(
or
(
find-component
()
,
component
)
,
if-no-component
))
,
if-no-operation
))
,
if-no-operation
))
(
defmethod
,
function
((
,
operation
operation
)
,
component
,@
more-args
)
(
defmethod
,
function
(
,@
prefix
(
,
operation
operation
)
,
component
,@
suffix
,@
more-args
)
(
if
(
typep
,
component
'component
)
(
if
(
typep
,
component
'component
)
(
error
"No defined method for ~S on ~/asdf-action:format-action/"
(
error
"No defined method for ~S on ~/asdf-action:format-action/"
',function
(
cons
,
operation
,
component
))
',function
(
cons
,
operation
,
component
))
(
let
((
,
found
(
find-component
()
,
component
)))
(
if-let
(
,
found
(
find-component
()
,
component
))
(
if
,
found
,
(
next-method
operation
found
)
,
(
next-method
operation
found
)
,
if-no-component
))))))))
,
if-no-component
)))))))))
;;;; self-description
;;;; self-description
...
@@ -6922,15 +6966,14 @@ in some previous image, or T if it needs to be done.")
...
@@ -6922,15 +6966,14 @@ in some previous image, or T if it needs to be done.")
(
defclass
basic-load-op
(
operation
)
())
(
defclass
basic-load-op
(
operation
)
())
(
defclass
basic-compile-op
(
operation
)
(
defclass
basic-compile-op
(
operation
)
((
proclamations
:initarg
:proclamations
:accessor
compile-op-proclamations
:initform
nil
)
((
proclamations
:initarg
:proclamations
:accessor
compile-op-proclamations
:initform
nil
)
(
flags
:initarg
:flags
:accessor
compile-op-flags
(
flags
:initarg
:flags
:accessor
compile-op-flags
:initform
nil
))))
:initform
nil
))))
;;; Our default operations: loading into the current lisp image
;;; Our default operations: loading into the current lisp image
(
with-upgradability
()
(
with-upgradability
()
(
defclass
prepare-op
(
upward-operation
sideway-operation
)
(
defclass
prepare-op
(
upward-operation
sideway-operation
)
((
sideway-operation
:initform
'load-op
)))
((
sideway-operation
:initform
'load-op
)))
(
defclass
load-op
(
basic-load-op
downward-operation
sideway-operation
selfward-operation
)
(
defclass
load-op
(
basic-load-op
downward-operation
sideway-operation
selfward-operation
)
;; NB: even though compile-op depends
-on
on prepare-op it is not needed-in-image-p,
;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
;; so we need to directly depend on prepare-op for its side-effects in the current image.
;; so we need to directly depend on prepare-op for its side-effects in the current image.
((
selfward-operation
:initform
'
(
prepare-op
compile-op
))))
((
selfward-operation
:initform
'
(
prepare-op
compile-op
))))
(
defclass
compile-op
(
basic-compile-op
downward-operation
selfward-operation
)
(
defclass
compile-op
(
basic-compile-op
downward-operation
selfward-operation
)
...
@@ -7161,7 +7204,7 @@ in some previous image, or T if it needs to be done.")
...
@@ -7161,7 +7204,7 @@ in some previous image, or T if it needs to be done.")
#:visit-dependencies
#:compute-action-stamp
#:traverse-action
#:visit-dependencies
#:compute-action-stamp
#:traverse-action
#:circular-dependency
#:circular-dependency-actions
#:circular-dependency
#:circular-dependency-actions
#:call-while-visiting-action
#:while-visiting-action
#:call-while-visiting-action
#:while-visiting-action
#:
traverse
#:plan-actions
#:perform-plan
#:plan-operates-on-p
#:
make-plan
#:plan-actions
#:perform-plan
#:plan-operates-on-p
#:planned-p
#:index
#:forced
#:forced-not
#:total-action-count
#:planned-p
#:index
#:forced
#:forced-not
#:total-action-count
#:planned-action-count
#:planned-output-action-count
#:visited-actions
#:planned-action-count
#:planned-output-action-count
#:visited-actions
#:visiting-action-set
#:visiting-action-list
#:plan-actions-r
#:visiting-action-set
#:visiting-action-list
#:plan-actions-r
...
@@ -7347,8 +7390,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
...
@@ -7347,8 +7390,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
(
in-files
(
input-files
o
c
))
(
in-files
(
input-files
o
c
))
;; Three kinds of actions:
;; Three kinds of actions:
(
out-op
(
and
out-files
t
))
; those that create files on the filesystem
(
out-op
(
and
out-files
t
))
; those that create files on the filesystem
;(image-op (and in-files (null out-files))) ; those that load stuff into the image
;
;(image-op (and in-files (null out-files))) ; those that load stuff into the image
;(null-op (and (null out-files) (null in-files))) ;
dependency
placeholders that do nothing
;
;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
;; When was the thing last actually done? (Now, or ask.)
;; When was the thing last actually done? (Now, or ask.)
(
op-time
(
or
just-done
(
component-operation-time
o
c
)))
(
op-time
(
or
just-done
(
component-operation-time
o
c
)))
;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
...
@@ -7467,7 +7510,9 @@ the action of OPERATION on COMPONENT in the PLAN"))
...
@@ -7467,7 +7510,9 @@ the action of OPERATION on COMPONENT in the PLAN"))
:stamp
stamp
:stamp
stamp
:done-p
(
and
done-p
(
not
add-to-plan-p
))
:done-p
(
and
done-p
(
not
add-to-plan-p
))
:planned-p
add-to-plan-p
:planned-p
add-to-plan-p
:index
(
if
status
(
action-index
status
)
(
incf
(
plan-total-action-count
plan
)))))
:index
(
if
status
(
action-index
status
)
(
incf
(
plan-total-action-count
plan
)))))
(
when
add-to-plan-p
(
when
add-to-plan-p
(
incf
(
plan-planned-action-count
plan
))
(
incf
(
plan-planned-action-count
plan
))
(
unless
aniip
(
unless
aniip
...
@@ -7483,6 +7528,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
...
@@ -7483,6 +7528,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
((
actions-r
:initform
nil
:accessor
plan-actions-r
)))
((
actions-r
:initform
nil
:accessor
plan-actions-r
)))
(
defgeneric
plan-actions
(
plan
))
(
defgeneric
plan-actions
(
plan
))
(
defmethod
plan-actions
((
plan
list
))
plan
)
(
defmethod
plan-actions
((
plan
sequential-plan
))
(
defmethod
plan-actions
((
plan
sequential-plan
))
(
reverse
(
plan-actions-r
plan
)))
(
reverse
(
plan-actions-r
plan
)))
...
@@ -7499,45 +7546,46 @@ the action of OPERATION on COMPONENT in the PLAN"))
...
@@ -7499,45 +7546,46 @@ the action of OPERATION on COMPONENT in the PLAN"))
;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
(
with-upgradability
()
(
with-upgradability
()
(
defgeneric
*
(
traverse
)
(
operation
component
&key
&allow-other-keys
)
(
defgeneric
make-plan
(
plan-class
operation
component
&key
&allow-other-keys
)
(
:documentation
(
:documentation
"Generate and return a plan for performing OPERATION on COMPONENT.
"Generate and return a plan for performing OPERATION on COMPONENT."
))
(
define-convenience-action-methods
make-plan
(
plan-class
operation
component
&key
))
The plan returned is a list of dotted-pairs. Each pair is the CONS
of ASDF operation object and a COMPONENT object. The pairs will be
processed in order by OPERATE."
))
(
define-convenience-action-methods
traverse
(
operation
component
&key
))
(
defgeneric
perform-plan
(
plan
&key
))
(
defgeneric
perform-plan
(
plan
&key
))
(
defgeneric
plan-operates-on-p
(
plan
component
))
(
defgeneric
plan-operates-on-p
(
plan
component
))
(
defvar
*default-plan-class*
'sequential-plan
)
(
defvar
*default-plan-class*
'sequential-plan
)
(
defmethod
traverse
(
(
o
operation
)
(
c
component
)
&rest
keys
&key
plan-class
&allow-other-keys
)
(
defmethod
make-plan
(
plan-class
(
o
operation
)
(
c
component
)
&rest
keys
&key
&allow-other-keys
)
(
let
((
plan
(
apply
'make-instance
(
let
((
plan
(
apply
'make-instance
(
or
plan-class
*default-plan-class*
)
(
or
plan-class
*default-plan-class*
)
:system
(
component-system
c
)
(
remove-plist-key
:plan-class
keys
)))
)
:system
(
component-system
c
)
keys
)))
(
traverse-action
plan
o
c
t
)
(
traverse-action
plan
o
c
t
)
(
plan
-actions
plan
)
))
plan
))
(
defmethod
perform-plan
:around
(
plan
&key
)
(
defmethod
perform-plan
:around
((
plan
t
)
&key
)
(
declare
(
ignorable
plan
))
(
let
((
*package*
*package*
)
(
let
((
*package*
*package*
)
(
*readtable*
*readtable*
))
(
*readtable*
*readtable*
))
(
with-compilation-unit
()
;; backward-compatibility.
(
with-compilation-unit
()
;; backward-compatibility.
(
call-next-method
))))
;; Going forward, see deferred-warning support in lisp-build.
(
call-next-method
))))
;; Going forward, see deferred-warning support in lisp-build.
(
defmethod
perform-plan
((
plan
t
)
&rest
keys
&key
&allow-other-keys
)
(
apply
'perform-plan
(
plan-actions
plan
)
keys
))
(
defmethod
perform-plan
((
steps
list
)
&key
force
&allow-other-keys
)
(
defmethod
perform-plan
((
steps
list
)
&key
force
&allow-other-keys
)
(
loop*
:for
(
o
.
c
)
:in
steps
(
loop*
:for
(
o
.
c
)
:in
steps
:when
(
or
force
(
not
(
nth-value
1
(
compute-action-stamp
nil
o
c
))))
:when
(
or
force
(
not
(
nth-value
1
(
compute-action-stamp
nil
o
c
))))
:do
(
perform-with-restarts
o
c
)))
:do
(
perform-with-restarts
o
c
)))
(
defmethod
plan-operates-on-p
((
plan
plan-traversal
)
(
component-path
list
))
(
plan-operates-on-p
(
plan-actions
plan
)
component-path
))
(
defmethod
plan-operates-on-p
((
plan
list
)
(
component-path
list
))
(
defmethod
plan-operates-on-p
((
plan
list
)
(
component-path
list
))
(
find
component-path
(
mapcar
'cdr
plan
)
(
find
component-path
(
mapcar
'cdr
plan
)
:test
'equal
:key
'component-find-path
)))
:test
'equal
:key
'component-find-path
)))
;;;; Incidental traversals
;;;; Incidental traversals
(
with-upgradability
()
(
with-upgradability
()
(
defclass
filtered-sequential-plan
(
sequential-plan
)
(
defclass
filtered-sequential-plan
(
sequential-plan
)
((
action-filter
:initform
t
:initarg
:action-filter
:reader
plan-action-filter
)
((
action-filter
:initform
t
:initarg
:action-filter
:reader
plan-action-filter
)
...
@@ -7561,11 +7609,10 @@ processed in order by OPERATE."))
...
@@ -7561,11 +7609,10 @@ processed in order by OPERATE."))
(
defmethod
traverse-actions
(
actions
&rest
keys
&key
plan-class
&allow-other-keys
)
(
defmethod
traverse-actions
(
actions
&rest
keys
&key
plan-class
&allow-other-keys
)
(
let
((
plan
(
apply
'make-instance
(
or
plan-class
'filtered-sequential-plan
)
keys
)))
(
let
((
plan
(
apply
'make-instance
(
or
plan-class
'filtered-sequential-plan
)
keys
)))
(
loop*
:for
(
o
.
c
)
:in
actions
:do
(
loop*
:for
(
o
.
c
)
:in
actions
:do
(
traverse-action
plan
o
c
t
))
(
traverse-action
plan
o
c
t
))
plan
))
(
plan-actions
plan
)))
(
define-convenience-action-methods
traverse-sub-actions
(
o
c
&key
))
(
define-convenience-action-methods
traverse-sub-actions
(
o
peration
component
&key
))
(
defmethod
traverse-sub-actions
((
operation
operation
)
(
component
component
)
&rest
keys
&key
&allow-other-keys
)
(
defmethod
traverse-sub-actions
((
operation
operation
)
(
component
component
)
&rest
keys
&key
&allow-other-keys
)
(
apply
'traverse-actions
(
direct-dependencies
operation
component
)
(
apply
'traverse-actions
(
direct-dependencies
operation
component
)
:system
(
component-system
component
)
keys
))
:system
(
component-system
component
)
keys
))
...
@@ -7573,14 +7620,14 @@ processed in order by OPERATE."))
...
@@ -7573,14 +7620,14 @@ processed in order by OPERATE."))
(
defmethod
plan-actions
((
plan
filtered-sequential-plan
))
(
defmethod
plan-actions
((
plan
filtered-sequential-plan
))
(
with-slots
(
keep-operation
keep-component
)
plan
(
with-slots
(
keep-operation
keep-component
)
plan
(
loop*
:for
(
o
.
c
)
:in
(
call-next-method
)
(
loop*
:for
(
o
.
c
)
:in
(
call-next-method
)
:when
(
and
(
typep
o
keep-operation
)
:when
(
and
(
typep
o
keep-operation
)
(
typep
c
keep-component
))
(
typep
c
keep-component
))
:collect
(
cons
o
c
))))
:collect
(
cons
o
c
))))
(
defmethod
required-components
(
system
&rest
keys
&key
(
goal-operation
'load-op
)
&allow-other-keys
)
(
defmethod
required-components
(
system
&rest
keys
&key
(
goal-operation
'load-op
)
&allow-other-keys
)
(
remove-duplicates
(
remove-duplicates
(
mapcar
'cdr
(
apply
'traverse-sub-actions
goal-operation
system
(
mapcar
'cdr
(
plan-actions
(
remove-plist-key
:goal-operation
keys
)))
(
apply
'traverse-sub-actions
goal-operation
system
(
remove-plist-key
:goal-operation
keys
))))
:from-end
t
)))
:from-end
t
)))
;;;; -------------------------------------------------------------------------
;;;; -------------------------------------------------------------------------
...
@@ -7671,8 +7718,8 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
...
@@ -7671,8 +7718,8 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
(
error
'missing-component-of-version
:requires
component
:version
version
)))
(
error
'missing-component-of-version
:requires
component
:version
version
)))
(
defmethod
operate
((
operation
operation
)
(
component
component
)
(
defmethod
operate
((
operation
operation
)
(
component
component
)
&rest
keys
&key
&allow-other-keys
)
&rest
keys
&key
plan-class
&allow-other-keys
)
(
let
((
plan
(
apply
'
traverse
operation
component
keys
)))
(
let
((
plan
(
apply
'
make-plan
plan-class
operation
component
keys
)))
(
apply
'perform-plan
plan
keys
)
(
apply
'perform-plan
plan
keys
)
(
values
operation
plan
)))
(
values
operation
plan
)))
...
@@ -7797,7 +7844,7 @@ for how to load or compile stuff")
...
@@ -7797,7 +7844,7 @@ for how to load or compile stuff")
;;;; -------------------------------------------------------------------------
;;;; -------------------------------------------------------------------------
;;; Internal hacks for backward-compatibility
;;; Internal hacks for backward-compatibility
(
asdf/package:define-package
:asdf/backward-internals
(
asdf/package:define-package
:asdf/backward-internals
(
:recycle
:asdf/backward-internals
:asdf
)
(
:recycle
:asdf/backward-internals
:asdf
)
...
@@ -8181,14 +8228,16 @@ for how to load or compile stuff")
...
@@ -8181,14 +8228,16 @@ for how to load or compile stuff")
;; we'd have to have the monolithic-op not inherit from the main op,
;; we'd have to have the monolithic-op not inherit from the main op,
;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
(
defclass
lib-op
(
bundle-compile-op
)
(
defclass
no-ld-flags-op
(
operation
)
())
(
defclass
lib-op
(
bundle-compile-op
no-ld-flags-op
)
((
bundle-type
:initform
#+
(
or
ecl
mkcl
)
:lib
#-
(
or
ecl
mkcl
)
:no-output-file
))
((
bundle-type
:initform
#+
(
or
ecl
mkcl
)
:lib
#-
(
or
ecl
mkcl
)
:no-output-file
))
(
:documentation
#+
(
or
ecl
mkcl
)
"compile the system and produce linkable (.a) library for it."
(
:documentation
#+
(
or
ecl
mkcl
)
"compile the system and produce linkable (.a) library for it."
#-
(
or
ecl
mkcl
)
"just compile the system"
))
#-
(
or
ecl
mkcl
)
"just compile the system"
))
(
defclass
dll-op
(
bundle-
op
basic-compile
-op
)
(
defclass
dll-op
(
bundle-
compile-op
selfward-operation
no-ld-flags
-op
)
((
bundle-type
:initform
:dll
))
((
bundle-type
:initform
:dll
))
(
:documentation
"
Link together all the dynamic library used by this system into a single one
."
))
(
:documentation
"
compile the system and produce dynamic (.so/.dll) library for it
."
))
(
defclass
binary-op
(
basic-compile-op
selfward-operation
)
(
defclass
binary-op
(
basic-compile-op
selfward-operation
)
((
selfward-operation
:initform
'
(
fasl-op
lib-op
)))
((
selfward-operation
:initform
'
(
fasl-op
lib-op
)))
...
@@ -8211,15 +8260,14 @@ for how to load or compile stuff")
...
@@ -8211,15 +8260,14 @@ for how to load or compile stuff")
(
defclass
monolithic-fasl-op
(
monolithic-bundle-compile-op
basic-fasl-op
)
()
(
defclass
monolithic-fasl-op
(
monolithic-bundle-compile-op
basic-fasl-op
)
()
(
:documentation
"Create a single fasl for the system and its dependencies."
))
(
:documentation
"Create a single fasl for the system and its dependencies."
))
(
defclass
monolithic-lib-op
(
monolithic-bundle-compile-op
basic-compile-op
)
(
defclass
monolithic-lib-op
(
monolithic-bundle-compile-op
basic-compile-op
no-ld-flags-op
)
((
bundle-type
:initform
#+
(
or
ecl
mkcl
)
:lib
#-
(
or
ecl
mkcl
)
:no-output-file
))
((
bundle-type
:initform
#+
(
or
ecl
mkcl
)
:lib
#-
(
or
ecl
mkcl
)
:no-output-file
))
(
:documentation
#+
(
or
ecl
mkcl
)
"Create a single linkable library for the system and its dependencies."
(
:documentation
#+
(
or
ecl
mkcl
)
"Create a single linkable library for the system and its dependencies."
#-
(
or
ecl
mkcl
)
"Compile a system and its dependencies."
))
#-
(
or
ecl
mkcl
)
"Compile a system and its dependencies."
))
(
defclass
monolithic-dll-op
(
monolithic-bundle-op
basic-compile-op
sideway-operation
selfward-operation
)
(
defclass
monolithic-dll-op
(
monolithic-bundle-compile-op
sideway-operation
selfward-operation
no-ld-flags-op
)
((
bundle-type
:initform
:dll
)
((
bundle-type
:initform
:dll
))
(
selfward-operation
:initform
'dll-op
)
(
:documentation
"Create a single dynamic (.so/.dll) library for the system and its dependencies."
))
(
sideway-operation
:initform
'dll-op
)))
(
defclass
program-op
#+
(
or
mkcl
ecl
)
(
monolithic-bundle-compile-op
)
(
defclass
program-op
#+
(
or
mkcl
ecl
)
(
monolithic-bundle-compile-op
)
#-
(
or
mkcl
ecl
)
(
monolithic-bundle-op
selfward-operation
)
#-
(
or
mkcl
ecl
)
(
monolithic-bundle-op
selfward-operation
)
...
@@ -8233,7 +8281,7 @@ for how to load or compile stuff")
...
@@ -8233,7 +8281,7 @@ for how to load or compile stuff")
((
or
null
string
)
bundle-type
)
((
or
null
string
)
bundle-type
)
((
eql
:fasl
)
#-
(
or
ecl
mkcl
)
(
compile-file-type
)
#+
(
or
ecl
mkcl
)
"fasb"
)
((
eql
:fasl
)
#-
(
or
ecl
mkcl
)
(
compile-file-type
)
#+
(
or
ecl
mkcl
)
"fasb"
)
#+
ecl
#+
ecl
((
member
:binary
:dll
:lib
:static-library
:program
:object
:program
)
((
member
:binary
:dll
:lib
:shared-library
:static-library
:program
:object
:program
)
(
compile-file-type
:type
bundle-type
))
(
compile-file-type
:type
bundle-type
))
((
eql
:binary
)
"image"
)
((
eql
:binary
)
"image"
)
((
eql
:dll
)
(
cond
((
os-unix-p
)
"so"
)
((
os-windows-p
)
"dll"
)))
((
eql
:dll
)
(
cond
((
os-unix-p
)
"so"
)
((
os-windows-p
)
"dll"
)))
...
@@ -8305,7 +8353,7 @@ for how to load or compile stuff")
...
@@ -8305,7 +8353,7 @@ for how to load or compile stuff")
(
remove-plist-keys
'
(
:type
:monolithic
:name-suffix
)
(
remove-plist-keys
'
(
:type
:monolithic
:name-suffix
)
(
operation-original-initargs
instance
))))
(
operation-original-initargs
instance
))))
(
defmethod
bundle-op-build-args
:around
((
o
lib
-op
))
(
defmethod
bundle-op-build-args
:around
((
o
no-ld-flags
-op
))
(
declare
(
ignorable
o
))
(
declare
(
ignorable
o
))
(
let
((
args
(
call-next-method
)))
(
let
((
args
(
call-next-method
)))
(
remf
args
:ld-flags
)
(
remf
args
:ld-flags
)
...
@@ -9032,11 +9080,11 @@ effectively disabling the output translation facility."
...
@@ -9032,11 +9080,11 @@ effectively disabling the output translation facility."
(
:recycle
:asdf/backward-interface
:asdf
)
(
:recycle
:asdf/backward-interface
:asdf
)
(
:use
:uiop/common-lisp
:uiop
:asdf/upgrade
(
:use
:uiop/common-lisp
:uiop
:asdf/upgrade
:asdf/component
:asdf/system
:asdf/find-system
:asdf/operation
:asdf/action
:asdf/component
:asdf/system
:asdf/find-system
:asdf/operation
:asdf/action
:asdf/lisp-action
:asdf/operate
:asdf/output-translations
)
:asdf/lisp-action
:asdf/plan
:asdf/operate
:asdf/output-translations
)
(
:export
(
:export
#:*asdf-verbose*
#:*asdf-verbose*
#:operation-error
#:compile-error
#:compile-failed
#:compile-warned
#:operation-error
#:compile-error
#:compile-failed
#:compile-warned
#:error-component
#:error-operation
#:error-component
#:error-operation
#:traverse
#:component-load-dependencies
#:component-load-dependencies
#:enable-asdf-binary-locations-compatibility
#:enable-asdf-binary-locations-compatibility
#:operation-forced
#:operation-forced
...
@@ -9089,7 +9137,19 @@ We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
...
@@ -9089,7 +9137,19 @@ We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
for a mostly compatible replacement that we're supporting,
for a mostly compatible replacement that we're supporting,
or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
if that's whay you mean."
;;)
if that's whay you mean."
;;)
(
system-source-file
x
)))
(
system-source-file
x
))
(
defgeneric*
(
traverse
)
(
operation
component
&key
&allow-other-keys
)
(
:documentation
"Generate and return a plan for performing OPERATION on COMPONENT.
The plan returned is a list of dotted-pairs. Each pair is the CONS
of ASDF operation object and a COMPONENT object. The pairs will be
processed in order by OPERATE."
))
(
define-convenience-action-methods
traverse
(
operation
component
&key
))
(
defmethod
traverse
((
o
operation
)
(
c
component
)
&rest
keys
&key
plan-class
&allow-other-keys
)
(
plan-actions
(
apply
'make-plan
plan-class
o
c
keys
))))
;;;; ASDF-Binary-Locations compatibility
;;;; ASDF-Binary-Locations compatibility
...
@@ -9160,7 +9220,15 @@ Deprecated function, for backward-compatibility only.
...
@@ -9160,7 +9220,15 @@ Deprecated function, for backward-compatibility only.
Please use UIOP:RUN-PROGRAM instead."
Please use UIOP:RUN-PROGRAM instead."
(
let
((
command
(
apply
'format
nil
control-string
args
)))
(
let
((
command
(
apply
'format
nil
control-string
args
)))
(
asdf-message
"; $ ~A~%"
command
)
(
asdf-message
"; $ ~A~%"
command
)
(
run-program
command
:force-shell
t
:ignore-error-status
t
:output
*verbose-out*
))))
(
handler-case
(
progn
(
run-program
command
:force-shell
t
:ignore-error-status
nil
:output
*verbose-out*
)
0
)
(
subprocess-error
(
c
)
(
let
((
code
(
subprocess-error-code
c
)))
(
typecase
code
(
integer
code
)
(
t
255
))))))))
(
with-upgradability
()
(
with-upgradability
()
(
defvar
*asdf-verbose*
nil
))
;; backward-compatibility with ASDF2 only. Unused.
(
defvar
*asdf-verbose*
nil
))
;; backward-compatibility with ASDF2 only. Unused.
...
@@ -9470,7 +9538,7 @@ system names to pathnames of .asd files")
...
@@ -9470,7 +9538,7 @@ system names to pathnames of .asd files")
(
defvar
*source-registry-parameter*
nil
)
(
defvar
*source-registry-parameter*
nil
)
(
defun
initialize-source-registry
(
&optional
(
parameter
*source-registry-parameter*
))
(
defun
initialize-source-registry
(
&optional
(
parameter
*source-registry-parameter*
))
;; Record the parameter used to configure the registry
;; Record the parameter used to configure the registry
(
setf
*source-registry-parameter*
parameter
)
(
setf
*source-registry-parameter*
parameter
)
;; Clear the previous registry database:
;; Clear the previous registry database:
(
setf
*source-registry*
(
make-hash-table
:test
'equal
))
(
setf
*source-registry*
(
make-hash-table
:test
'equal
))
...
@@ -9516,7 +9584,7 @@ system names to pathnames of .asd files")
...
@@ -9516,7 +9584,7 @@ system names to pathnames of .asd files")
;; TODO: automatically generate interface with reexport?
;; TODO: automatically generate interface with reexport?
(
:export
(
:export
#:defsystem
#:find-system
#:locate-system
#:coerce-name
#:defsystem
#:find-system
#:locate-system
#:coerce-name
#:oos
#:operate
#:
traverse
#:perform-plan
#:sequential-plan
#:oos
#:operate
#:
make-plan
#:perform-plan
#:sequential-plan
#:system-definition-pathname
#:with-system-definitions
#:system-definition-pathname
#:with-system-definitions
#:search-for-system-definition
#:find-component
#:component-find-path
#:search-for-system-definition
#:find-component
#:component-find-path
#:compile-system
#:load-system
#:load-systems
#:compile-system
#:load-system
#:load-systems
...
@@ -9572,6 +9640,7 @@ system names to pathnames of .asd files")
...
@@ -9572,6 +9640,7 @@ system names to pathnames of .asd files")
#:module-components
; backward-compatibility
#:module-components
; backward-compatibility
#:operation-on-warnings
#:operation-on-failure
; backward-compatibility
#:operation-on-warnings
#:operation-on-failure
; backward-compatibility
#:component-property
; backward-compatibility
#:component-property
; backward-compatibility
#:traverse
; backward-compatibility
#:system-description
#:system-description
#:system-long-description
#:system-long-description
...
@@ -9706,6 +9775,12 @@ system names to pathnames of .asd files")
...
@@ -9706,6 +9775,12 @@ system names to pathnames of .asd files")
(
and
(
first
l
)
(
register-pre-built-system
(
coerce-name
name
)))
(
and
(
first
l
)
(
register-pre-built-system
(
coerce-name
name
)))
(
values-list
l
))))))))
(
values-list
l
))))))))
#+
cmu
(
with-upgradability
()
(
defun
herald-asdf
(
stream
)
(
format
stream
" ASDF ~A"
(
asdf-version
)))
(
setf
(
getf
ext:*herald-items*
:asdf
)
`
(
herald-asdf
)))
;;;; Done!
;;;; Done!
(
with-upgradability
()
(
with-upgradability
()
...
...
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