[Armedbear-cvs] r14714 - in trunk/abcl: doc/asdf src/org/armedbear/lisp
mevenson at common-lisp.net
mevenson at common-lisp.net
Fri Jul 18 17:03:27 UTC 2014
Author: mevenson
Date: Fri Jul 18 17:03:20 2014
New Revision: 14714
Log:
ASDF 3.1.2.9
changeset: 2488:0a1ded36af37
bookmark: master
tag: default/master
tag: tip
user: Francois-Rene Rideau <tunes at google.com>
summary: Tweak the debian changelog.
Modified:
trunk/abcl/doc/asdf/asdf.texinfo
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
Modified: trunk/abcl/doc/asdf/asdf.texinfo
==============================================================================
--- trunk/abcl/doc/asdf/asdf.texinfo Sat May 17 10:51:33 2014 (r14713)
+++ trunk/abcl/doc/asdf/asdf.texinfo Fri Jul 18 17:03:20 2014 (r14714)
@@ -909,6 +909,7 @@
regarding source-registry or output-translations.
@end defun
+ at 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 @@
of the system in memory
@end itemize
+ at 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
+ at 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
- at 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,
+ at pxref{The package-inferred-system extension}.
+
+Because of the way these search functions are defined,
+you should put the definition for a system
+ at 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.
+
+ at c FIXME: Move this discussion to the system definition grammar, or somewhere else.
+ at anchor{System names}
+ at cindex System names
+ at cindex Primary system name
+ at 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}. at 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.
+
+ at end defun
+
+ at 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}.
+
+ at end defun
+
+ at 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.
+ at c (This does not include the loading of the system definition,
+ at c which is done by @code{find-system},
+ at c or the loading of the system itself, which is done by @code{load-system};
+ at c however, for systems the definition of which has already been loaded,
+ at c @code{locate-system} may return an object of class @code{system}.)
+Returns five values: @var{foundp}, @var{found-system}, @var{pathname},
+ at var{previous}, and @var{previous-time}.
+ at 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.
+ at c This system may be registered (by @code{register-system}) or may not, if
+ at c it's preloaded code. Fare writes:
+ at c In the case of preloaded code, as for "asdf", "uiop", etc.,
+ at c themselves, the system objects are not registered until after they are
+ at c initially located by sysdef-preloaded-system-search as a fallback when
+ at c no source code was found.
+The system definition will @emph{not} be
+loaded if it hasn't been loaded already.
+ at 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}
+ at code{system} object of the same name (note that the system
+ at emph{definition} is previously-loaded: the system itself may or may not be).
+ at 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
+ at 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:
+ at enumerate
+ at item
+ at var{foundp} will be @code{T},
+ at item
+ at var{found-system} will be @code{NIL},
+ at item
+ at var{pathname} will be @code{#p"/current/path/to/foo.asd"},
+ at item
+ at var{previous} will be an object of type @code{SYSTEM} with
+ at code{system-source-file} slot value of
+ at code{#p"/previous/path/to/foo.asd"}
+ at item
+ at var{previous-time} will be the timestamp of
+ at code{#p"/previous/path/to/foo.asd"} at the time it was loaded.
+ at end enumerate
@end defun
@defun find-component base path
@@ -2725,8 +2851,8 @@
New component types are defined by subclassing one of the existing
component classes and specializing methods on the new component class.
- at emph{FIXME: this should perhaps be explained more throughly,
-not only by example ...}
+ at c FIXME: this should perhaps be explained more throughly,
+ at c not only by example ...
As an example, suppose we have some implementation-dependent
functionality that we want to isolate
@@ -2769,10 +2895,10 @@
@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 @@
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 @@
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 @@
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 @@
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 @@
@printindex vr
@bye
+
+ at c LocalWords: clbuild tarballs defsystem Quicklisp initarg uiop fasl
+ at c LocalWords: namestring initargs fasls
Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sat May 17 10:51:33 2014 (r14713)
+++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Fri Jul 18 17:03:20 2014 (r14714)
@@ -1,5 +1,5 @@
;;; -*- 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 at common-lisp.net>.
@@ -402,7 +402,7 @@
(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 @@
(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 @@
#: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 @@
#+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 @@
;;; 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 @@
(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 @@
(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 @@
"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 @@
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 @@
(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 @@
#+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 @@
(beforef (gensym "BEFORE"))
(afterf (gensym "AFTER")))
`(flet (,@(when before
- `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) , at before)))
+ `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
+ ,@(when after `((declare (ignorable ,pathname))))
+ , at before)))
,@(when after
(assert pathnamep)
`((,afterf (,pathname) , at after))))
@@ -4120,7 +4137,7 @@
#+(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 @@
(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 @@
(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 @@
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 @@
;; 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 @@
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 @@
(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 @@
(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 @@
#+(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 @@
(*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 @@
"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 @@
;; "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 @@
(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 @@
;; 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 @@
(: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 @@
(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 () , at body) :override ,override :key ,key))
@@ -7309,8 +7338,8 @@
(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 @@
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))
- (unset-asdf-cache-entry `(locate-system ,name))
- (initialize-source-registry)))))))
-
+ (or (and *immutable-systems* (gethash name *immutable-systems*)
+ (cdr (system-registered-p name)))
+ (multiple-value-bind (foundp found-system pathname previous previous-time)
+ (locate-system name)
+ (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
+ (cond
+ (in-memory
+ (when pathname
+ (setf (car in-memory) (get-file-stamp pathname)))
+ (cdr in-memory))
+ (error-p
+ (error 'missing-component :requires name))
+ (t ;; not found: don't keep negative cache, see lp#1335323
+ (unset-asdf-cache-entry `(locate-system ,name))
+ (return-from find-system nil)))))))))
;;;; -------------------------------------------------------------------------
;;;; Finding components
@@ -7748,10 +7768,10 @@
(and (typep c 'missing-dependency)
(eq (missing-required-by c) component)
(equal (missing-requires c) name))))
- (unless (component-parent component)
- (let ((name (coerce-name name)))
- (unset-asdf-cache-entry `(find-system ,name))
- (unset-asdf-cache-entry `(locate-system ,name))))))))
+ (unless (component-parent component)
+ (let ((name (coerce-name name)))
+ (unset-asdf-cache-entry `(find-system ,name))
+ (unset-asdf-cache-entry `(locate-system ,name))))))))
(defun resolve-dependency-spec (component dep-spec)
@@ -9049,7 +9069,8 @@
component-directed strategy for how to load or compile systems.")
(defmethod component-depends-on ((o prepare-op) (s system))
- `((,*load-system-operation* ,@(component-sideway-dependencies s))))
+ (loop :for (o . cs) :in (call-next-method)
+ :collect (cons (if (eq o 'load-op) *load-system-operation* o) cs)))
(defclass build-op (non-propagating-operation) ()
(:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation,
@@ -9060,7 +9081,8 @@
if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION*
that will load the system in the current image, and its typically LOAD-OP."))
(defmethod component-depends-on ((o build-op) (c component))
- `((,(or (component-build-operation c) *load-system-operation*) ,c)))
+ `((,(or (component-build-operation c) *load-system-operation*) ,c)
+ ,@(call-next-method)))
(defun make (system &rest keys)
"The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO).
@@ -11223,11 +11245,13 @@
#:package-inferred-system-missing-package-error
#:operation-definition-warning #:operation-definition-error
- #:try-recompiling
+ #:try-recompiling ; restarts
#:retry
- #:accept ; restarts
+ #:accept
#:coerce-entry-to-directory
#:remove-entry-from-registry
+ #:clear-configuration-and-retry
+
#:*encoding-detection-hook*
#:*encoding-external-format-hook*
@@ -11263,7 +11287,8 @@
#:user-source-registry
#:system-source-registry
#:user-source-registry-directory
- #:system-source-registry-directory))
+ #:system-source-registry-directory
+ ))
;;;; ---------------------------------------------------------------------------
;;;; ASDF-USER, where the action happens.
More information about the armedbear-cvs
mailing list