ASDF 3.1.2.9

changeset:   2488:0a1ded36af37
bookmark:    master
tag:         default/master
tag:         tip
user:        Francois-Rene Rideau <tunes@google.com>
summary:     Tweak the debian changelog.
parent ab7525f2
......@@ -909,6 +909,7 @@ For that you may use the following function:
regarding source-registry or output-translations.
@end defun
@vindex *image-dump-hook*
This function is pushed onto the @code{uiop:*image-dump-hook*} by default,
which means that if you save an image using @code{uiop:dump-image},
or via @code{asdf:image-op} and @code{asdf:program-op},
......@@ -2388,25 +2389,150 @@ the file's @code{last-modified} time exceeds the @code{last-modified} time
of the system in memory
@end itemize
@cindex ASDF-USER package
When system definitions are loaded from @file{.asd} files,
a new scratch package is created for them to load into,
so that different systems do not overwrite each others operations.
The user may also wish to (and is recommended to)
include @code{defpackage} and @code{in-package} forms
in his system definition files, however,
so that they can be loaded manually if need be.
they are implicitly loaded into the @code{ASDF-USER} package,
which uses @code{ASDF}, @code{UIOP} and @code{UIOP/COMMON-LISP}@footnote{
Note that between releases 2.27 and 3.0.3, only @code{UIOP/PACKAGE},
not all of @code{UIOP}, was used; if you want your code to work
with releases earlier than 3.1.2, you may have to explicitly define a package
that uses @code{UIOP}, or use proper package prefix to your symbols, as in
@code{uiop:version<}.}
Programmers who do anything non-trivial in a @file{.asd} file,
such as defining new variables, functions or classes,
should include @code{defpackage} and @code{in-package} forms in this file,
so they will not overwrite each others' extensions.
Such forms might also help the files behave identically
if loaded manually with @code{cl:load} for development or debugging,
though we recommend you use the function @code{asdf::load-asd} instead,
which the @code{slime-asdf} contrib knows about.
The default value of @code{*system-definition-search-functions*}
is a list of two functions.
is a list of three functions.
The first function looks in each of the directories given
by evaluating members of @code{*central-registry*}
for a file whose name is the name of the system and whose type is @file{asd}.
The first such file is returned,
for a file whose name is the name of the system and whose type is @file{asd};
the first such file is returned,
whether or not it turns out to actually define the appropriate system.
The second function does something similar,
for the directories specified in the @code{source-registry}.
Hence, it is strongly advised to define a system
@var{foo} in the corresponding file @var{foo.asd}.
for the directories specified in the @code{source-registry},
but searches the filesystem only once and caches its results.
The third function makes the @code{package-inferred-system} extension work,
@pxref{The package-inferred-system extension}.
Because of the way these search functions are defined,
you should put the definition for a system
@var{foo} in a file named @file{foo.asd},
in a directory that is
in the central registry or
which can be found using the
source registry configuration.
@c FIXME: Move this discussion to the system definition grammar, or somewhere else.
@anchor{System names}
@cindex System names
@cindex Primary system name
@findex primary-system-name
It is often useful to define multiple systems in a same file,
but ASDF can only locate a system's definition file based on the system
name.
For this reason,
ASDF 3's system search algorithm has been extended to
allow a file @file{foo.asd} to contain
secondary systems named @var{foo/bar}, @var{foo/baz}, @var{foo/quux}, etc.,
in addition to the primary system named @var{foo}.
The first component of a system name,
separated by the slash character, @code{/},
is called the primary name of a system.
The primary name may be
extracted by function @code{asdf::primary-system-name};
when ASDF 3 is told to find a system whose name has a slash,
it will first attempt to load the corresponding primary system,
and will thus see any such definitions, and/or any
definition of a @code{package-inferred-system}.@footnote{
ASDF 2.26 and earlier versions
do not support this primary system name convention.
With these versions of ASDF
you must explicitly load @file{foo.asd}
before you can use system @var{foo/bar} defined therein,
e.g. using @code{(asdf:find-system "foo")}.
We do not support ASDF 2, and recommend that you should upgrade to ASDF 3.
}
If your file @file{foo.asd} also defines systems
that do not follow this convention, e.g., a system named @var{foo-test},
ASDF will not be able to automatically locate a definition for these systems,
and will only see their definition
if you explicitly find or load the primary system
using e.g. @code{(asdf:find-system "foo")} before you try to use them.
We strongly recommend against this practice,
though it is currently supported for backward compatibility.
@end defun
@defun primary-system-name name
Internal (not exported) function, @code{asdf::primary-system-name}.
Returns the primary system name (the portion before
the slash, @code{/}, in a secondary system name) from @var{name}.
@end defun
@defun locate-system name
This function should typically @emph{not} be invoked directly. It is
exported as part of the API only for programmers who wish to provide
their own @code{*system-definition-search-functions*}.
Given a system @var{name} designator,
try to locate where to load the system definition from.
@c (This does not include the loading of the system definition,
@c which is done by @code{find-system},
@c or the loading of the system itself, which is done by @code{load-system};
@c however, for systems the definition of which has already been loaded,
@c @code{locate-system} may return an object of class @code{system}.)
Returns five values: @var{foundp}, @var{found-system}, @var{pathname},
@var{previous}, and @var{previous-time}.
@var{foundp} is true when a system was found,
either a new as yet unregistered one, or a previously registered one.
The @var{found-system} return value
will be a @code{system} object, if a system definition is found in your
source registry.
@c This system may be registered (by @code{register-system}) or may not, if
@c it's preloaded code. Fare writes:
@c In the case of preloaded code, as for "asdf", "uiop", etc.,
@c themselves, the system objects are not registered until after they are
@c initially located by sysdef-preloaded-system-search as a fallback when
@c no source code was found.
The system definition will @emph{not} be
loaded if it hasn't been loaded already.
@var{pathname} when not null is a path from which to load the system,
either associated with @var{found-system}, or with the @var{previous} system.
If @var{previous} is not null, it will be a @emph{previously loaded}
@code{system} object of the same name (note that the system
@emph{definition} is previously-loaded: the system itself may or may not be).
@var{previous-time} when not null is
the timestamp of the previous system definition file, at the
time when the @var{previous} system definition was loaded.
For example, if your current registry has @file{foo.asd} in
@file{/current/path/to/foo.asd},
but system @code{foo} was previously loaded from @file{/previous/path/to/foo.asd}
then @var{locate-system} will return the following values:
@enumerate
@item
@var{foundp} will be @code{T},
@item
@var{found-system} will be @code{NIL},
@item
@var{pathname} will be @code{#p"/current/path/to/foo.asd"},
@item
@var{previous} will be an object of type @code{SYSTEM} with
@code{system-source-file} slot value of
@code{#p"/previous/path/to/foo.asd"}
@item
@var{previous-time} will be the timestamp of
@code{#p"/previous/path/to/foo.asd"} at the time it was loaded.
@end enumerate
@end defun
@defun find-component base path
......@@ -2725,8 +2851,8 @@ the default @code{defsystem} macro takes a @code{:class} keyword argument.
New component types are defined by subclassing one of the existing
component classes and specializing methods on the new component class.
@emph{FIXME: this should perhaps be explained more throughly,
not only by example ...}
@c FIXME: this should perhaps be explained more throughly,
@c not only by example ...
As an example, suppose we have some implementation-dependent
functionality that we want to isolate
......@@ -2769,10 +2895,10 @@ The new component type is used in a @code{defsystem} form in this way:
@c FIXME: Moved this material here, but it isn't very comfortable
@c here.... Also needs to be revised to be coherent.
To be successfully buildable, this graph of actions but be acyclic.
If, as a user, extender or implementer of ASDF, you fail
to keep the dependency graph without cycles,
ASDF will fail loudly as it eventually finds one.
To be successfully build-able, this graph of actions must be acyclic.
If, as a user, extender or implementer of ASDF, you introduce
a cycle into the dependency graph,
ASDF will fail loudly.
To clearly distinguish the direction of dependencies,
ASDF 3 uses the words @emph{requiring} and @emph{required}
as applied to an action depending on the other:
......@@ -2963,7 +3089,7 @@ however we recommend you instead use
our source-registry configuration mechanism described below,
because it is easier to setup in a portable way across users and implementations.
Addtionally, some people dislike truename,
Additionally, some people dislike truename,
either because it is very slow on their system, or
because they are using content-addressed storage where the truename of a file
is related to a digest of its individual contents,
......@@ -3251,9 +3377,9 @@ directory according to X's (relative) instructions.
When considering environment variable @code{CL_SOURCE_REGISTRY}
ASDF will skip to next configuration if it's an empty string.
It will @code{READ} the string as a SEXP in the DSL
if it begins with a paren @code{(}
and it will be interpreted much like @code{TEXINPUTS}
list of paths, where
if it begins with a paren @code{(},
otherwise it will be interpreted much like @code{TEXINPUTS},
as a list of paths, where
* paths are separated
by a @code{:} (colon) on Unix platforms (including cygwin),
......@@ -3709,7 +3835,7 @@ TRANSLATION-FUNCTION :=
SYMBOL | ;; symbol naming a function that takes two arguments:
;; the pathname to be translated and the matching
;; DIRECTORY-DESIGNATOR
LAMBDA ;; A form which evalutates to a function taking two arguments:
LAMBDA ;; A form which evaluates to a function taking two arguments:
;; the pathname to be translated and the matching
;; DIRECTORY-DESIGNATOR
......@@ -3770,7 +3896,7 @@ from the file specified.
If the @code{translate-pathname} mechanism cannot achieve a desired
translation, the user may provide a function which provides the
required algorithim. Such a translation function is specified by
required algorithm. Such a translation function is specified by
supplying a list as the second @code{directory-designator}
the first element of which is the keyword @code{:function},
and the second element of which is
......@@ -5613,3 +5739,6 @@ Also, bugs are now tracked on launchpad:
@printindex vr
@bye
@c LocalWords: clbuild tarballs defsystem Quicklisp initarg uiop fasl
@c LocalWords: namestring initargs fasls
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
;;; This is ASDF 3.1.2.2: Another System Definition Facility.
;;; This is ASDF 3.1.2.9: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......@@ -402,7 +402,7 @@ or when loading the package is optional."
(imported)
(t (push name intern)))))))
(labels ((sort-names (names)
(sort names #'string<))
(sort (copy-list names) #'string<))
(table-keys (table)
(loop :for k :being :the :hash-keys :of table :collect k))
(when-relevant (key value)
......@@ -845,8 +845,8 @@ UNINTERN -- Remove symbols here from PACKAGE."
(uiop/package:define-package :uiop/common-lisp
(:nicknames :uoip/cl :asdf/common-lisp :asdf/cl)
(:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package)
(:reexport :common-lisp)
(:use :uiop/package)
(:use-reexport #-genera :common-lisp #+genera :future-common-lisp)
(:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf)
#+allegro (:intern #:*acl-warn-save*)
#+cormanlisp (:shadow #:user-homedir-pathname)
......@@ -855,7 +855,7 @@ UNINTERN -- Remove symbols here from PACKAGE."
#:logical-pathname #:translate-logical-pathname
#:make-broadcast-stream #:file-namestring)
#+genera (:shadowing-import-from :scl #:boolean)
#+genera (:export #:boolean #:ensure-directories-exist)
#+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence)
#+mcl (:shadow #:user-homedir-pathname))
(in-package :uiop/common-lisp)
......@@ -935,9 +935,20 @@ UNINTERN -- Remove symbols here from PACKAGE."
#+genera
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (fboundp 'lambda)
(defmacro lambda (&whole form &rest bvl-decls-and-body)
(declare (ignore bvl-decls-and-body)(zwei::indentation 1 1))
`#',(cons 'lisp::lambda (cdr form))))
(unless (fboundp 'ensure-directories-exist)
(defun ensure-directories-exist (path)
(fs:create-directories-recursively (pathname path)))))
(fs:create-directories-recursively (pathname path))))
(unless (fboundp 'read-sequence)
(defun read-sequence (sequence stream &key (start 0) end)
(scl:send stream :string-in nil sequence start end)))
(unless (fboundp 'write-sequence)
(defun write-sequence (sequence stream &key (start 0) end)
(scl:send stream :string-out sequence start end)
sequence)))
#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
(read-from-string
......@@ -1213,7 +1224,7 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; Characters
(with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR.
(defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
(defconstant +non-base-chars-exist-p+ #.(not (subtypep 'character 'base-char)))
#-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow???
(when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
......@@ -1390,7 +1401,7 @@ and EVAL that in a (FUNCTION ...) context."
(etypecase fun
(function fun)
((or boolean keyword character number pathname) (constantly fun))
(hash-table (lambda (x) (gethash x fun)))
(hash-table #'(lambda (x) (gethash x fun)))
(symbol (fdefinition fun))
(cons (if (eq 'lambda (car fun))
(eval fun)
......@@ -1750,10 +1761,13 @@ then returning the non-empty string value of the variable"
(defun operating-system ()
"The operating system of the current host"
(first-feature
'(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
'(:cygwin
(:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
(:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
(:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
(:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
(:solaris :solaris :sunos)
(:bsd :bsd :freebsd :netbsd :openbsd :dragonfly)
:unix
:genera)))
(defun architecture ()
......@@ -2552,7 +2566,7 @@ when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPA
"if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
(let ((sub (when maybe-subpath (pathname maybe-subpath)))
(base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
(base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
(or (and base (subpathp sub base)) sub)))
(defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk)
......@@ -3297,13 +3311,14 @@ in an atomic way if the implementation allows."
directory-pathname (unix:get-unix-error-msg errno))))
#+cormanlisp (win32:delete-directory directory-pathname)
#+ecl (si:rmdir directory-pathname)
#+genera (fs:delete-directory directory-pathname)
#+lispworks (lw:delete-directory directory-pathname)
#+mkcl (mkcl:rmdir directory-pathname)
#+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
`(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
`(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
#+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
#-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks mkcl sbcl scl xcl)
#-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
(error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
(defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
......@@ -3337,7 +3352,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
(error "~S was asked to delete ~S but the directory does not exist"
'delete-filesystem-tree directory-pathname))
(:ignore nil)))
#-(or allegro cmu clozure sbcl scl)
#-(or allegro cmu clozure genera sbcl scl)
((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
;; except on implementations where we can prevent DIRECTORY from following symlinks;
;; instead spawn a standard external program to do the dirty work.
......@@ -3347,7 +3362,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
#+allegro (symbol-call :excl.osi :delete-directory-and-files
directory-pathname :if-does-not-exist if-does-not-exist)
#+clozure (ccl:delete-directory directory-pathname)
#+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type))
#+genera (fs:delete-directory directory-pathname :confirm nil)
#+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
`(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
'(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
......@@ -3995,7 +4010,9 @@ Upon success, the KEEP form is evaluated and the file is is deleted unless it ev
(beforef (gensym "BEFORE"))
(afterf (gensym "AFTER")))
`(flet (,@(when before
`((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@before)))
`((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
,@(when after `((declare (ignorable ,pathname))))
,@before)))
,@(when after
(assert pathnamep)
`((,afterf (,pathname) ,@after))))
......@@ -4120,7 +4137,7 @@ This is designed to abstract away the implementation specific quit forms."
#+(or cmu scl) (unix:unix-exit code)
#+ecl (si:quit code)
#+gcl (system:quit code)
#+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
#+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
#+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
#+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
#+mkcl (mk-ext:quit :exit-code code)
......@@ -4144,8 +4161,8 @@ This is designed to abstract away the implementation specific quit forms."
(declare (ignorable stream count condition))
#+abcl
(loop :for i :from 0
:for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
(safe-format! stream "~&~D: ~A~%" i frame))
:for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
(safe-format! stream "~&~D: ~A~%" i frame))
#+allegro
(let ((*terminal-io* stream)
(*standard-output* stream)
......@@ -4169,20 +4186,20 @@ This is designed to abstract away the implementation specific quit forms."
(debug:backtrace (or count most-positive-fixnum) stream))
#+(or ecl mkcl)
(let* ((top (si:ihs-top))
(repeats (if count (min top count) top))
(backtrace (loop :for ihs :from 0 :below top
(repeats (if count (min top count) top))
(backtrace (loop :for ihs :from 0 :below top
:collect (list (si::ihs-fun ihs)
(si::ihs-env ihs)))))
(loop :for i :from 0 :below repeats
:for frame :in (nreverse backtrace) :do
(safe-format! stream "~&~D: ~S~%" i frame)))
:for frame :in (nreverse backtrace) :do
(safe-format! stream "~&~D: ~S~%" i frame)))
#+gcl
(let ((*debug-io* stream))
(ignore-errors
(with-safe-io-syntax ()
(if condition
(conditions::condition-backtrace condition)
(system::simple-backtrace)))))
(if condition
(conditions::condition-backtrace condition)
(system::simple-backtrace)))))
#+lispworks
(let ((dbg::*debugger-stack*
(dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
......@@ -4196,8 +4213,8 @@ This is designed to abstract away the implementation specific quit forms."
stream)
#+xcl
(loop :for i :from 0 :below (or count most-positive-fixnum)
:for frame :in (extensions:backtrace-as-list) :do
(safe-format! stream "~&~D: ~S~%" i frame)))
:for frame :in (extensions:backtrace-as-list) :do
(safe-format! stream "~&~D: ~S~%" i frame)))
(defun print-backtrace (&rest keys &key stream count condition)
"Print a backtrace"
......@@ -4297,14 +4314,14 @@ if we are not called from a directly executable image."
;; SBCL and Allegro already separate user arguments from implementation arguments.
#-(or sbcl allegro)
(unless (eq *image-dumped-p* :executable)
;; LispWorks command-line processing isn't transparent to the user
;; unless you create a standalone executable; in that case,
;; we rely on cl-launch or some other script to set the arguments for us.
#+lispworks (return *command-line-arguments*)
;; On other implementations, on non-standalone executables,
;; we trust cl-launch or whichever script starts the program
;; to use -- as a delimiter between implementation arguments and user arguments.
#-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
;; LispWorks command-line processing isn't transparent to the user
;; unless you create a standalone executable; in that case,
;; we rely on cl-launch or some other script to set the arguments for us.
#+lispworks (return *command-line-arguments*)
;; On other implementations, on non-standalone executables,
;; we trust cl-launch or whichever script starts the program
;; to use -- as a delimiter between implementation arguments and user arguments.
#-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
(rest arguments)))
(defun argv0 ()
......@@ -4339,7 +4356,7 @@ immediately to the surrounding restore process if allowed to continue.
Then, comes the restore process itself:
First, call each function in the RESTORE-HOOK,
in the order they were registered with REGISTER-RESTORE-HOOK.
in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
Second, evaluate the prelude, which is often Lisp text that is read,
as per EVAL-INPUT.
Third, call the ENTRY-POINT function, if any is specified, with no argument.
......@@ -4384,7 +4401,7 @@ of the function will be returned rather than interpreted as a boolean designatin
(dump-hook *image-dump-hook*)
#+clozure prepend-symbols #+clozure (purify t)
#+sbcl compression
#+(and sbcl windows) application-type)
#+(and sbcl os-windows) application-type)
"Dump an image of the current Lisp environment at pathname FILENAME, with various options.
First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
......@@ -4458,7 +4475,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
(when compression (list :compression compression))
;;--- only save runtime-options for standalone executables
(when executable (list :toplevel #'restore-image :save-runtime-options t))
#+(and sbcl windows) ;; passing :application-type :gui will disable the console window.
#+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window.
;; the default is :console - only works with SBCL 1.1.15 or later.
(when application-type (list :application-type application-type)))))
#-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
......@@ -5295,7 +5312,7 @@ It returns a process-info plist with possible keys:
#+(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
(%wait-process-result
(apply '%run-program (%normalize-system-command command) :wait t keys))
#+(or abcl cormanlisp clisp ecl gcl (and lispworks os-windows) mkcl xcl)
#+(or abcl cormanlisp clisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
(let ((%command (%redirected-system-command command input output error-output directory)))
#+(and lispworks os-windows)
(system:call-system %command :current-directory directory :wait t)
......@@ -5312,6 +5329,8 @@ It returns a process-info plist with possible keys:
(*error-output* *stderr*))
(ext:system %command))
#+gcl (system:system %command)
#+genera (error "~S not supported on Genera, cannot run ~S"
'%system %command)
#+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
#+mkcl (mkcl:system %command)
#+xcl (system:%run-shell-command %command))))
......@@ -6342,7 +6361,7 @@ this function tries to locate the Windows FOLDER for one of
"Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
be applied to the results to yield a configuration form. Current
values of TAG include :source-registry and :output-translations."
(let ((files (sort (ignore-errors
(let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
(remove-if
'hidden-pathname-p
(directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
......@@ -6639,7 +6658,7 @@ previously-loaded version of ASDF."
;; "3.4.5.67" would be a development version in the official branch, on top of 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
(asdf-version "3.1.2.2")
(asdf-version "3.1.2.9")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
......@@ -6651,26 +6670,26 @@ previously-loaded version of ASDF."
(when-upgrading ()
(let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
;; NB: it's too late to do anything about functions in UIOP!
;; If you introduce some critically incompatibility there, you must change name.
;; NB: it's too late to do anything about functions in UIOP!
;; If you introduce some critically incompatibility there, you must change name.
'(#:component-relative-pathname #:component-parent-pathname ;; component
#:source-file-type
#:find-system #:system-source-file #:system-relative-pathname ;; system
#:find-component ;; find-component
#:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
#:component-depends-on #:operation-done-p #:component-depends-on
#:traverse ;; backward-interface
#:find-component ;; find-component
#:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
#:component-depends-on #:operation-done-p #:component-depends-on
#:traverse ;; backward-interface
#:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan
#:operate ;; operate
#:parse-component-form ;; defsystem
#:apply-output-translations ;; output-translations
#:process-output-translations-directive
#:inherit-source-registry #:process-source-registry ;; source-registry
#:process-source-registry-directive
#:trivial-system-p)) ;; bundle
(redefined-classes
#:operate ;; operate
#:parse-component-form ;; defsystem
#:apply-output-translations ;; output-translations
#:process-output-translations-directive
#:inherit-source-registry #:process-source-registry ;; source-registry
#:process-source-registry-directive
#:trivial-system-p)) ;; bundle
(redefined-classes
;; redefining the classes causes interim circularities
;; with the old ASDF during upgrade, and many implementations bork
;; with the old ASDF during upgrade, and many implementations bork
'((#:compile-concatenated-source-op (#:operation) ()))))
(loop :for name :in redefined-functions
:for sym = (find-symbol* name :asdf nil) :do
......@@ -6678,12 +6697,12 @@ previously-loaded version of ASDF."
;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh.
#-clisp (fmakunbound sym)))
(labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf))
(find-symbol* s p nil)))
(asyms (l) (mapcar #'asym l)))
(find-symbol* s p nil)))
(asyms (l) (mapcar #'asym l)))
(loop* :for (name superclasses slots) :in redefined-classes
:for sym = (find-symbol* name :asdf nil)
:when (and sym (find-class sym))
:do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))))))
:for sym = (find-symbol* name :asdf nil)
:when (and sym (find-class sym))
:do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))))))
;;; Self-upgrade functions
......@@ -7144,8 +7163,9 @@ in which the system specification (.asd file) is located."
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
#:do-asdf-cache #:normalize-namestring
#:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
#:do-asdf-cache #:normalize-namestring
#:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
#:clear-configuration-and-retry #:retry))
(in-package :asdf/cache)
;;; This stamp cache is useful for:
......@@ -7181,8 +7201,17 @@ in which the system specification (.asd file) is located."
(let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
(if (and *asdf-cache* (not override))
(funcall fun)
(let ((*asdf-cache* (make-hash-table :test 'equal)))
(funcall fun)))))
(loop
(restart-case
(let ((*asdf-cache* (make-hash-table :test 'equal)))
(return (funcall fun)))
(retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
(clear-configuration-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
(clear-configuration)))))))
(defmacro with-asdf-cache ((&key key override) &body body)
`(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
......@@ -7309,8 +7338,8 @@ of which is a system object.")
(defun clear-defined-systems ()
;; Invalidate all systems but ASDF itself, if registered.
(loop :for name :being :the :hash-keys :of *defined-systems*
:unless (equal name "asdf")
:do (clear-defined-system name)))
:unless (equal name "asdf")
:do (clear-defined-system name)))
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
......@@ -7563,82 +7592,73 @@ but not loaded in memory"
Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
FOUNDP is true when a system was found,
either a new unregistered one or a previously registered one.
FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
PATHNAME when not null is a path from where to load the system,
FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed.
PATHNAME when not null is a path from which to load the system,
either associated with FOUND-SYSTEM, or with the PREVIOUS system.
PREVIOUS when not null is a previously loaded SYSTEM object of same name.
PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
(with-asdf-cache (:key `(locate-system ,name))
(let* ((name (coerce-name name))
(in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
(previous (cdr in-memory))
(previous (and (typep previous 'system) previous))
(previous-time (car in-memory))
(found (search-for-system-definition name))
(found-system (and (typep found 'system) found))
(pathname (ensure-pathname
(or (and (typep found '(or pathname string)) (pathname found))
(and found-system (system-source-file found-system))
(and previous (system-source-file previous)))
:want-absolute t :resolve-symlinks *resolve-symlinks*))
(foundp (and (or found-system pathname previous) t)))
(check-type found (or null pathname system))
(unless (check-not-old-asdf-system name pathname)
(cond
(previous (setf found nil pathname nil))
(t
(setf found (sysdef-preloaded-system-search "asdf"))
(assert (typep found 'system))
(setf found-system found pathname nil))))
(values foundp found-system pathname previous previous-time))))
(let* ((name (coerce-name name))
(in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
(previous (cdr in-memory))
(previous (and (typep previous 'system) previous))
(previous-time (car in-memory))
(found (search-for-system-definition name))
(found-system (and (typep found 'system) found))
(pathname (ensure-pathname
(or (and (typep found '(or pathname string)) (pathname found))
(and found-system (system-source-file found-system))
(and previous (system-source-file previous)))
:want-absolute t :resolve-symlinks *resolve-symlinks*))
(foundp (and (or found-system pathname previous) t)))
(check-type found (or null pathname system))
(unless (check-not-old-asdf-system name pathname)
(cond
(previous (setf found nil pathname nil))
(t
(setf found (sysdef-preloaded-system-search "asdf"))
(assert (typep found 'system))
(setf found-system found pathname nil))))
(values foundp found-system pathname previous previous-time)))
(defmethod find-system ((name string) &optional (error-p t))
(with-asdf-cache (:key `(find-system ,name))
(let ((primary-name (primary-system-name name)))
(unless (equal name primary-name)
(find-system primary-name nil)))
(loop
(restart-case
(multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name)
(when (and found-system (eq found-system previous)
(or (first (gethash `(find-system ,name) *asdf-cache*))
(and *immutable-systems* (gethash name *immutable-systems*))))
(return found-system))
(assert (eq foundp (and (or found-system pathname previous) t)))
(let ((previous-pathname (and previous (system-source-file previous)))
(system (or previous found-system)))
(when (and found-system (not previous))
(register-system found-system))
(when (and system pathname)
(setf (system-source-file system) pathname))
(when (and pathname
(let ((stamp (get-file-stamp pathname)))
(and stamp
(not (and previous
(or (pathname-equal pathname previous-pathname)
(and pathname previous-pathname
(pathname-equal
(physicalize-pathname pathname)
(physicalize-pathname previous-pathname))))
(stamp<= stamp previous-time))))))
;; only load when it's a pathname that is different or has newer content, and not an old asdf
(load-asd pathname :name name)))
(let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
(return
(cond
(in-memory
(when pathname
(setf (car in-memory) (get-file-stamp pathname)))
(cdr in-memory))
(error-p
(error 'missing-component :requires name))))))
(reinitialize-source-registry-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))