Merge branch 'master' of ssh://git.informatimago.com/srv/git/public/lisp

Pascal J. Bourguignon [2015-11-01 09:29]
Merge branch 'master' of ssh://git.informatimago.com/srv/git/public/lisp
Filename
clext/GPL
clext/association.lisp
clext/logical-pathname.lisp
clext/pipe.lisp
clext/weak-oid.tst
common-lisp/cesarum/brelation.lisp
common-lisp/cesarum/bset.lisp
common-lisp/cesarum/ecma048.lisp
common-lisp/cesarum/graph.lisp
common-lisp/cesarum/set.lisp
common-lisp/html-base/ml-sexp.lisp
common-lisp/html-parser/parse-html.lisp
common-lisp/picture/picture.lisp
future/vfs/filenames.lisp
future/vfs/files.lisp
future/vfs/general.lisp
future/vfs/streams.lisp
future/vfs/vfs-file-stream.lisp
future/vfs/virtual-fs.lisp
languages/c11/c11-parser.lisp
languages/lua/lua-parser.lisp
lispdoc/gentext.lisp
rdp/packages.lisp
rdp/rdp-basic-gen.lisp
rdp/rdp.lisp
tools/asdf.lisp
tools/com.informatimago.tools.try-systems.asd
tools/try-systems.lisp
diff --git a/clext/GPL b/clext/GPL
deleted file mode 100644
index d60c31a..0000000
--- a/clext/GPL
+++ /dev/null
@@ -1,340 +0,0 @@
-		    GNU GENERAL PUBLIC LICENSE
-		       Version 2, June 1991
-
- Copyright (C) 1989, 1991 Free Software Foundation, Inc.
-     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-			    Preamble
-
-  The licenses for most software are designed to take away your
-freedom to share and change it.  By contrast, the GNU General Public
-License is intended to guarantee your freedom to share and change free
-software--to make sure the software is free for all its users.  This
-General Public License applies to most of the Free Software
-Foundation's software and to any other program whose authors commit to
-using it.  (Some other Free Software Foundation software is covered by
-the GNU Library General Public License instead.)  You can apply it to
-your programs, too.
-
-  When we speak of free software, we are referring to freedom, not
-price.  Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-this service if you wish), that you receive source code or can get it
-if you want it, that you can change the software or use pieces of it
-in new free programs; and that you know you can do these things.
-
-  To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the rights.
-These restrictions translate to certain responsibilities for you if you
-distribute copies of the software, or if you modify it.
-
-  For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must give the recipients all the rights that
-you have.  You must make sure that they, too, receive or can get the
-source code.  And you must show them these terms so they know their
-rights.
-
-  We protect your rights with two steps: (1) copyright the software, and
-(2) offer you this license which gives you legal permission to copy,
-distribute and/or modify the software.
-
-  Also, for each author's protection and ours, we want to make certain
-that everyone understands that there is no warranty for this free
-software.  If the software is modified by someone else and passed on, we
-want its recipients to know that what they have is not the original, so
-that any problems introduced by others will not reflect on the original
-authors' reputations.
-
-  Finally, any free program is threatened constantly by software
-patents.  We wish to avoid the danger that redistributors of a free
-program will individually obtain patent licenses, in effect making the
-program proprietary.  To prevent this, we have made it clear that any
-patent must be licensed for everyone's free use or not licensed at all.
-
-  The precise terms and conditions for copying, distribution and
-modification follow.
-
-		    GNU GENERAL PUBLIC LICENSE
-   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
-  0. This License applies to any program or other work which contains
-a notice placed by the copyright holder saying it may be distributed
-under the terms of this General Public License.  The "Program", below,
-refers to any such program or work, and a "work based on the Program"
-means either the Program or any derivative work under copyright law:
-that is to say, a work containing the Program or a portion of it,
-either verbatim or with modifications and/or translated into another
-language.  (Hereinafter, translation is included without limitation in
-the term "modification".)  Each licensee is addressed as "you".
-
-Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope.  The act of
-running the Program is not restricted, and the output from the Program
-is covered only if its contents constitute a work based on the
-Program (independent of having been made by running the Program).
-Whether that is true depends on what the Program does.
-
-  1. You may copy and distribute verbatim copies of the Program's
-source code as you receive it, in any medium, provided that you
-conspicuously and appropriately publish on each copy an appropriate
-copyright notice and disclaimer of warranty; keep intact all the
-notices that refer to this License and to the absence of any warranty;
-and give any other recipients of the Program a copy of this License
-along with the Program.
-
-You may charge a fee for the physical act of transferring a copy, and
-you may at your option offer warranty protection in exchange for a fee.
-
-  2. You may modify your copy or copies of the Program or any portion
-of it, thus forming a work based on the Program, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
-
-    a) You must cause the modified files to carry prominent notices
-    stating that you changed the files and the date of any change.
-
-    b) You must cause any work that you distribute or publish, that in
-    whole or in part contains or is derived from the Program or any
-    part thereof, to be licensed as a whole at no charge to all third
-    parties under the terms of this License.
-
-    c) If the modified program normally reads commands interactively
-    when run, you must cause it, when started running for such
-    interactive use in the most ordinary way, to print or display an
-    announcement including an appropriate copyright notice and a
-    notice that there is no warranty (or else, saying that you provide
-    a warranty) and that users may redistribute the program under
-    these conditions, and telling the user how to view a copy of this
-    License.  (Exception: if the Program itself is interactive but
-    does not normally print such an announcement, your work based on
-    the Program is not required to print an announcement.)
-
-These requirements apply to the modified work as a whole.  If
-identifiable sections of that work are not derived from the Program,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works.  But when you
-distribute the same sections as part of a whole which is a work based
-on the Program, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Program.
-
-In addition, mere aggregation of another work not based on the Program
-with the Program (or with a work based on the Program) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
-  3. You may copy and distribute the Program (or a work based on it,
-under Section 2) in object code or executable form under the terms of
-Sections 1 and 2 above provided that you also do one of the following:
-
-    a) Accompany it with the complete corresponding machine-readable
-    source code, which must be distributed under the terms of Sections
-    1 and 2 above on a medium customarily used for software interchange; or,
-
-    b) Accompany it with a written offer, valid for at least three
-    years, to give any third party, for a charge no more than your
-    cost of physically performing source distribution, a complete
-    machine-readable copy of the corresponding source code, to be
-    distributed under the terms of Sections 1 and 2 above on a medium
-    customarily used for software interchange; or,
-
-    c) Accompany it with the information you received as to the offer
-    to distribute corresponding source code.  (This alternative is
-    allowed only for noncommercial distribution and only if you
-    received the program in object code or executable form with such
-    an offer, in accord with Subsection b above.)
-
-The source code for a work means the preferred form of the work for
-making modifications to it.  For an executable work, complete source
-code means all the source code for all modules it contains, plus any
-associated interface definition files, plus the scripts used to
-control compilation and installation of the executable.  However, as a
-special exception, the source code distributed need not include
-anything that is normally distributed (in either source or binary
-form) with the major components (compiler, kernel, and so on) of the
-operating system on which the executable runs, unless that component
-itself accompanies the executable.
-
-If distribution of executable or object code is made by offering
-access to copy from a designated place, then offering equivalent
-access to copy the source code from the same place counts as
-distribution of the source code, even though third parties are not
-compelled to copy the source along with the object code.
-
-  4. You may not copy, modify, sublicense, or distribute the Program
-except as expressly provided under this License.  Any attempt
-otherwise to copy, modify, sublicense or distribute the Program is
-void, and will automatically terminate your rights under this License.
-However, parties who have received copies, or rights, from you under
-this License will not have their licenses terminated so long as such
-parties remain in full compliance.
-
-  5. You are not required to accept this License, since you have not
-signed it.  However, nothing else grants you permission to modify or
-distribute the Program or its derivative works.  These actions are
-prohibited by law if you do not accept this License.  Therefore, by
-modifying or distributing the Program (or any work based on the
-Program), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Program or works based on it.
-
-  6. Each time you redistribute the Program (or any work based on the
-Program), the recipient automatically receives a license from the
-original licensor to copy, distribute or modify the Program subject to
-these terms and conditions.  You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties to
-this License.
-
-  7. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License.  If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Program at all.  For example, if a patent
-license would not permit royalty-free redistribution of the Program by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Program.
-
-If any portion of this section is held invalid or unenforceable under
-any particular circumstance, the balance of the section is intended to
-apply and the section as a whole is intended to apply in other
-circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system, which is
-implemented by public license practices.  Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-
-  8. If the distribution and/or use of the Program is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Program under this License
-may add an explicit geographical distribution limitation excluding
-those countries, so that distribution is permitted only in or among
-countries not thus excluded.  In such case, this License incorporates
-the limitation as if written in the body of this License.
-
-  9. The Free Software Foundation may publish revised and/or new versions
-of the General Public License from time to time.  Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
-Each version is given a distinguishing version number.  If the Program
-specifies a version number of this License which applies to it and "any
-later version", you have the option of following the terms and conditions
-either of that version or of any later version published by the Free
-Software Foundation.  If the Program does not specify a version number of
-this License, you may choose any version ever published by the Free Software
-Foundation.
-
-  10. If you wish to incorporate parts of the Program into other free
-programs whose distribution conditions are different, write to the author
-to ask for permission.  For software which is copyrighted by the Free
-Software Foundation, write to the Free Software Foundation; we sometimes
-make exceptions for this.  Our decision will be guided by the two goals
-of preserving the free status of all derivatives of our free software and
-of promoting the sharing and reuse of software generally.
-
-			    NO WARRANTY
-
-  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
-FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
-OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
-PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
-OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
-TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
-PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
-REPAIR OR CORRECTION.
-
-  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
-REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
-INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
-OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
-TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
-YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
-PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGES.
-
-		     END OF TERMS AND CONDITIONS
-
-	    How to Apply These Terms to Your New Programs
-
-  If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
-  To do so, attach the following notices to the program.  It is safest
-to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
-    <one line to give the program's name and a brief idea of what it does.>
-    Copyright (C) <year>  <name of author>
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-
-
-Also add information on how to contact you by electronic and paper mail.
-
-If the program is interactive, make it output a short notice like this
-when it starts in an interactive mode:
-
-    Gnomovision version 69, Copyright (C) year  name of author
-    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
-    This is free software, and you are welcome to redistribute it
-    under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License.  Of course, the commands you use may
-be called something other than `show w' and `show c'; they could even be
-mouse-clicks or menu items--whatever suits your program.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the program, if
-necessary.  Here is a sample; alter the names:
-
-  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
-  `Gnomovision' (which makes passes at compilers) written by James Hacker.
-
-  <signature of Ty Coon>, 1 April 1989
-  Ty Coon, President of Vice
-
-This General Public License does not permit incorporating your program into
-proprietary programs.  If your program is a subroutine library, you may
-consider it more useful to permit linking proprietary applications with the
-library.  If this is what you want to do, use the GNU Library General
-Public License instead of this License.
diff --git a/clext/association.lisp b/clext/association.lisp
index 6f7d2fe..4b5f8fb 100644
--- a/clext/association.lisp
+++ b/clext/association.lisp
@@ -11,28 +11,26 @@
 ;;;;AUTHORS
 ;;;;    <PJB> Pascal J. Bourguignon <pjb@anevia.com>
 ;;;;MODIFICATIONS
+;;;;    2015-11-01 <PJB> Changed license from GPL3 to AGPL3.
 ;;;;    2009-05-20 <PJB> Adapted these macros for the objecteering metamodel.
 ;;;;    2009-01-09 <PJB> Added this comment.
 ;;;;BUGS
 ;;;;LEGAL
-;;;;    GPL
+;;;;    AGPL3
 ;;;;
-;;;;    Copyright
 ;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU General Public License
-;;;;    as published by the Free Software Foundation; either version
-;;;;    2 of the License, or (at your option) any later version.
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
 ;;;;
-;;;;    This program is distributed in the hope that it will be
-;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
-;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
 ;;;;
-;;;;    You should have received a copy of the GNU General Public
-;;;;    License along with this program; if not, write to the Free
-;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;;    Boston, MA 02111-1307 USA
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 ;;;;*************************************************************************

 (defpackage "COM.INFORMATIMAGO.CLEXT.ASSOCIATION"
diff --git a/clext/logical-pathname.lisp b/clext/logical-pathname.lisp
new file mode 100644
index 0000000..07b0b01
--- /dev/null
+++ b/clext/logical-pathname.lisp
@@ -0,0 +1,133 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               logical-pathname.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Parses and validates a logical pathname namestring.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2015-11-01 <PJB> Extracted from COM.INFORMATIMAGO.COMMON-LISP.VIRTUAL-FILE-SYSTEM.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2015 - 2015
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+(defpackage "COM.INFORMATIMAGO.CLEXT.LOGICAL-PATHNAME"
+  (:use "COMMON-LISP"
+        "CL-PPCRE"
+        "SPLIT-SEQUENCE")
+  (:export "PARSE-LOGICAL-PATHNAME"))
+(in-package "COM.INFORMATIMAGO.CLEXT.LOGICAL-PATHNAME")
+
+
+(defun re-compile (re &key extended)
+  (cl-ppcre:create-scanner re :extended-mode extended))
+
+(defun re-exec (re string &key (start 0) (end nil))
+  (multiple-value-bind (mstart mend starts ends)
+      (cl-ppcre:scan re string
+                     :start start
+                     :end (or end (length string)))
+    (and mstart mend
+         (values-list (cons (list mstart mend)
+                            (map 'list (lambda (s e)
+                                         (if (or s e)
+                                             (list s e)
+                                             nil))
+                              starts ends))))))
+
+
+(defun re-match-string (string match)
+  (subseq string (first match) (second match)))
+
+(defun re-match (regexp string)
+  (re-exec (re-compile regexp :extended t) string))
+
+
+
+(defparameter *logical-pathname-regexp*
+  (let ((host "(([-A-Z0-9]+):)?")
+        (dire "(;)?(([-*A-Z0-9]+;|\\*\\*;)*)")
+        (name "([-*A-Z0-9]+)?")
+        (type "(.([-*A-Z0-9]+)(.([0-9]+|newest|NEWEST|\\*))?)?"))
+    #-(and)
+    (concatenate 'string "^" host dire name type "$")
+    (re-compile (concatenate 'string "^" host dire name type "$")
+                :extended t)))
+
+
+(defun parse-logical-pathname (string &key (start 0) (end nil))
+  "
+RETURN: a list containing the pathname components: (host directory name type version)
+"
+  ;; TODO: implement junk-allowed
+  ;; TODO: return new position.
+  (flet ((wild (item part wild-inferiors-p)
+           (cond ((string= "*"  item) :wild)
+                 ((and wild-inferiors-p (string= "**" item)) :wild-inferiors)
+                 ((search  "**" item)
+                  (error "Invalid ~A part: ~S; ~
+                                \"**\" inside a wildcard-world is forbidden."
+                         part item))
+                 ((position #\* item) (list :wild-word item))
+                 (t item))))
+    (multiple-value-bind (all
+                          dummy0 host
+                          relative directories dummy1
+                          name
+                          dummy2 type dummy3 version)
+        (re-exec *logical-pathname-regexp* string :start start :end end)
+      (declare (ignore dummy0 dummy1 dummy2 dummy3))
+      (if all
+          (list (and host        (re-match-string string host))
+                (if relative :relative :absolute)
+                (and directories
+                     (mapcar
+                      (lambda (item) (wild item "directory" t))
+                      (butlast (split-sequence #\; (re-match-string
+                                                    string directories)))))
+                (and name
+                     (let ((item (re-match-string string name)))
+                       (wild item "name" nil)))
+                (and type
+                     (let ((item (re-match-string string type)))
+                       (wild item "type" nil)))
+                (and version
+                     (let ((version (re-match-string string version)))
+                       (cond
+                         ((string= "*" version) :wild)
+                         ((string-equal "NEWEST" version) :newest)
+                         (t (parse-integer version :junk-allowed nil))))))
+          (error "Syntax error parsing logical pathname ~S"
+                 (subseq string start end))))))
+
+#-(and)
+(mapc
+ (lambda (path) (print (ignore-errors (parse-logical-pathname path))))
+ '("SYS:KERNEL;PATH;LOGICAL.LISP"
+   "SYS:;KERNEL;PATH;LOGICAL.LISP"
+   "SYS:;KERNEL;**;LOGICAL.LISP"
+   "SYS:;KERNEL;**;LO*L.LISP"
+   "SYS:kernel;path/logical.lisp"))
+
+
+;;;; THE END ;;;;
diff --git a/clext/pipe.lisp b/clext/pipe.lisp
index 315286b..baacbef 100644
--- a/clext/pipe.lisp
+++ b/clext/pipe.lisp
@@ -731,6 +731,7 @@ when it's the case, end-of-file is detected upon reading on an empty pipe.")
           (slot-value (pipe-output-stream pipe) 'open) t))
   (gate-signal (not-empty pipe)))

+(defgeneric close-pipe (pipe))
 (defmethod close-pipe ((pipe generic-pipe))
   (with-lock-held ((lock pipe))
     (setf (slot-value (pipe-output-stream pipe) 'open) nil))
diff --git a/clext/weak-oid.tst b/clext/weak-oid.tst
index 98e3489..0ca6c75 100644
--- a/clext/weak-oid.tst
+++ b/clext/weak-oid.tst
@@ -11,27 +11,26 @@
 ;;;;AUTHORS
 ;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
 ;;;;MODIFICATIONS
+;;;;    2015-11-01 <PJB> Changed license from GPL3 to AGPL3.
 ;;;;    2006-06-16 <PJB> Created.
 ;;;;BUGS
 ;;;;LEGAL
-;;;;    GPL
+;;;;    AGPL3
 ;;;;
 ;;;;    Copyright Pascal Bourguignon 2006 - 2006
 ;;;;
-;;;;    This program is free software; you can redistribute it and/or
-;;;;    modify it under the terms of the GNU General Public License
-;;;;    as published by the Free Software Foundation; either version
-;;;;    2 of the License, or (at your option) any later version.
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
 ;;;;
-;;;;    This program is distributed in the hope that it will be
-;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
-;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;;;;    PURPOSE.  See the GNU General Public License for more details.
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
 ;;;;
-;;;;    You should have received a copy of the GNU General Public
-;;;;    License along with this program; if not, write to the Free
-;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;;    Boston, MA 02111-1307 USA
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 ;;;;**************************************************************************

 (progn
diff --git a/common-lisp/cesarum/brelation.lisp b/common-lisp/cesarum/brelation.lisp
index 9c33299..c52cf3e 100644
--- a/common-lisp/cesarum/brelation.lisp
+++ b/common-lisp/cesarum/brelation.lisp
@@ -44,22 +44,21 @@
 ;;;;    You should have received a copy of the GNU Affero General Public License
 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
 ;;;;****************************************************************************
-
-(in-package "COMMON-LISP-USER")
-(declaim (declaration also-use-packages))
-(declaim (also-use-packages "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.BSET"))
 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.BRELATION"
-  (:use "COMMON-LISP")
+  (:use "COMMON-LISP"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.BSET")
+  (:shadowing-import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.BSET"
+                          "COMPLEMENT" "INTERSECTION" "UNION" "SUBSETP")
+  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
+                "VECTOR-INIT" "FOR" "UNTIL")
   (:export "PROJECT-2" "PROJECT-1" "WRITE-BRELATION" "READ-BRELATION"
            "FOR-ALL-DO" "EXISTS-1" "EXISTS" "FOR-ALL" "EXTRACT" "SELECT" "CARDINAL"
-           "IS-EMPTY" "IS-NOT-EQUAL" "IS-EQUAL" "IS-STRICT-SUBSET" "IS-SUBSET"
+           "EMPTYP" "IS-NOT-EQUAL" "IS-EQUAL" "IS-STRICT-SUBSET" "IS-SUBSET"
            "COMPLEMENT" "SYM-DIFF" "INTERSECTION" "DIFFERENCE" "UNION" "ASSIGN"
            "ASSIGN-ELEMENT" "ASSIGN-EMPTY" "CLOSURE" "GET-CYCLICS" "IS-CYCLIC"
            "HAS-REFLEXIVE" "IS-EQUIVALENCE" "IS-TRANSITIVE" "IS-SYMMETRIC"
            "IS-REFLEXIVE" "IS-TRANSITIVE-1" "IS-REFLEXIVE-1" "IS-RELATED" "IS-ELEMENT"
            "EXCLUDE" "INCLUDE" "MAKE-BRELATION" "BRELATION")
-  (:shadow "COMPLEMENT" "INTERSECTION" "UNION")
-  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY" "VECTOR-INIT" "FOR")
   (:documentation
    "

@@ -75,7 +74,7 @@ License:

     AGPL3

-    Copyright Pascal J. Bourguignon 2004 - 2012
+    Copyright Pascal J. Bourguignon 2004 - 2015

     This program is free software: you can redistribute it and/or modify
     it under the terms of the GNU Affero General Public License as published by
@@ -94,15 +93,13 @@ License:
 "))
 (in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.BRELATION")

-
-
 (defstruct (brelation (:constructor %make-brelation))
   "The Binary Relation Class."
-  (adjsets (make-array '(0) :element-type 'com.informatimago.common-lisp.cesarum.bset:bset
-                       :initial-element (com.informatimago.common-lisp.cesarum.bset:make-bset 0))
-           :type (array com.informatimago.common-lisp.cesarum.bset:bset (*)))
-  (size-1 0 :type (integer 0))
-  (size-2 0 :type (integer 0)))
+  (adjsets (make-array '(0) :element-type 'bset
+                            :initial-element (make-bset 0))
+           :type (array bset (*)))
+  (size-1 0 :type element)
+  (size-2 0 :type element))



@@ -110,14 +107,15 @@ License:
   "
 RETURN: A new BRELATION between sets of sizes SIZE-1 and SIZE-2.
 "
-  (declare (type (integer 0) size-1 size-2))
+  (check-type size-1 element)
+  (check-type size-2 element)
   (%make-brelation
    :adjsets (vector-init (make-array (list (1+ size-1))
-                                     :element-type 'com.informatimago.common-lisp.cesarum.bset:bset
-                                     :initial-element (com.informatimago.common-lisp.cesarum.bset:make-bset 0))
+                                     :element-type 'bset
+                                     :initial-element (make-bset 0))
                          (lambda (index)
                            (declare (ignore index))
-                           (com.informatimago.common-lisp.cesarum.bset:make-bset size-2)))
+                           (make-bset size-2)))
    :size-1 size-1
    :size-2 size-2))

@@ -133,358 +131,357 @@ NOTE:   This short circuits the evaluation of Q if P is false.
   `(aref (brelation-adjsets ,rel) ,i))

 (defmacro related (rel e1 e2)
-  `(com.informatimago.common-lisp.cesarum.bset:is-element ,e2 (adjref ,rel ,e1)))
-
-
-(defun include (rel e1 e2)
+  `(is-element ,e2 (adjref ,rel ,e1)))
+
+
+(deftype arc () 'cons)
+(defun arc (e1 e2) (cons e1 e2))
+(defun arc-from (arc) (car arc))
+(defun arc-to   (arc) (cdr arc))
+(defmacro with-arc (((e1 e2) arc) &body body)
+  (let ((varc (gensym)))
+    `(let ((,varc ,arc))
+       (check-type ,varc arc)
+       (let ((,e1 (arc-from ,varc))
+             (,e2 (arc-to   ,varc)))
+         (check-type ,e1 element)
+         (check-type ,e2 element)
+         ,@body))))
+
+(defmethod include ((rel brelation) arc)
   "
 DO:     Adds (E1 E2) to the relation REL.
 POST:   REL(E1,E2)
 "
-  (declare (type (integer 0) e1 e2))
-  (com.informatimago.common-lisp.cesarum.bset:include (adjref rel e1) e2)
+  (with-arc ((e1 e2) arc)
+    (include (adjref rel e1) e2))
   rel)

-
-(defun exclude (rel e1 e2)
+(defmethod exclude ((rel brelation) arc)
   "
 DO:     Remove (E1 E2) from the relation REL.
 POST:   ¬ REL(E1,E2)
 "
-  (declare (type (integer 0) e1 e2))
-  (com.informatimago.common-lisp.cesarum.bset:exclude (adjref rel e1) e2)
+  (with-arc ((e1 e2) arc)
+    (exclude (adjref rel e1) e2))
   rel)

-
-(defun is-element (e1 e2 rel)
+(defmethod is-element (arc (rel brelation))
   "
 RETURN: Whether REL(E1,E2).
 "
-  (declare (type (integer 0) e1 e2))
-  (related rel e1 e2))
-
+  (with-arc ((e1 e2) arc)
+    (related rel e1 e2)))

-(defun is-related (e1 e2 rel)
+(defgeneric is-related (e1 e2 rel))
+(defmethod is-related (e1 e2 (rel brelation))
   "
 RETURN: Whether REL(E1,E2).
 "
-  (declare (type (integer 0) e1 e2))
   (related rel e1 e2))

-
-(defun is-reflexive-1 (e1 rel)
+(defgeneric is-reflexive-1 (e1 rel))
+(defmethod is-reflexive-1 (e1 (rel brelation))
   "
 RETURN: Whether REL(E1,E1)
 "
-  (declare (type (integer 0) e1))
+  (check-type e1 element)
   (related rel e1 e1))

-
-(defun is-symmetric-1 (e1 e2 rel)
-    "
+(defgeneric is-symmetric-1 (e1 e2 rel))
+(defmethod is-symmetric-1 (e1 e2 (rel brelation))
+  "
 RETURN: Whether REL(E1,E2) ∧ REL(E2,E1)
 "
-  (declare (type (integer 0) e1 e2))
+  (check-type e1 element)
+  (check-type e2 element)
   (imply (related rel e1 e2) (related rel e2 e1)))

-
-(defun is-transitive-1 (e1 e2 e3 rel)
-      "
+(defgeneric is-transitive-1 (e1 e2 e3 rel))
+(defmethod is-transitive-1 (e1 e2 e3 (rel brelation))
+  "
 RETURN: Whether (REL(E1,E2) ∧ REL(E2,E3)) ⇒ REL(E1,E3)
 NOTE:   Tests the transitivity of the relation REL only on the
         elements E1, E2, and E3.  This doesn't mean the relation REL
         is transitive (but it's a necessary condition).
 "
-  (declare (type (integer 0) e1 e2 e3))
+  (check-type e1 element)
+  (check-type e2 element)
+  (check-type e3 element)
   (imply (and (related rel e1 e2) (related rel e2 e3)) (related rel e1 e3)))


-(defun is-reflexive (rel)
+(defgeneric is-reflexive (rel))
+(defmethod is-reflexive ((rel brelation))
   "
 RETURN: Whether the relation REL is reflexive. Ie. ∀i∈[0,SIZE1-1], REL(i,i)
 "
   (for (i 0 (brelation-size-1 rel))
-       (unless (related rel i i) (return-from is-reflexive nil)))
+    (unless (related rel i i) (return-from is-reflexive nil)))
   t)

-
-(defun is-symmetric (rel)
+(defgeneric is-symmetric (rel))
+(defmethod is-symmetric ((rel brelation))
   "
 RETURN: Whether the relation REL is symetric. Ie. ∀(i,j)∈[0,SIZE1-1]², REL(i,j) ⇒ REL(j,i)
 "
   (for (i 0 (brelation-size-1 rel))
-       (unless (com.informatimago.common-lisp.cesarum.bset:for-all (adjref rel i)
-                                                                   (lambda (j) (related rel j i)))
-         (return-from is-symmetric nil)))
+    (unless (for-all (adjref rel i)
+                     (lambda (j) (related rel j i)))
+      (return-from is-symmetric nil)))
   t)


-(defun is-transitive (rel)
-   "
+(defgeneric is-transitive (rel))
+(defmethod is-transitive ((rel brelation))
+  "
 RETURN: Whether the relation REL is transitive. Ie. ∀(i,j,k)∈[0,SIZE1-1]³, REL(i,j) ∧ REL(j,k) ⇒ REL(i,k)
 "
-   (let ((r (make-brelation (brelation-size-1 rel) (brelation-size-2 rel))))
+  (let ((r (make-brelation (brelation-size-1 rel) (brelation-size-2 rel))))
     (assign r rel)
     (closure r)
     (is-equal r rel) ))


-(defun is-equivalence (rel)
+(defgeneric is-equivalence (rel))
+(defmethod is-equivalence ((rel brelation))
   "
 RETURN: Whether REL is an equivalence relation. Ie. REL is reflexive, symetric and transitive.
 "
   (and (is-reflexive rel) (is-symmetric rel) (is-transitive rel)))


-(defun has-reflexive (rel)
+(defgeneric has-reflexive (rel))
+(defmethod has-reflexive ((rel brelation))
   "
 RETURN: ∃i∈[0,SIZE1-1], REL(i,i)
 "
   (for (i 0 (brelation-size-1 rel))
-       (when (related rel i i) (return-from has-reflexive t)))
+    (when (related rel i i) (return-from has-reflexive t)))
   nil)

-
-(defmacro until (condition &body body) `(do () (,condition) ,@body))
-
-
-(defun is-cyclic (rel)
+(defgeneric is-cyclic (rel))
+(defmethod is-cyclic ((rel brelation))
   "
 RETURN: Whether the relation REL is cyclic.
 "
-  (let ((with-pred    (com.informatimago.common-lisp.cesarum.bset:make-bset (brelation-size-1 rel)))
-        (without-pred (com.informatimago.common-lisp.cesarum.bset:make-bset (brelation-size-1 rel)))
+  (let ((with-pred    (make-bset (brelation-size-1 rel)))
+        (without-pred (make-bset (brelation-size-1 rel)))
         (pred-count   (make-array (list (1+ (brelation-size-1 rel)))
-                                  :element-type '(integer 0)
+                                  :element-type 'element
                                   :initial-element 0)))
     (for (i 0 (brelation-size-1 rel))
-      (com.informatimago.common-lisp.cesarum.bset:for-all-do (adjref rel i)
-                                                             (lambda (e) (incf (aref pred-count e)))))
+      (for-all-do (adjref rel i)
+                  (lambda (e) (incf (aref pred-count e)))))
     (for (i 0 (brelation-size-1 rel))
       (when (= 0 (aref pred-count i))
-        (com.informatimago.common-lisp.cesarum.bset:include without-pred i)))
-    (com.informatimago.common-lisp.cesarum.bset:complement with-pred)
-    (until (com.informatimago.common-lisp.cesarum.bset:is-empty without-pred)
-      (let ((i (com.informatimago.common-lisp.cesarum.bset:extract without-pred)))
-        (com.informatimago.common-lisp.cesarum.bset:exclude with-pred i)
-        (com.informatimago.common-lisp.cesarum.bset:for-all-do (adjref rel i)
-                                                               (lambda (e) (decf (aref pred-count e))
-                                                                 (when (= 0 (aref pred-count e))
-                                                                   (com.informatimago.common-lisp.cesarum.bset:include without-pred e))))))
-    (not (com.informatimago.common-lisp.cesarum.bset:is-empty with-pred))))
-
-
-
-(defun get-cyclics (rel bset)
+        (include without-pred i)))
+    (complement with-pred)
+    (until (emptyp without-pred)
+      (let ((i (extract without-pred)))
+        (exclude with-pred i)
+        (for-all-do (adjref rel i)
+                    (lambda (e) (decf (aref pred-count e))
+                      (when (= 0 (aref pred-count e))
+                        (include without-pred e))))))
+    (not (emptyp with-pred))))
+
+(defgeneric get-cyclics (rel bset))
+(defmethod get-cyclics ((rel brelation) (bset bset))
   "
 RETURN: The set of elements that are in cycles.
 "
   (let ((r (make-brelation (brelation-size-1 rel)(brelation-size-2 rel))))
     (assign r rel)
     (closure r)
-    (com.informatimago.common-lisp.cesarum.bset:assign-empty bset)
+    (assign-empty bset)
     (for (i 0 (brelation-size-1 rel))
-         (when (related r i i) (com.informatimago.common-lisp.cesarum.bset:include bset i))))
+      (when (related r i i) (include bset i))))
   bset)

-
-(defun assign-empty (rel)
+(defmethod assign-empty ((rel brelation))
   "
 POST:   REL is the empty relation.
 RETURN: REL
 "
   (for (i 0 (brelation-size-1 rel))
-       (com.informatimago.common-lisp.cesarum.bset:assign-empty (adjref rel i)))
+       (assign-empty (adjref rel i)))
   rel)

-
-(defun assign-element (rel e1 e2)
+(defmethod assign-element ((rel brelation) arc)
     "
 POST:   REL contains only (E1,E2).
 RETURN: REL
 "
-  (assign-empty rel)
-  (include rel e1 e2)
+  (with-arc ((e1 e2) arc)
+    (assign-empty rel)
+    (include rel (arc e1 e2)))
   rel)

-
-(defun assign (rel1 rel2)
+(defmethod assign ((rel1 brelation) (rel2 brelation))
   "
 POST:   REL1 is a copy of REL2.
 RETURN: REL1
 "
   (for (i 0 (brelation-size-1 rel1))
-       (com.informatimago.common-lisp.cesarum.bset:assign-empty (adjref rel1 i))
-       (com.informatimago.common-lisp.cesarum.bset:assign-empty (adjref rel2 i)))
+       (assign-empty (adjref rel1 i))
+       (assign-empty (adjref rel2 i)))
   rel1)

-
-(defun closure (rel)
-    "
+(defgeneric closure (rel))
+(defmethod closure ((rel brelation))
+  "
 POST:   REL is the transitive closure of the old REL.
 RETURN: REL
 "
   (for (j 0 (brelation-size-1 rel))
-       (unless (com.informatimago.common-lisp.cesarum.bset:is-empty (adjref rel j))
-         (for (i 0 (brelation-size-1 rel))
-              (when (related rel i j)
-                (com.informatimago.common-lisp.cesarum.bset:union (adjref rel i)
-                            (adjref rel j))))))
+    (unless (emptyp (adjref rel j))
+      (for (i 0 (brelation-size-1 rel))
+        (when (related rel i j)
+          (union (adjref rel i)
+                 (adjref rel j))))))
   rel)

-
-(defun union (rel1 rel2)
+(defmethod union ((rel1 brelation) (rel2 brelation))
      "
 POST:   REL1 is the union of old REL1 and REL2.
 RETURN: REL1
 "
   (for (i 0 (brelation-size-1 rel1))
-       (com.informatimago.common-lisp.cesarum.bset:union (adjref rel1 i) (adjref rel2 i)))
+       (union (adjref rel1 i) (adjref rel2 i)))
   rel1)

-
-(defun difference (rel1 rel2)
+(defmethod difference ((rel1 brelation) (rel2 brelation))
   "
 POST:   REL1 is the difference of old REL1 and REL2.
 RETURN: REL1
 "
   (for (i 0 (brelation-size-1 rel1))
-       (com.informatimago.common-lisp.cesarum.bset:difference (adjref rel1 i) (adjref rel2 i)))
+       (difference (adjref rel1 i) (adjref rel2 i)))
   rel1)

-
-(defun intersection (rel1 rel2)
+(defmethod intersection ((rel1 brelation) (rel2 brelation))
     "
 POST:   REL1 is the intersection of old REL1 and REL2.
 RETURN: REL1
 "
   (for (i 0 (brelation-size-1 rel1))
-       (com.informatimago.common-lisp.cesarum.bset:intersection (adjref rel1 i) (adjref rel2 i)))
+       (intersection (adjref rel1 i) (adjref rel2 i)))
   rel1)

-
-(defun sym-diff (rel1 rel2)
+(defmethod sym-diff ((rel1 brelation) (rel2 brelation))
   "
 POST:   REL1 is the symetric difference of old REL1 and REL2.
 RETURN: REL1
 "
   (for (i 0 (brelation-size-1 rel1))
-       (com.informatimago.common-lisp.cesarum.bset:sym-diff (adjref rel1 i) (adjref rel2 i)))
+       (sym-diff (adjref rel1 i) (adjref rel2 i)))
   rel1)

-
-(defun complement (rel)
+(defmethod complement ((rel brelation))
   "
 POST:   REL is the complement of old REL.
 RETURN: REL
 "
   (for (i 0 (brelation-size-1 rel))
-       (com.informatimago.common-lisp.cesarum.bset:complement (adjref rel i)))
+       (complement (adjref rel i)))
   rel)

-
-(defun is-subset (rel1 rel2)
+(defmethod subsetp ((rel1 brelation) (rel2 brelation))
   "
 RETURN: Whether REL1 is a subset of REL2.
 "
   (for (i 0 (brelation-size-1 rel1))
-       (unless (com.informatimago.common-lisp.cesarum.bset:is-subset (adjref rel1 i) (adjref rel2 i))
-         (return-from is-subset nil)))
+       (unless (subsetp (adjref rel1 i) (adjref rel2 i))
+         (return-from subsetp nil)))
   t)

-
-(defun is-strict-subset (rel1 rel2)
+(defmethod strict-subsetp ((rel1 brelation) (rel2 brelation))
     "
 RETURN: Whether REL1 is a strict subset of REL2.
 "
   (and (is-subset rel1 rel2) (is-not-equal rel1 rel2)))

-
-(defun is-equal (rel1 rel2)
-      "
+(defmethod is-equal ((rel1 brelation) (rel2 brelation))
+  "
 RETURN: Whether REL1 is equal to REL2.
 "
   (for (i 0 (brelation-size-1 rel1))
-       (unless (com.informatimago.common-lisp.cesarum.bset:is-equal  (adjref rel1 i) (adjref rel2 i))
-         (return-from is-equal nil)))
+    (unless (is-equal  (adjref rel1 i) (adjref rel2 i))
+      (return-from is-equal nil)))
   t)

-
-(defun is-not-equal (rel1 rel2)
-        "
+(defmethod is-not-equal ((rel1 brelation) (rel2 brelation))
+  "
 RETURN: Whether REL1 is not equal to REL2.
 "
   (not (is-equal rel1 rel2)))


-(defun is-empty (rel)
-          "
+(defmethod emptyp ((rel brelation))
+  "
 RETURN: Whether REL is empty.
 "
   (for (i 0 (brelation-size-1 rel))
-       (unless (com.informatimago.common-lisp.cesarum.bset:is-empty  (adjref rel i))
-         (return-from is-empty  nil)))
+    (unless (emptyp (adjref rel i))
+      (return-from emptyp nil)))
   t)

-
-(defun cardinal (rel)
+(defmethod cardinal ((rel brelation))
   "
 RETURN: The number of couples in the relation REL.
 "
   (let ((n 0))
     (for (i 0 (brelation-size-1 rel))
-         (incf n (com.informatimago.common-lisp.cesarum.bset:cardinal (adjref rel i))))
+         (incf n (cardinal (adjref rel i))))
     n))

-
-(defun select (rel)
+(defmethod select ((rel brelation))
     "
 RETURN: (values i j) such as REL(i,j), or NIL if REL is empty.
 "
   (for (i 0 (brelation-size-1 rel))
-       (unless (com.informatimago.common-lisp.cesarum.bset:is-empty (adjref rel i))
-         (return-from select (values i (com.informatimago.common-lisp.cesarum.bset:select (adjref rel i))))))
+       (unless (emptyp (adjref rel i))
+         (return-from select (values i (select (adjref rel i))))))
   nil)

-
-(defun extract (rel)
+(defmethod extract ((rel brelation))
   "
 DO:     Selects a couple in the relation REL, exclude it from REL, and return it.
-PRE:    (not (is-empty rel))
+PRE:    (not (emptyp rel))
 POST:   ¬REL(i,j)
 RETURN: (values i j) such as old REL(i,j), or NIL if REL is empty.
 "
   (multiple-value-bind (e1 e2) (select rel)
     (when e2
-      (exclude rel e1 e2)
+      (exclude rel (arc e1 e2))
       (values e1 e2))))


-(defun for-all (rel proc)
+(defmethod for-all ((rel brelation) proc)
   "
 DO:     Calls PROC on couples of the relation REL while it returns true.
 PROC:   A predicate of two elements.
 RETURN: Whether PROC returned true for all couples.
 "
   (for (i 0 (brelation-size-1 rel))
-       (unless (com.informatimago.common-lisp.cesarum.bset:for-all (adjref rel i) (lambda (e) (funcall proc i e)))
+       (unless (for-all (adjref rel i) (lambda (e) (funcall proc i e)))
          (return-from for-all nil)))
   t)

-
-(defun exists (rel proc)
+(defmethod exists ((rel brelation) proc)
    "
 DO:     Calls PROC on  couples of the relation REL until it returns true.
 PROC:   A predicate of two elements.
 RETURN: Whether PROC returned true for at least one couple.
 "
   (for (i 0 (brelation-size-1 rel))
-       (when (com.informatimago.common-lisp.cesarum.bset:exists (adjref rel i) (lambda (e) (funcall proc i e)))
+       (when (exists (adjref rel i) (lambda (e) (funcall proc i e)))
          (return-from exists t)))
   nil)


-(defun exists-1 (rel proc)
+(defmethod exists-1 ((rel brelation) proc)
   "
 DO:     Calls PROC on each couples of the relation REL.
 PROC:   A predicate of two elements.
@@ -492,19 +489,19 @@ RETURN: Whether PROC returned true for exactly one couple.
 "
   (let ((n 0))
     (for (i 0 (brelation-size-1 rel))
-         (when (com.informatimago.common-lisp.cesarum.bset:exists (adjref rel i) (lambda (e) (funcall proc i e)))
+         (when (exists (adjref rel i) (lambda (e) (funcall proc i e)))
            (incf n)))
     (= n 1)))


-(defun for-all-do (rel proc)
+(defmethod for-all-do ((rel brelation) proc)
   "
 DO:     Calls PROC on each couple of the relation REL.
 PROC:   A function of two elements.
 RETURN: REL
 "
   (for (i 0 (brelation-size-1 rel))
-       (com.informatimago.common-lisp.cesarum.bset:for-all-do (adjref rel i) (lambda (e) (funcall proc i e))))
+       (for-all-do (adjref rel i) (lambda (e) (funcall proc i e))))
   rel)


@@ -523,13 +520,12 @@ NOTE:   The serialization format is that of a list of adjacency lists.
         ((char= (peek-char t stream nil (character ")")) (character ")"))
          (read-char stream))
       (let ((i (read stream)))
-
         (when (peek-char (character "(") stream nil nil)
           (read-char stream)
           (do ()
               ((char= (peek-char t stream nil (character ")")) (character ")"))
                (read-char stream))
-            (include rel i (read stream)))))))
+            (include rel (arc i (read stream))))))))
   rel)


@@ -541,25 +537,25 @@ RETURN: REL.
   (princ "(" stream)
   (for (i 0 (brelation-size-1 rel))
        (princ i stream)
-       (com.informatimago.common-lisp.cesarum.bset:write-bset stream (adjref rel i))
+       (write-bset stream (adjref rel i))
        (terpri stream))
   (princ ")" stream)
   rel)

-
-(defun project-1 (rel e1 bset)
+(defgeneric project-1 (rel e1 bset))
+(defmethod project-1 ((rel brelation) e1 (bset bset))
   "
 POST:   BSET is the set of all elements I that are in relation REL(I,E2).
 RETURN: BSET
 "
   (assign-empty bset)
   (for (i 0 (brelation-size-1 rel))
-       (when (related rel i e1)
-         (com.informatimago.common-lisp.cesarum.bset:include bset i)))
+    (when (related rel i e1)
+      (include bset i)))
   bset)

-
-(defun project-2 (rel e1 bset)
+(defgeneric project-2 (rel e1 bset))
+(defmethod project-2 ((rel brelation) e1 (bset bset))
   "
 POST:   BSET is the set of all elements E2 that are in relation REL(E1,E2).
 RETURN: BSET
diff --git a/common-lisp/cesarum/bset.lisp b/common-lisp/cesarum/bset.lisp
index bf67f93..3b2563a 100644
--- a/common-lisp/cesarum/bset.lisp
+++ b/common-lisp/cesarum/bset.lisp
@@ -40,18 +40,18 @@
 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
 ;;;;****************************************************************************

-
-(in-package "COMMON-LISP-USER")
 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.BSET"
   (:use "COMMON-LISP")
+  (:shadow "COMPLEMENT" "INTERSECTION" "UNION" "SET" "SUBSETP")
+  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY" "VECTOR-INIT" "FOR")
   (:export "BSET-TO-LIST" "LIST-TO-BSET" "WRITE-BSET" "READ-BSET" "FOR-ALL-DO"
            "ASSIGN-EMPTY" "ASSIGN-ELEMENT" "ASSIGN" "EXISTS-1" "EXISTS" "FOR-ALL"
-           "IS-EMPTY" "IS-ELEMENT" "IS-EQUAL" "IS-STRICT-SUBSET" "IS-SUBSET" "EXTRACT"
-           "SELECT" "MAXIMUM" "MINIMUM" "SIZE" "CARDINAL" "EXCLUDE" "INCLUDE"
+           "IS-EMPTY" "IS-ELEMENT" "IS-EQUAL" "IS-NOT-EQUAL"
+           "IS-STRICT-SUBSET" "IS-SUBSET"
+           "EXTRACT" "SELECT" "MAXIMUM" "MINIMUM" "SIZE" "CARDINAL" "EXCLUDE" "INCLUDE"
            "COMPLEMENT" "SYM-DIFF" "INTERSECTION" "DIFFERENCE" "UNION" "RESIZE-BSET"
-           "COPY-BSET" "MAKE-BSET" "BSET")
-  (:shadow "COMPLEMENT" "INTERSECTION" "UNION" "SET")
-  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY" "VECTOR-INIT" "FOR")
+           "COPY-BSET" "MAKE-BSET" "BSET"
+           "ELEMENT" "EMPTYP" "SUBSETP" "STRICT-SUBSETP")
   (:documentation
    "

@@ -64,7 +64,7 @@ License:

     AGPL3

-    Copyright Pascal J. Bourguignon 2004 - 2012
+    Copyright Pascal J. Bourguignon 2004 - 2015

     This program is free software: you can redistribute it and/or modify
     it under the terms of the GNU Affero General Public License as published by
@@ -88,6 +88,7 @@ License:
   (defconstant +bit-per-bitset+ 32))

 (deftype bitset () `(unsigned-byte ,+bit-per-bitset+))
+(deftype element () '(integer 0))

 (defstruct (bset
              (:constructor %make-bset)
@@ -104,9 +105,9 @@ License:
            :type (array bitset *))
   ;; max-element == (* +bit-per-bitset+ (array-dimension bitsets 0))
   ;; last-bitset == (1- (array-dimension bitsets 0))
-  (cardinal      nil :type (or null (integer 0)))
-  (first-element 0   :type (integer 0)) ; approximate
-  (last-element  0   :type (integer 0)) ; approximate
+  (cardinal      nil :type (or null element))
+  (first-element 0   :type element) ; approximate
+  (last-element  0   :type element) ; approximate
   ;; (for all i (==> (< i (bset-first-element bset)) (not (is-element i bset))))
   ;; (for all i (==> (> i (bset-last-element  bset)) (not (is-element i bset))))
   )
@@ -170,7 +171,7 @@ PRE:    (<= 0 max-size)
 POST:   (<= max-size (size (make-bset max-size)))
 RETURN: A new bset allocated to hold at least elements from 0 to max-size.
 "
-  (declare (type (integer 0) max-size))
+  (check-type max-size element)
   (%make-bset :bitsets (make-array (list (1+ (elem-to-bitset max-size)))
                                    :element-type 'bitset
                                    :initial-element 0
@@ -191,7 +192,8 @@ DO:      Reallocate bset to have it able to hold at least elements
          from 0 to max-size.
 RETURN:  bset
 "
-  (declare (type bset bset) (type (integer 0) max-size))
+  (check-type bset bset)
+  (check-type max-size element)
   (let ((old-count (array-dimension (bset-bitsets bset) 0))
         (new-count (1+ (elem-to-bitset max-size))))
     (setf (bset-bitsets bset) (adjust-array (bset-bitsets bset)
@@ -204,8 +206,8 @@ RETURN:  bset
     bset))


-
-(defun union (set1 set2)
+(defgeneric union (s1 s2))
+(defmethod union ((set1 bset) (set2 bset))
   "
 DO:      set1 := set1 U ( set2 inter (complement (make-bset (size set1))) )
          Accumulate in set1 the union of set1 and set2
@@ -226,8 +228,8 @@ RETURN:  SET1
                                        (bset-last-element set2)))
   set1)

-
-(defun difference (set1 set2)
+(defgeneric difference (s1 s2))
+(defmethod difference ((set1 bset) (set2 bset))
   "
 DO:      set1 := set1 - ( set2 inter (complement (make-bset (size set1))) )
          Accumulate in set1 the difference of set1 and set2
@@ -247,8 +249,8 @@ RETURN:  SET1
   (setf (bset-cardinal set1) nil)
   set1)

-
-(defun intersection (set1 set2)
+(defgeneric intersection (s1 s2))
+(defmethod intersection ((set1 bset) (set2 bset))
   "
 DO:      set1 := set1 inter set2 inter
          Accumulate in set1 the intersection of set1 and set2
@@ -270,9 +272,8 @@ RETURN:  SET1
                                        (bset-last-element set2)))
   set1)

-
-
-(defun sym-diff (set1 set2)
+(defgeneric sym-diff (s1 s2))
+(defmethod sym-diff ((set1 bset) (set2 bset))
   "
 DO:      set1 := set1 delta ( set2 inter (complement (make-bset (size set1))) )
          Accumulate in set1 the symetrical difference of set1 and set2
@@ -296,8 +297,8 @@ RETURN:  SET1
                                        (bset-last-element set2)))
   set1)

-
-(defun complement (bset)
+(defgeneric complement (s))
+(defmethod complement ((bset bset))
   "
 DO:      set1 := (complement (make-bset (size set1))) - set1
          Accumulate in set1 the complement of set1
@@ -316,14 +317,14 @@ RETURN:  SET1
           (bset-last-element  bset) (1- (bitset-to-elem (last-bitset bits)))))
   bset)

-
-(defun include (bset element)
+(defgeneric include (set element))
+(defmethod include ((bset bset) element)
   "
 PRE:    (<= 0 element (size bset))
 POST:   (is-element element bset)
 RETURN: BSET
 "
-  (declare (type (integer 0) element))
+  (check-type element element)
   (let ((bits (bset-bitsets bset)))
     (setf (bsref bits (elem-to-bitset element))
           (dpb 1 (byte 1 (elem-to-bit element))
@@ -334,14 +335,14 @@ RETURN: BSET
   bset)


-
-(defun exclude (bset element)
+(defgeneric exclude (set element))
+(defmethod exclude ((bset bset) element)
   "
 PRE:    (<= 0 element (size bset))
 POST:   (not (is-element element bset))
 RETURN: BSET
 "
-  (declare (type (integer 0) element))
+  (check-type element element)
   (let ((bits (bset-bitsets bset)))
     (setf (bsref bits (elem-to-bitset element))
           (dpb 0 (byte 1 (elem-to-bit element))
@@ -355,8 +356,8 @@ RETURN: BSET
       (decf (bset-last-element bset))))
   bset)

-
-(defun cardinal (bset)
+(defgeneric cardinal (set))
+(defmethod cardinal ((bset bset))
   "
 RETURN:  The number of elements in BSET.
 "
@@ -368,7 +369,8 @@ RETURN:  The number of elements in BSET.
   (bset-cardinal bset))


-(defun size (bset)
+(defgeneric size (bset))
+(defmethod size ((bset bset))
   "
 RETURN:  The maximum element BSET can hold.
 "
@@ -376,43 +378,47 @@ RETURN:  The maximum element BSET can hold.
     (1- (bitset-to-elem (last-bitset bits)))))


-(defun minimum (bset)
+(defgeneric minimum (bset))
+(defmethod minimum ((bset bset))
   "
-PRE:     (not (is-empty bset))
+PRE:     (not (emptyp bset))
 RETURN:  The smallest element of BSET.
 "
   (for (i (bset-first-element bset)  (bset-last-element bset))
-       (when (is-element i bset)
-         (setf (bset-first-element bset) i)
-         (return-from minimum i)))
+    (when (is-element i bset)
+      (setf (bset-first-element bset) i)
+      (return-from minimum i)))
   0)


-(defun maximum (bset)
+(defgeneric maximum (bset))
+(defmethod maximum ((bset bset))
   "
-PRE:     (not (is-empty bset))
+PRE:     (not (emptyp bset))
 RETURN:  The greatest element of BSET.
 "
   (for (i (bset-last-element bset)  (bset-first-element bset))
-       (when (is-element i bset)
-         (setf (bset-last-element bset) i)
-         (return-from maximum i)))
+    (when (is-element i bset)
+      (setf (bset-last-element bset) i)
+      (return-from maximum i)))
   0)



-(defun select (bset)
+(defgeneric select (bset))
+(defmethod select ((bset bset))
   "
-PRE:      (not (is-empty bset))
+PRE:      (not (emptyp bset))
 RETURN:   An element of BSET.
 WARNING:  May return always the same element if it's not removed from the BSET.
 "
   (minimum bset))


-(defun extract (bset)
+(defgeneric extract (bset))
+(defmethod extract ((bset bset))
   "
-PRE:      (not (is-empty bset))
+PRE:      (not (emptyp bset))
 POST:     (not (is-element (extract bset) bset))
 DO:       Select an element from the BSET and removes it from the BSET.
 RETURN:   An element that was in BSET.
@@ -420,7 +426,12 @@ RETURN:   An element that was in BSET.
   (let ((i (minimum bset))) (exclude bset i) i))


-(defun is-subset (set1 set2)
+(defgeneric is-subset (set1 set2)
+  (:method (set1 set2)
+    (subsetp set1 set2)))
+
+(defgeneric subsetp (set1 set2))
+(defmethod subsetp ((set1 bset) (set2 bset))
   "
 RETURN:  Whether  SET1 is a subset of SET2.
 "
@@ -433,30 +444,35 @@ RETURN:  Whether  SET1 is a subset of SET2.
   (let ((bits1 (bset-bitsets set1))
         (bits2 (bset-bitsets set2)))
     (for (i (elem-to-bitset (bset-first-element set1))
-            (elem-to-bitset (min (bset-last-element set1)
-                                 (bset-last-element set2))))
-         (cond
-           ((= 0 (bsref bits1 i)))
-           ((= 0 (bsref bits2 i))
-            (return-from is-subset nil))
-           ((/= 0 (logandc2 (bsref bits1 i) (bsref bits2 i)))
-            (return-from is-subset nil)))
-         (when (> (bset-last-element set1) (bset-last-element set2))
-           (for (i (1+ (elem-to-bitset (bset-last-element set1)))
-                   (elem-to-bitset (bset-last-element set2)))
-                (when (/= 0 (bsref bits1 i))
-                  (return-from is-subset nil))))))
+           (elem-to-bitset (min (bset-last-element set1)
+                                (bset-last-element set2))))
+      (cond
+        ((= 0 (bsref bits1 i)))
+        ((= 0 (bsref bits2 i))
+         (return-from subsetp nil))
+        ((/= 0 (logandc2 (bsref bits1 i) (bsref bits2 i)))
+         (return-from subsetp nil)))
+      (when (> (bset-last-element set1) (bset-last-element set2))
+        (for (i (1+ (elem-to-bitset (bset-last-element set1)))
+               (elem-to-bitset (bset-last-element set2)))
+          (when (/= 0 (bsref bits1 i))
+            (return-from subsetp nil))))))
   t)

+(defgeneric is-strict-subset (set1 set2)
+  (:method (set1 set2)
+    (strict-subsetp set1 set2)))

-(defun is-strict-subset (set1 set2)
+(defgeneric strict-subsetp (set1 set2))
+(defmethod strict-subsetp ((set1 bset) (set2 bset))
   "
 RETURN:  Whether SET1 is a strict subset of SET2.
 "
-  (and (is-subset set1 set2) (not (is-equal set1 set2))))
+  (and (subsetp set1 set2) (not (is-equal set1 set2))))


-(defun is-equal (set1 set2)
+(defgeneric is-equal (set1 set2))
+(defmethod is-equal ((set1 bset) (set2 bset))
   "
 RETURN:  Whether SET1 and SET2 contain the same elements.
   "
@@ -464,99 +480,108 @@ RETURN:  Whether SET1 and SET2 contain the same elements.
       (let ((bits1 (bset-bitsets set1))
             (bits2 (bset-bitsets set2)))
         (for (i
-               (elem-to-bitset (min (bset-first-element set1)
-                                    (bset-first-element set2)))
+                 (elem-to-bitset (min (bset-first-element set1)
+                                      (bset-first-element set2)))
                (elem-to-bitset (min (bset-last-element set1)
                                     (bset-last-element set2))))
-             (unless (= (bsref bits1 i) (bsref bits2 i))
-               (return-from is-equal nil)))
+          (unless (= (bsref bits1 i) (bsref bits2 i))
+            (return-from is-equal nil)))
         (when (> (elem-to-bitset (size set1))
                  (elem-to-bitset (bset-last-element set1))
                  (elem-to-bitset (bset-last-element set2)))
           (for (i
-                 (1+ (elem-to-bitset (min (bset-last-element set1)
-                                          (bset-last-element set2))))
+                   (1+ (elem-to-bitset (min (bset-last-element set1)
+                                            (bset-last-element set2))))
                  (elem-to-bitset (size set1)))
-               (when (/= 0 (bsref bits1 i))
-                 (return-from is-equal nil))))
+            (when (/= 0 (bsref bits1 i))
+              (return-from is-equal nil))))
         (when (> (elem-to-bitset (size set2))
                  (elem-to-bitset (bset-last-element set2))
                  (elem-to-bitset (bset-last-element set1)))
           (for (i
-                 (1+ (elem-to-bitset (min (bset-last-element set1)
-                                          (bset-last-element set2))))
+                   (1+ (elem-to-bitset (min (bset-last-element set1)
+                                            (bset-last-element set2))))
                  (elem-to-bitset (size set2)))
-               (when (/= 0 (bsref bits2 i))
-                 (return-from is-equal nil))))
+            (when (/= 0 (bsref bits2 i))
+              (return-from is-equal nil))))
         t)))


-(defun is-not-equal (set1 set2)
+(defgeneric is-not-equal (set1 set2))
+(defmethod is-not-equal ((set1 bset) (set2 bset))
   "
 RETURN:  (not (is-equal set1 set2))
 "
   (not (is-equal set1 set2)))


-(defun is-element (element bset)
+(defgeneric is-element (element bset))
+(defmethod is-element (element (bset bset))
   "
 RETURN:  Whether element is in BSET.
 "
-  (declare (type (integer 0) element))
+  (check-type element element)
   (let ((bits (bset-bitsets bset)))
     (and (< element (bitset-to-elem (last-bitset bits)))
          (/= 0 (logand (bsref bits (elem-to-bitset element))
                        (ash 1 (elem-to-bit element)))))))

+(defgeneric is-empty (set)
+  (:method (set) (emptyp set)))

-(defun is-empty (bset)
+(defgeneric emptyp (set))
+(defmethod emptyp ((bset bset))
   "
 RETURN: (= 0 (cardinal bset))
 "
   (or (and (bset-cardinal bset) (= 0 (bset-cardinal bset)))
       (let ((bits (bset-bitsets bset)))
         (for (i 0 (last-bitset bits))
-             (when (/= 0 (bsref bits i)) (return-from is-empty nil)))
+          (when (/= 0 (bsref bits i)) (return-from emptyp nil)))
         (setf (bset-cardinal bset) 0)
         t)))


-(defun for-all (bset proc)
+(defgeneric for-all (bset proc))
+(defmethod for-all ((bset bset) proc)
   "
 DO:     Call function PROC for each element in the BSET until PROC returns NIL.
 RETURN: Whether no call to PROC returned NIL.
 "
   (for (i (bset-first-element bset) (bset-last-element bset))
-       (when (and (is-element i bset) (not (funcall proc i)))
-         (return-from for-all nil)))
+    (when (and (is-element i bset) (not (funcall proc i)))
+      (return-from for-all nil)))
   t)


-(defun exists (bset proc)
+(defgeneric exists (bset proc))
+(defmethod exists ((bset bset) proc)
   "
 DO:      Call function PROC for each element in the BSET
          until PROC returns non nil.
 RETURN:  Whether PROC returned non nil.
 "
   (for (i (bset-first-element bset) (bset-last-element bset))
-       (when (and (is-element i bset) (funcall proc i))
-         (return-from exists t)))
+    (when (and (is-element i bset) (funcall proc i))
+      (return-from exists t)))
   nil)


-(defun exists-1 (bset proc)
+(defgeneric exists-1 (bset proc))
+(defmethod exists-1 ((bset bset) proc)
   "
 DO:       Call function PROC on all elements in the BSET.
 RETURN:   Whether PROC returned non nil for exactly one element.
 "
   (let ((n 0))
     (for (i (bset-first-element bset) (bset-last-element bset))
-         (when (and (is-element i bset) (funcall proc i))
-           (incf n)))
+      (when (and (is-element i bset) (funcall proc i))
+        (incf n)))
     (= n 1)))


-(defun assign (set1 set2)
+(defgeneric assign (set1 set2))
+(defmethod assign ((set1 bset) (set2 bset))
   "
 DO:      Accumulate in set1 the elements of set2 that are less than (size set1).
 POST:    (is-equal set1 (intersection (complement (make-bset (size set1)))set2))
@@ -565,11 +590,11 @@ RETURN:  SET1
   (let ((bits1 (bset-bitsets set1))
         (bits2 (bset-bitsets set2)))
     (for (i 0 (min (last-bitset bits1) (last-bitset bits2)))
-         (setf (bsref bits1 i) (bsref bits2 i)))
+      (setf (bsref bits1 i) (bsref bits2 i)))
     (when (< (min (last-bitset bits1) (last-bitset bits2)) (last-bitset bits1))
       (for (i (1+ (min (last-bitset bits1) (last-bitset bits2)))
-              (last-bitset bits1))
-           (setf (bsref bits1 i) 0)))
+             (last-bitset bits1))
+        (setf (bsref bits1 i) 0)))
     (setf (bset-cardinal set1) (bset-cardinal set2)
           (bset-first-element set1) (min (bset-first-element set2)
                                          (bitset-to-elem (last-bitset bits1)))
@@ -578,7 +603,8 @@ RETURN:  SET1
   set1)


-(defun assign-element (bset element)
+(defgeneric assign-element (bset element))
+(defmethod assign-element ((bset bset) element)
   "
 DO:     Empties BSET and include element.
 PRE:    (<= 0 element (size bset))
@@ -586,7 +612,7 @@ POST:   (and (exists bset (lambda (x) (= x element)))
              (for-all bset (lambda (x) (= x element))))
 RETURN:  BSET
 "
-  (declare (type (integer 0) element))
+  (check-type element element)
   (assign-empty bset)
   (include bset element)
   (setf (bset-cardinal bset) 1
@@ -595,9 +621,10 @@ RETURN:  BSET
   bset)


-(defun assign-empty (bset)
+(defgeneric assign-empty (bset))
+(defmethod assign-empty ((bset bset))
   "
-POST:    (is-empty bset)
+POST:    (emptyp bset)
 RETURN:  BSET.
 "
   (let ((bits (bset-bitsets bset)))
@@ -608,25 +635,27 @@ RETURN:  BSET.
   bset)


-(defun for-all-do (bset proc)
+(defgeneric for-all-do (bset proc))
+(defmethod for-all-do ((bset bset) proc)
   "
 DO:      Call PROC on all elements in BSET.
 RETURN:  BSET.
 "
   (for (i (bset-first-element bset) (bset-last-element bset))
-       (when (is-element i bset)
-         (funcall proc i)))
+    (when (is-element i bset)
+      (funcall proc i)))
   bset)


-(defun bset-to-list (bset)
+(defgeneric bset-to-list (bset))
+(defmethod bset-to-list ((bset bset))
   "
 RETURN:  A list of all elements of BSET, sorted in increasing order.
 "
   (let ((elements '()))
     (for (i (bset-last-element bset) (bset-first-element bset))
-         (when (is-element i bset)
-           (push i elements)))
+      (when (is-element i bset)
+        (push i elements)))
     elements))


diff --git a/common-lisp/cesarum/ecma048.lisp b/common-lisp/cesarum/ecma048.lisp
index e10ca2b..6e6c77a 100644
--- a/common-lisp/cesarum/ecma048.lisp
+++ b/common-lisp/cesarum/ecma048.lisp
@@ -125,7 +125,8 @@
    "STX"  "SU"   "SUB"  "SVS"  "SYN"
    "TAC"  "TALE" "TATE" "TBC"  "TCC"
    "TSR"  "TSS"  "VPA"  "VPB"  "VPR"
-   "VT"   "VTS"  "SPD"  "EL"))
+   "VT"   "VTS"  "SPD"  "EL"
+   "FS" "GS" "RS" "US" "DEL" "PAD" "HOP" "IND" "SGCI"))
 (in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ECMA048")


diff --git a/common-lisp/cesarum/graph.lisp b/common-lisp/cesarum/graph.lisp
index cef74c4..caa3643 100644
--- a/common-lisp/cesarum/graph.lisp
+++ b/common-lisp/cesarum/graph.lisp
@@ -49,6 +49,8 @@
         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SET")
   (:shadowing-import-from "COMMON-LISP"
                           "UNION" "INTERSECTION" "MERGE")
+  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
+                "WHILE")
   (:export "EDGE-CLASS" "EDGES" "NODES" "TO" "FROM" "WEIGHT" "INDEX"
            "ELEMENTS" "PROPERTIES" "IDENT" "SHOW-GRAPH" "FIND-NODES-WITH-PROPERTY"
            "COPY" "WALK-EDGES-FROM-NODE" "WALK-FROM-NODE" "FLOW-DISTANCE-FROM-NODE"
@@ -65,7 +67,7 @@
            "SELECT-ELEMENTS" "MAP-ELEMENTS" "PERFORM-WITH-ELEMENTS" "REMOVE-ELEMENT"
            "ADD-ELEMENTS" "CARDINAL" "SET-CLASS" "DELETE-PROPERTY" "GET-PROPERTY"
            "SET-PROPERTY" "PROPERTY-NAMES" "ELEMENT-CLASS")
-  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY" "WHILE")
+
   (:documentation
    "

@@ -215,11 +217,6 @@ DO:     Remove the property named `prop-name' from the property list of
 "))


-(defgeneric cardinal (self)
-  (:documentation   "
-RETURN: The number of elements in this set.
-"))
-

 (defgeneric add-elements (self newelementlist)
   (:documentation   "
@@ -244,13 +241,6 @@ NOTE:   lambda-body must not change this set.
 "))


-(defgeneric map-elements (result-type self lambda-body)
-  (:documentation   "
-RETURN: the list of results returned by lambda-body called with each element.
-NOTE:   lambda-body must not change this set.
-"))
-
-
 (defgeneric select-elements (self select-lambda)
   (:documentation   "
 RETURN: A list of elements for which select-lambda returned true.
@@ -520,8 +510,7 @@ DO:     Remove the property named `prop-name' from the property list of


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defgeneric elements (set)
-  (:documentation "The elements in the set."))
+

 (defclass set-class (element-class)
   ((elements
@@ -696,13 +685,6 @@ RETURN: A string describing this element.
             (description (cdr nodes)))))


-(defgeneric copy (self &key &allow-other-keys)
-  (:documentation "
-RETURN: A COPY of this edge.
-        The COPY has the same  NODES than this edge.
-        Other attributes are normally copied."))
-
-
 (defgeneric nodes (self)
   (:documentation "
 RETURN: A list of NODES.
diff --git a/common-lisp/cesarum/set.lisp b/common-lisp/cesarum/set.lisp
index 2a281a8..d61a05f 100644
--- a/common-lisp/cesarum/set.lisp
+++ b/common-lisp/cesarum/set.lisp
@@ -314,12 +314,12 @@ RETURN:         A new set containing only the elements of SET that
                     set))))


-(defgeneric copy                  (set)
+(defgeneric copy (set &key &allow-other-keys)
   (:documentation "
 RETURN:         A new set of same class as SET, containing the same
                 elements as SET.
 ")
-  (:method (set)
+  (:method (set &key &allow-other-keys)
     (assign (make-instance (class-of set)) set)))

 (defgeneric union                 (result-type set1 set2)
@@ -496,6 +496,9 @@ RETURN: SET.
 ;;; A simple implementation to test the default methods.
 ;;;

+(defgeneric elements (set)
+  (:documentation "The elements in the set."))
+
 (defclass list-set ()
   ((elements :initform '() :initarg :elements :reader elements)))

diff --git a/common-lisp/html-base/ml-sexp.lisp b/common-lisp/html-base/ml-sexp.lisp
index 58dd31d..3b0904e 100644
--- a/common-lisp/html-base/ml-sexp.lisp
+++ b/common-lisp/html-base/ml-sexp.lisp
@@ -46,12 +46,12 @@
    "ELEMENT-CHILD"
    "STRING-SINGLE-CHILD-P"

-   "CHILD-TAGGED"            "CHILDREN-TAGGED"            "GRANDCHILDREN-TAGGED"
-   "CHILD-VALUED"            "CHILDREN-VALUED"            "GRANDCHILDREN-VALUED"
-   "CHILD-TAGGED-AND-VALUED" "CHILDREN-TAGGED-AND-VALUED" "GRANDCHILDREN-TAGGED-AND-VALUED"
+   "CHILD-TAGGED"         "CHILD-VALUED"         "CHILD-TAGGED-AND-VALUED"
+   "CHILDREN-TAGGED"      "CHILDREN-VALUED"      "CHILDREN-TAGGED-AND-VALUED"
+   "GRANDCHILD-TAGGED"    "GRANDCHILD-VALUED"    "GRANDCHILD-TAGGED-AND-VALUED"
+   "GRANDCHILDREN-TAGGED" "GRANDCHILDREN-VALUED" "GRANDCHILDREN-TAGGED-AND-VALUED"

    "ELEMENT-AT-PATH"
-
    "VALUE-TO-BOOLEAN")
   (:documentation "

@@ -206,13 +206,25 @@ In addition to normal elements, there are sgml directives
 (defgeneric children-tagged (element tag))
 (defgeneric grandchildren-tagged (element tag))

+(defgeneric grandchild-tagged (element tag)
+  (:method (element tag)
+    (first (grandchildren-tagged element tag))))
+
 (defgeneric child-valued (element attribute value))
 (defgeneric children-valued (element attribute value))
 (defgeneric grandchildren-valued (element attribute value))

+(defgeneric grandchild-valued (element attribute value)
+  (:method (element attribute value)
+    (first (grandchildren-valued element attribute value))))
+
 (defgeneric child-tagged-and-valued (element tag attribute value))
 (defgeneric children-tagged-and-valued (element tag attribute value))
-(defgeneric grandchild-tagged-and-valued (element tag attribute value))
+(defgeneric grandchildren-tagged-and-valued (element tag attribute value))
+
+(defgeneric grandchild-tagged-and-valued (element tag attribute value)
+  (:method (element tag attribute value)
+    (first (grandchildren-tagged-and-valued element tag attribute value))))

 (defgeneric element-at-path (element tag-path))

diff --git a/common-lisp/html-parser/parse-html.lisp b/common-lisp/html-parser/parse-html.lisp
index 7518101..78d201f 100644
--- a/common-lisp/html-parser/parse-html.lisp
+++ b/common-lisp/html-parser/parse-html.lisp
@@ -36,7 +36,7 @@
 ;;;;****************************************************************************

 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.HTML-PARSER.PARSE-HTML"
-   (:use "COMMON-LISP"
+  (:use "COMMON-LISP"
         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST"
         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING"
@@ -66,8 +66,7 @@
                                  "PRINT-NOT-READABLE-OBJECT")
   (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING" "UNSPLIT-STRING"
                 "SPLIT-STRING" "STRING-REPLACE")
-  (:export "HTML-ATTRIBUTE" "HTML-CONTENTS" "HTML-ATTRIBUTES" "HTML-TAG"
-           "UNPARSE-HTML" "WRITE-HTML-TEXT"
+  (:export "UNPARSE-HTML" "WRITE-HTML-TEXT"
            "PARSE-HTML-STREAM" "PARSE-HTML-STRING" "PARSE-HTML-FILE")
   (:documentation "

@@ -641,7 +640,7 @@ structured according to the OPEN-TAG and (optional) CLOSE-TAG tokens.
 DO:                 Parse the HTML stream STREAM.
 VERBOSE:            When true, writes some information in the *TRACE-OUTPUT*.
 RETURN:             A list of html elements.
-SEE ALSO:           HTML-TAG, HTML-ATTRIBUTES, HTML-PATTRIBUTE, HTML-CONTENTS.
+SEE ALSO:           ELEMENT-TAG, ELEMENT-ATTRIBUTES, ATTRIBUTE-NAMED, ELEMENT-CHILDREN.
 "
   (let ((name (or (ignore-errors (namestring stream))
                   (princ-to-string stream)))
@@ -664,7 +663,7 @@ DO:                 Parse the HTML file PATHNAME.
 VERBOSE:            When true, writes some information in the *TRACE-OUTPUT*.
 EXTERNAL-FORMAT:    The external-format to use to open the HTML file.
 RETURN:             A list of html elements.
-SEE ALSO:           HTML-TAG, HTML-ATTRIBUTES, HTML-PATTRIBUTE, HTML-CONTENTS.
+SEE ALSO:           ELEMENT-TAG, ELEMENT-ATTRIBUTES, ATTRIBUTE-NAMED, ELEMENT-CHILDREN.
 "
   (with-open-file (src pathname :direction :input
                                 :if-does-not-exist :error
@@ -677,7 +676,7 @@ SEE ALSO:           HTML-TAG, HTML-ATTRIBUTES, HTML-PATTRIBUTE, HTML-CONTENTS.
 DO:                 Parse the HTML in the STRING (between START and END)
 VERBOSE:            When true, writes some information in the *TRACE-OUTPUT*.
 RETURN:             A list of html elements.
-SEE ALSO:           HTML-TAG, HTML-ATTRIBUTES, HTML-PATTRIBUTE, HTML-CONTENTS.
+SEE ALSO:           ELEMENT-TAG, ELEMENT-ATTRIBUTES, ATTRIBUTE-NAMED, ELEMENT-CHILDREN.
 "
   (when verbose
     (format *trace-output* "~&starting string parsing from ~D~%" start))
@@ -686,19 +685,6 @@ SEE ALSO:           HTML-TAG, HTML-ATTRIBUTES, HTML-PATTRIBUTE, HTML-CONTENTS.



-(defun html-tag        (html)
-  "RETURN: The TAG of the HTML element."
-  (first  html))
-(defun html-attributes (html)
-  "RETURN: The PATTRIBUTES of the HTML element."
-  (second html))
-(defun html-contents   (html)
-  "RETURN: The CONTENTS of the HTML element."
-  (cddr   html))
-(defun html-pattribute  (html key)
-  "RETURN: The PATTRIBUTE named KEY in the HTML element."
-  (cadr (member key (second html))))
-

 (defparameter *nl* (make-hash-table)
   "
@@ -716,11 +702,11 @@ to a list of two elements:
   to format the element as (reStructured)text.
 ")

-(defun html-tag-key (html)
-  (intern (string (html-tag html)) *tag-package*))
+(defun element-key (html)
+  (intern (string (element-tag html)) *tag-package*))

 (defun must-new-line (html where)
-  (member where (first (gethash (html-tag-key html) *nl*))))
+  (member where (first (gethash (element-key html) *nl*))))


 (defun write-text (element)
@@ -729,7 +715,7 @@ to a list of two elements:
     (atom   (princ element))
     (otherwise
      (flet ((write-it ()
-              (let ((entry (gethash (html-tag element) *nl*)))
+              (let ((entry (gethash (element-tag element) *nl*)))
                 (if (second entry)
                     (funcall (second entry) element)
                     (progn
@@ -739,10 +725,10 @@ to a list of two elements:
                       (princ element)
                       (when (intersection '(:bc :ac) (first entry))
                         (terpri)))))))
-       (cond ((member (html-tag element) '(:foreign :definition :comment)
+       (cond ((member (element-tag element) '(:foreign :definition :comment)
                       :test (function string-equal))
               #|ignore|#)
-             ((member (html-tag element) '(:pre :quote :address)
+             ((member (element-tag element) '(:pre :quote :address)
                       :test (function string-equal))
               (let ((*pre* t))
                 (write-it)))
@@ -750,7 +736,7 @@ to a list of two elements:
               (write-it)))))))

 (defun write-children-text (self)
-  (dolist (child (html-contents self))
+  (dolist (child (element-children self))
     (write-text child)))

 (defun write-nothing (self)
@@ -841,7 +827,7 @@ to a list of two elements:
 (define-element-writer i                ()                 (write-parenthesized-children self "/" "/"))
 (define-element-writer iframe           (:bo :ao :bc :ac)  :children)
 (define-element-writer img              (:bo :ac)
-  (let ((alt (html-pattribute self :alt)))
+  (let ((alt (attribute-named self :alt)))
     (when alt (princ alt))))
 (define-element-writer input            (:bo :ac)          :children)
 (define-element-writer ins              ()                 :children)
@@ -918,18 +904,18 @@ to a list of two elements:


 (defvar *row-kind* :body)
-(defstruct row   kind tag pattributes cells)
-(defstruct cell           pattributes lines)
+(defstruct row   kind tag attributes cells)
+(defstruct cell           attributes lines)


 (defun collect-table-cells (element)
   (when (listp element)
-    (case (html-tag element)
+    (case (element-tag element)
       ((:table)  (let ((*row-kind* :body)
                        (rows       '()))
-                   (dolist (child (html-contents element) rows)
+                   (dolist (child (element-children element) rows)
                      (when (listp child)
-                       (case (html-tag child)
+                       (case (element-tag child)
                          ((:thead :tbody) (appendf rows (collect-table-cells child)))
                          ((:th :tr)       (appendf rows (list (collect-table-cells child))))
                          ((:caption :col :colgroup) #| ignore for now |#)
@@ -940,14 +926,14 @@ to a list of two elements:
                    (collect-table-cells element)))
       ((:th :tr) (make-row
                   :kind       *row-kind*
-                  :tag        (html-tag element)
-                  :attributes (html-attributes element)
+                  :tag        (element-tag element)
+                  :attributes (element-attributes element)
                   :cells      (mapcar (function collect-table-cells)
                                       (remove-if-not (lambda (element)
                                                        (and (listp element)
-                                                            (eql :td (html-tag element))))
-                                                     (html-contents element)))))
-      ((:td)     (make-cell :attributes (html-attributes element)
+                                                            (eql :td (element-tag element))))
+                                                     (element-children element)))))
+      ((:td)     (make-cell :attributes (element-attributes element)
                             :lines      (split-string (with-output-to-string (*standard-output*)
                                                         (write-children-text element))
                                                       #(#\newline))))
@@ -1019,9 +1005,9 @@ Some reStructuredText formating is used.
 Simple tables are rendered, but colspan and rowspan are ignored.
 "
   (let ((*standard-output* stream))
-    (if (string-equal (html-tag html) :document)
-        (dolist (item (html-contents html))
-          (write-text item))
+    (if (string-equal (element-tag html) :document)
+        (dolist (child (element-children html))
+          (write-text child))
         (write-text html))))


@@ -1043,33 +1029,33 @@ Simple tables are rendered, but colspan and rowspan are ignored.
         (cond
           ((atom html)
            (format stream "~A" html))
-          ((string-equal (html-tag html) :document)
+          ((string-equal (element-tag html) :document)
            ;; (:document nil …)
-           (dolist (item (html-contents html))
-             (unparse-html item stream)))
-          ((string-equal (html-tag html) :foreign)
+           (dolist (child (element-children html))
+             (unparse-html child stream)))
+          ((string-equal (element-tag html) :foreign)
            ;; (:foreign nil "<?xml version=\"1.0\" encoding=\"utf-8\" ?>")
            (format stream "~&~{~A~}~%" (element-children html)))
-          ((string-equal (html-tag html) :comment)
+          ((string-equal (element-tag html) :comment)
            ;; (:foreign nil "<?xml version=\"1.0\" encoding=\"utf-8\" ?>")
            (format stream "~&<!--~{~A~}-->~%" (element-children html)))
-          ((string-equal (html-tag html) :definition)
+          ((string-equal (element-tag html) :definition)
            ;; (:definition () :doctype "html" "PUBLIC" "-//W3C//DTD XHTML 1.0 Transitional//EN"
            ;;                        "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
            (format stream "~&<!~{~A~^ ~}>~%" (cddr html)))
           (t
-           (let ((nl (first (gethash (html-tag-key html) *nl*))))
+           (let ((nl (first (gethash (element-key html) *nl*))))
              (format stream "~:[~;~&~]<~A~{ ~A=~S~}>~:[~;~&~]"
                      (member :bo nl)
-                     (tag-case (html-tag html))
+                     (tag-case (element-tag html))
                      (loop :for (attr val) :on (element-attributes html) :by (function cddr)
                            :nconc (list (tag-case attr) val))
                      (member :ao nl))
-             (dolist (item (html-contents html))
-               (unparse-html item stream))
+             (dolist (child (element-children html))
+               (unparse-html child stream))
              (format stream "~:[~;~&~]</~A>~:[~;~&~]"
                      (member :bc nl)
-                     (tag-case (html-tag html))
+                     (tag-case (element-tag html))
                      (member :ac nl)))))))))

 ;;;; THE END ;;;;
diff --git a/common-lisp/picture/picture.lisp b/common-lisp/picture/picture.lisp
index 7bd2917..846e1c6 100644
--- a/common-lisp/picture/picture.lisp
+++ b/common-lisp/picture/picture.lisp
@@ -607,8 +607,10 @@ RETURN: SELF
      (set-sprite-data self
                       (mapcar (lambda (frame) (split-string frame *new-line*))
                               sprite-data)))
-    ((and (consp sprite-data) (consp (car sprite-data)) (or (stringp (caar sprite-data))
-                                                            (consp (caar sprite-data))))
+    ((and (consp sprite-data)
+          (consp (car sprite-data))
+          (or (stringp (caar sprite-data))
+              (consp (caar sprite-data))))
      (let ((new-data
              (make-array
               (list (length sprite-data)
@@ -640,7 +642,7 @@ RETURN: SELF
                                   ((stringp cur-char) (aref cur-char 0))
                                   ((numberp cur-char) (code-char cur-char))
                                   ((symbolp cur-char)
-                                   (aref (symbol-sprite-name cur-char) 0))
+                                   (aref (sprite-name cur-char) 0))
                                   (t (error "~S is not a character!" cur-char))
                                   )))
                      (loop for x from 0 below (array-dimension new-data 2)
@@ -653,7 +655,7 @@ RETURN: SELF
                                       ((stringp cur-char) (aref cur-char 0))
                                       ((numberp cur-char) (code-char cur-char))
                                       ((symbolp cur-char)
-                                       (aref (symbol-sprite-name cur-char) 0))
+                                       (aref (sprite-name cur-char) 0))
                                       (t (error "~S is not a character!"
                                                 cur-char))
                                       ))))))
diff --git a/future/vfs/filenames.lisp b/future/vfs/filenames.lisp
index f090662..7a30bc5 100644
--- a/future/vfs/filenames.lisp
+++ b/future/vfs/filenames.lisp
@@ -78,6 +78,7 @@
                          name
                          dummy2 type dummy3 version)
         (re-exec *logical-pathname-regexp* string :start start :end end)
+      (declare (ignore dummy0 dummy1 dummy2 dummy3))
       (if all
           (list (and host        (re-match-string string host))
                 (if relative :relative :absolute)
@@ -100,37 +101,37 @@
                          (t (parse-integer version :junk-allowed nil))))))
           (error "Syntax error parsing pathname ~S" string)))))

+(defun concat* (type list)
+  (let* ((totlen  (reduce (lambda (length item) (+ (length item) length))
+                          list :initial-value 0))
+         (result  (cond
+                    ((or (eq type 'string)
+                         (and (consp type) (eq 'string (first type))))
+                     (make-string totlen))
+                    ((or (eq type 'vector)
+                         (and (consp type) (eq 'vector (first type)))
+                         (eq type 'array)
+                         (and (consp type) (eq 'array (first type))))
+                     (make-array totlen))
+                    ((eq type 'list)
+                     (make-list totlen))
+                    (t (error "Invalid sequence type: ~S" type)))))
+    (loop
+      :for item :in list
+      :and start = 0 :then (+ start (length item))
+      :do (replace result item :start1 start)
+      :finally (return result))))

 (defun match-wild-word-p (item wild)
-  (flet ((concat (type list)
-           (let* ((totlen  (reduce (lambda (length item) (+ (length item) length))
-                                   list :initial-value 0))
-                  (result  (cond
-                             ((or (eq type 'string)
-                                  (and (consp type) (eq 'string (first type))))
-                              (make-string totlen))
-                             ((or (eq type 'vector)
-                                  (and (consp type) (eq 'vector (first type)))
-                                  (eq type 'array)
-                                  (and (consp type) (eq 'array (first type))))
-                              (make-array totlen))
-                             ((eq type 'list)
-                              (make-list totlen))
-                             (t (error "Invalid sequence type: ~S" type)))))
-             (loop
-               :for item :in list
-               :and start = 0 :then (+ start (length item))
-               :do (replace result item :start1 start)
-               :finally (return result)))))
-    (re-match
-     (concat 'string
-             (cons "^"
-                   (nconc
-                    (loop
-                      :for chunks :on (split-sequence #\* wild)
-                      :collect (car chunks) :when (cdr chunks) :collect ".*")
-                    (list "$"))))
-     item)))
+  (re-match
+   (concat* 'string
+            (cons "^"
+                  (nconc
+                   (loop
+                     :for chunks :on (split-sequence #\* wild)
+                     :collect (car chunks) :when (cdr chunks) :collect ".*")
+                   (list "$"))))
+   item))


 ;;;---------------------------------------------------------------------
@@ -187,6 +188,7 @@
 #+emacs (put 'define-pathname-attribute 'lisp-indent-function 1)
 (defmacro define-pathname-attribute (name &optional docstring)
   `(defun ,(intern (format nil "PATHNAME-~A" name)) (pathname &key (case :local))
+     (declare (ignore case))
      ,@(when docstring (list docstring))
      (,(intern (format nil "%PATHNAME-~A" name)) (pathname pathname))))

@@ -278,8 +280,8 @@ file). Implementations can define other special version symbols.")
                      ((eql :wild host)       'pathname)
                      ((logical-host-p host)  'logical-pathname)
                      (t                      'pathname))
-        :host host :directory (cons relative directory)
-        :name name :type type :version version)))
+                   :host host :directory (cons relative directory)
+                   :name name :type type :version version)))



@@ -325,6 +327,7 @@ file). Implementations can define other special version symbols.")


 (defun enough-namestring (pathname &optional defaults)
+  (declare (ignore pathname defaults))
   (error "enough-namestring not implemented yet"))


@@ -341,6 +344,7 @@ file). Implementations can define other special version symbols.")

 (defun make-pathname (&key host device directory name type version (case :local)
                         (defaults nil defaults-p))
+  (declare (ignore case))
   (cond ((stringp directory)  (setf directory (list :absolute directory)))
         ((eq :wild directory) (setf directory (list :absolute :wild-inferiors))))
   (let ((host (check-host (or host (if defaults-p
@@ -350,12 +354,12 @@ file). Implementations can define other special version symbols.")
                      ((eql :wild host)       'pathname)
                      ((logical-host-p host)  'logical-pathname)
                      (t                      'pathname))
-        :host        host
-        :device      (or device    (and defaults (pathname-device    defaults)))
-        :directory   (or directory (and defaults (pathname-directory defaults)))
-        :name        (or name      (and defaults (pathname-name      defaults)))
-        :type        (or type      (and defaults (pathname-type      defaults)))
-        :version     (or version   (and defaults (pathname-version   defaults))))))
+                   :host        host
+                   :device      (or device    (and defaults (pathname-device    defaults)))
+                   :directory   (or directory (and defaults (pathname-directory defaults)))
+                   :name        (or name      (and defaults (pathname-name      defaults)))
+                   :type        (or type      (and defaults (pathname-type      defaults)))
+                   :version     (or version   (and defaults (pathname-version   defaults))))))



@@ -400,7 +404,7 @@ RETURN: The logical pathname translations for the HOST.
                                             :name host
                                             :type "TRANSLATIONS"
                                             :version :newest)
-                             :if-does-not-exist nil)
+                        :if-does-not-exist nil)
         (if input
             (setf (logical-pathname-translations host) (read input nil nil))
             (error "No logical pathname translation file found for host ~S"
@@ -432,7 +436,7 @@ RETURN: The logical pathname translations for the HOST.
                                           (pathname-host thing :case :common)
                                           default-host))))
       (string
-       (if (string= thing "" :start start :end end)
+       (if (string= thing "" :start1 start :end1 end)
            (values (make-instance 'pathname :host nil :directory nil :name nil :type nil :version nil)
                    start)
            ;; TODO: implement junk-allowed
@@ -450,8 +454,8 @@ RETURN: The logical pathname translations for the HOST.
                                        ((eql :wild host)       'pathname)
                                        ((logical-host-p host)  'logical-pathname)
                                        (t                      'pathname))
-                          :host host :directory (cons relative directory)
-                          :name name :type type :version version)
+                                     :host host :directory (cons relative directory)
+                                     :name name :type type :version version)
                       (or end (length thing)))))
                  (values nil start))))))))

@@ -493,11 +497,12 @@ RETURN: The logical pathname translations for the HOST.
       (and (stringp item) (stringp wild) (string= item wild))))

 (defun match-directory-items-p (item wild)
-  (or (null item wild)
+  (or (null item)
+      (null wild)
       (if (eq (first wild) :wild-inferiors)
           (loop
             :for rest :on item
-            :thereis (match-directory-items-p rest (rest wild)))
+              :thereis (match-directory-items-p rest (rest wild)))
           (and (match-item-p (first item) (first wild) t)
                (match-directory-items-p (rest item) (rest wild))))))

@@ -546,6 +551,8 @@ RETURN: The logical pathname translations for the HOST.
   (assert-type source        '(or string pathname file-stream))
   (assert-type from-wildcard '(or string pathname file-stream))
   (assert-type to-wildcard   '(or string pathname file-stream))
+  (error "NOT IMPLEMENTED YET")
+  #-(and)
   (let ((source        (pathname-components (pathname source)))
         (from-wildcard (pathname-components (pathname from-wildcard)))
         (to-wildcard   (pathname-components (pathname to-wildcard))))
@@ -554,10 +561,7 @@ RETURN: The logical pathname translations for the HOST.
       :for s-compo :in source
       :for f-compo :in from-wildcard
       :for t-compo :in to-wildcard
-      :collect (if dirp
-
-
-                   ))))
+      :collect :to-be-done)))



@@ -571,7 +575,7 @@ RETURN: The logical pathname translations for the HOST.
       ""))

 (defun test ()
-  (let* ((source "CRACKBOOMHUH")
+  (let* (;; (source "CRACKBOOMHUH")
          (source "FOOZIMBAR")
          (from      (split-sequence #\* "FOO*BAR"))
          (to        (split-sequence #\* "Z(O)OM*ZOOM"))
@@ -593,16 +597,16 @@ RETURN: The logical pathname translations for the HOST.

 (defun delete-back (dir)
   (loop
-    :with changed = t
+    :with changed := t
     :while changed
     :do (loop
-          :for cur = dir :then (cdr cur)
-          :initially (setf changed nil)
+          :for cur := dir :then (cdr cur)
+            :initially (setf changed nil)
           :do (when (and (or (stringp (cadr cur)) (eq :wild (cadr cur)))
                          (eq :back (caddr cur)))
                 (setf (cdr cur) (cdddr cur)
-                      changed t)))
-    :finally (return dir)))
+                      changed t))))
+  dir)


 (defun merge-pathnames (pathname
diff --git a/future/vfs/files.lisp b/future/vfs/files.lisp
index 8fd9ed2..d987565 100644
--- a/future/vfs/files.lisp
+++ b/future/vfs/files.lisp
@@ -166,6 +166,7 @@ COMMON-LISP: probe-file tests whether a file exists.
 (defun file-write-date   (path) (write-date   (file-entry (truename path))))
 (defun file-element-type (path) (element-type (file-entry (truename path))))

+(defgeneric rename-entry (self newpath))
 (defmethod rename-entry ((self fs-file) newpath)
   ;; rename the whole file
   (when (ignore-errors (probe-file newpath))
@@ -189,10 +190,12 @@ COMMON-LISP: probe-file tests whether a file exists.
           (gethash (version self) (versions file)) self)
     self))

+(defgeneric delete-entry (self))
 (defmethod delete-entry ((self fs-file))
   ;; delete the whole file
   (remove-entry-named (parent self) (pathname-entry-name self)))

+(defgeneric remove-version (self version))
 (defmethod remove-version ((self fs-file) version)
   (remhash version (versions self))
   (when (= version (version (newest self)))
diff --git a/future/vfs/general.lisp b/future/vfs/general.lisp
index 1407735..d01ae36 100644
--- a/future/vfs/general.lisp
+++ b/future/vfs/general.lisp
@@ -69,19 +69,9 @@


 ;; Macros are taken from clisp sources, and adapted.
-(eval-when (:execute :compile-toplevel :load-toplevel)
- (defun parse-body (body)
-   (values (extract-body body)
-           (let ((decls '()))
-             (maphash
-              (lambda (k v)
-                (setf decls (nconc (mapcar (lambda (d) (cons k v)) v) decls)))
-              (declarations-hash-table (extract-declarations body)))
-             decls))))
-

 (defmacro with-open-file ((stream &rest options) &body body)
-  (multiple-value-bind (body-rest declarations)  (parse-body body)
+  (multiple-value-bind (body-rest declarations)  (parse-body :locally body)
     `(let ((,stream (open ,@options)))
        (declare (read-only ,stream) ,@declarations)
        (unwind-protect
@@ -91,7 +81,7 @@


 (defmacro with-open-stream ((var stream) &body body)
-  (multiple-value-bind (body-rest declarations) (parse-body body)
+  (multiple-value-bind (body-rest declarations) (parse-body :locally body)
     `(let ((,var ,stream))
        (declare (read-only ,var) ,@declarations)
        (unwind-protect
@@ -102,7 +92,7 @@
 (defmacro with-input-from-string ((var string  &key (index nil sindex)
                                        (start '0 sstart) (end 'nil send))
                                   &body body)
-  (multiple-value-bind (body-rest declarations) (parse-body body)
+  (multiple-value-bind (body-rest declarations) (parse-body :loally body)
     `(let ((,var (make-string-input-stream
                   ,string
                   ,@(if (or sstart send)
@@ -118,7 +108,7 @@
 (defmacro with-output-to-string ((var &optional (string nil)
                                       &key (element-type ''character))
                                  &body body)
-  (multiple-value-bind (body-rest declarations) (parse-body body)
+  (multiple-value-bind (body-rest declarations) (parse-body :locally body)
     (if string
         (let ((ignored-var (gensym)))
           `(let ((,var (make-instance 'string-output-stream :string ,string))
diff --git a/future/vfs/streams.lisp b/future/vfs/streams.lisp
index 390ed24..06c0dea 100644
--- a/future/vfs/streams.lisp
+++ b/future/vfs/streams.lisp
@@ -247,39 +247,45 @@ DO:     Specifies the name and parameter list of methods.
        (defun ,name ,arguments
          ,@(when documentation (list documentation))
          ,@(when stream-designator
-                 `((setf ,stream-name (stream-designator
-                                       ,stream-name
-                                       ,(if (listp stream-designator)
-                                            (ecase (second stream-designator)
-                                              ((:input)  '*standard-input*)
-                                              ((:output) '*standard-output*))
-                                            '*standard-input*)))))
+             `((setf ,stream-name (stream-designator
+                                   ,stream-name
+                                   ,(if (listp stream-designator)
+                                        (ecase (second stream-designator)
+                                          ((:input)  '*standard-input*)
+                                          ((:output) '*standard-output*))
+                                        '*standard-input*)))))
          ,(if (lambda-list-rest-p lambda-list)
               `(apply (function ,m-name) ,@(make-argument-list lambda-list))
               `(,m-name         ,@(butlast (make-argument-list lambda-list)))))
        ,@(when cl-forward
-               `((defmethod ,m-name
-                     ,(make-method-lambda-list lambda-list stream-name 'cl-stream)
-                   ,(let ((arguments (mapcar
-                                      (lambda (arg)
-                                        (if (eq arg stream-name)
-                                            `(cl-stream-stream ,stream-name)
-                                            arg))
-                                      (make-argument-list lambda-list))))
-                         (if (lambda-list-rest-p lambda-list)
-                             `(apply (function ,cl-name) ,@arguments)
-                             `(,cl-name ,@(butlast arguments)))))
-                 ;; We don't want to allow access to CL:STREAM from a sandbox.
-                 ;; (defmethod ,m-name
-                 ;;     ,(make-method-lambda-list lambda-list stream-name 'cl:stream)
-                 ;;   ,(let ((arguments (make-argument-list lambda-list)))
-                 ;;         (if (lambda-list-rest-p lambda-list)
-                 ;;             `(apply (function ,cl-name) ,@arguments)
-                 ;;             `(,cl-name ,@(butlast arguments)))))
-                 ))
+           ;; TODO: review the generation of generic function lambda list:
+           (let ((method-lambda-list (make-method-lambda-list lambda-list stream-name 'cl-stream)))
+             `((defgeneric ,m-name ,(mapcar (lambda (parameter)
+                                              (if (listp parameter)
+                                                  (first parameter)
+                                                  parameter))
+                                     method-lambda-list))
+               (defmethod ,m-name ,method-lambda-list
+                 ,(let ((arguments (mapcar
+                                    (lambda (arg)
+                                      (if (eq arg stream-name)
+                                          `(cl-stream-stream ,stream-name)
+                                          arg))
+                                    (make-argument-list lambda-list))))
+                    (if (lambda-list-rest-p lambda-list)
+                        `(apply (function ,cl-name) ,@arguments)
+                        `(,cl-name ,@(butlast arguments)))))
+               ;; We don't want to allow access to CL:STREAM from a sandbox.
+               ;; (defmethod ,m-name
+               ;;     ,(make-method-lambda-list lambda-list stream-name 'cl:stream)
+               ;;   ,(let ((arguments (make-argument-list lambda-list)))
+               ;;         (if (lambda-list-rest-p lambda-list)
+               ;;             `(apply (function ,cl-name) ,@arguments)
+               ;;             `(,cl-name ,@(butlast arguments)))))
+               )))
        ,@(when check-stream-type
-               `((defmethod ,m-name ,(make-method-lambda-list lambda-list stream-name 't)
-                   (signal-type-error ,stream-name ',check-stream-type))))
+           `((defmethod ,m-name ,(make-method-lambda-list lambda-list stream-name 't)
+               (signal-type-error ,stream-name ',check-stream-type))))
        ,@(mapcar
           (lambda (method)
             (when (and (listp method) (eq :method (car method)))
@@ -348,7 +354,6 @@ DO:     Expands to a bunch of defmethod forms, with the parameter
       eof-value))


-
 (define-forward read-byte (stream &optional (eof-error-p t) (eof-value nil))
   (declare (stream-argument stream)
            (check-stream-type stream)
diff --git a/future/vfs/vfs-file-stream.lisp b/future/vfs/vfs-file-stream.lisp
index f26ff17..9169171 100644
--- a/future/vfs/vfs-file-stream.lisp
+++ b/future/vfs/vfs-file-stream.lisp
@@ -64,6 +64,7 @@
   ())


+(defgeneric print-object-fields (self stream))
 (defmethod print-object-fields ((self file-stream) stream)
   (call-next-method)
   (format stream " :PATHNAME ~S :POSITION ~A"
diff --git a/future/vfs/virtual-fs.lisp b/future/vfs/virtual-fs.lisp
index e65c545..81dec7f 100644
--- a/future/vfs/virtual-fs.lisp
+++ b/future/vfs/virtual-fs.lisp
@@ -102,6 +102,7 @@
              (dump v stream (concatenate 'string level *dump-indent*)))
            (entries self)))

+(defgeneric select-entries (self predicate))
 (defmethod select-entries ((self t) predicate)
   (declare (ignorable self predicate))
   '())
@@ -114,9 +115,11 @@
                (when (funcall predicate v) (push v result))) (entries self))
     result))

+(defgeneric entry-name (self))
 (defmethod entry-name ((self fs-directory))
   (name self))

+(defgeneric entry-named (self name))
 (defmethod entry-named ((self t) (name string))
   (error "~A is not a directory" (pathname self)))

@@ -124,6 +127,7 @@
   (gethash name (entries self)))


+(defgeneric entry-at-path (self path))
 (defmethod entry-at-path ((self t) path)
   (declare (ignorable path))
   (error "~S is not a directory" self))
@@ -137,6 +141,7 @@
             (entry-at-path entry (cdr path))))))


+(defgeneric add-entry (self entry))
 (defmethod add-entry ((self fs-directory) (entry fs-item))
   (let ((name (entry-name entry)))
     (if (entry-named self name)
@@ -144,6 +149,7 @@
         (setf (parent entry)                self
               (gethash name (entries self)) entry))))

+(defgeneric remove-entry-named (self name))
 (defmethod remove-entry-named ((self fs-directory) (name string))
   (if (entry-named self name)
       (remhash name (entries self))
@@ -195,10 +201,15 @@
 (defmethod entry-name ((self fs-file))
   (format nil "~A.~A" (name self) (type self)))

+(defgeneric author (self))
+(defgeneric write-date (self))
+(defgeneric element-type (self))
+
 (defmethod author       ((self fs-file)) (author       (newest self)))
 (defmethod write-date   ((self fs-file)) (write-date   (newest self)))
 (defmethod element-type ((self fs-file)) (element-type (newest self)))

+(defgeneric select-versions (self predicate))
 (defmethod select-versions ((self fs-file) predicate)
   (let ((result '()))
     (maphash (lambda (k v)
@@ -281,6 +292,7 @@ DO: Delete only the specified version.
   "The name or identification of the user.")


+(defgeneric create-new-version (self &key element-type))
 (defmethod create-new-version ((self fs-file) &key (element-type 'character))
   "
 DO:     Add a new version to the file.
@@ -288,13 +300,13 @@ RETURN: The FS-FILE.
 "
   (setf (newest self)
         (make-instance 'file-contents
-            :version (1+ (if (null (newest self)) 0 (version (newest self))))
-            :author *author*
-            :write-date (get-universal-time)
-            :element-type element-type
-            :contents (make-array 0 :fill-pointer 0 :adjustable t
-                                  :element-type element-type)
-            :file self))
+                       :version (1+ (if (null (newest self)) 0 (version (newest self))))
+                       :author *author*
+                       :write-date (get-universal-time)
+                       :element-type element-type
+                       :contents (make-array 0 :fill-pointer 0 :adjustable t
+                                               :element-type element-type)
+                       :file self))
   (setf (gethash (version (newest self)) (versions self)) (newest self))
   self)

@@ -352,6 +364,7 @@ RETURN: The FS-FILE.
         (error "There's no file system named ~S" (pathname-host fspath)))))


+(defgeneric create-directories-at-path (self path &optional created))
 (defmethod create-directories-at-path ((self fs-directory) path
                                        &optional created)
   (if (null path)
diff --git a/languages/c11/c11-parser.lisp b/languages/c11/c11-parser.lisp
index 644410e..abb3caf 100644
--- a/languages/c11/c11-parser.lisp
+++ b/languages/c11/c11-parser.lisp
@@ -32,7 +32,7 @@
 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 ;;;;**************************************************************************
 (in-package "COM.INFORMATIMAGO.LANGUAGES.C11.PARSER")
-
+(declaim (declaration stepper))

 (defclass pre-scanned-scanner (buffered-scanner)
   ((tokens :initform '() :initarg :tokens :accessor pre-scanned-tokens)
@@ -1031,6 +1031,8 @@ NOTE:   if the top-of-stack is :typedef then pop it as well as the specifiers.


 (defun check-constant-expression (expression)
+  (declare (ignore expression))
+  #|TODO|#
   (values))

 (defun check-unary (expression)
diff --git a/languages/lua/lua-parser.lisp b/languages/lua/lua-parser.lisp
index a7749f0..d55c5e4 100644
--- a/languages/lua/lua-parser.lisp
+++ b/languages/lua/lua-parser.lisp
@@ -161,6 +161,7 @@
                  (alt (seq prefixexp args)
                       (seq prefixexp ":" Name args)))

+            #-(and)
             (--> callpart
                  (seq (opt (seq ":" name)) args))

diff --git a/lispdoc/gentext.lisp b/lispdoc/gentext.lisp
index 8cb272e..783dbab 100644
--- a/lispdoc/gentext.lisp
+++ b/lispdoc/gentext.lisp
@@ -61,7 +61,8 @@
 (defvar *line-width* 80)

 (defmacro with-doc-output (target &body body)
-  `(let ((*standard-output* (or (documentation-file ,target) t))
+  `(let ((*standard-output* (or (documentation-file ,target)
+                                *standard-output*))
          ;; TODO: add a line-width slot to text-documentation.
          (*line-width*      *print-right-margin*))
      ,@body))
diff --git a/rdp/packages.lisp b/rdp/packages.lisp
index 6bf7e18..7fb2f93 100644
--- a/rdp/packages.lisp
+++ b/rdp/packages.lisp
@@ -52,8 +52,8 @@
            "GRAMMAR-ALL-TERMINALS" "GRAMMAR-ALL-NON-TERMINALS"
            "GRAMMAR-SKIP-SPACES"

-           "FIND-RULE" "TERMINALP" "NON-TERMINAL-P"
-           "FIRST-SET" "FOLLOW-SET" "NULLABLEP"
+           "FIND-RHSES" "FIND-RHS" "TERMINALP" "NON-TERMINAL-P"
+           "FIRSTS-SET" "FOLLOW-SET" "NULLABLEP"
            "SENTENCE-FIRST-SET"

            "CLEAN-RULES"
diff --git a/rdp/rdp-basic-gen.lisp b/rdp/rdp-basic-gen.lisp
index e82832e..b8b4a9f 100644
--- a/rdp/rdp-basic-gen.lisp
+++ b/rdp/rdp-basic-gen.lisp
@@ -190,12 +190,14 @@
 (defparameter *lex* 0)

 (defun first-rhs (grammar item)
-  (first-set grammar item))
+  (firsts-set grammar item))
+
+(defgeneric gen-parsing-statement (target grammar item))

 (defmethod gen-parsing-statement ((target (eql :basic)) grammar item)
   (labels ((es-first-set (extended-sentence)
              (if (atom extended-sentence)
-                 (first-set grammar extended-sentence)
+                 (firsts-set grammar extended-sentence)
                  (ecase (car extended-sentence)
                    ((seq) (loop
                             :with all-firsts = '()
@@ -278,13 +280,12 @@
                              (emit "ENDIF")))))
              (gen (second item))))))))

-
-(defmethod generate-nt-parser ((target (eql :basic)) grammar non-terminal &key (trace nil))
+(defmethod generate-non-terminal-parser-function ((target (eql :basic)) grammar non-terminal &key (trace nil))
   (let ((fname (gen-parse-function-name target grammar non-terminal)))
     `(progn
        (emit "SUB ~A" ',fname)
        ,@(when trace `((emit "PRINT \"> ~A\"" ',(symbol-name fname))))
-       ,(gen-parsing-statement target grammar (find-rule grammar non-terminal))
+       ,(gen-parsing-statement target grammar (find-rhs grammar non-terminal))
        ,@(when trace `((emit "PRINT \"< ~A\"" ',(symbol-name fname))))
        (emit "ENDSUB"))))

diff --git a/rdp/rdp.lisp b/rdp/rdp.lisp
index 793020b..74885bb 100644
--- a/rdp/rdp.lisp
+++ b/rdp/rdp.lisp
@@ -142,6 +142,7 @@ Use (GRAMMAR-NAMED name) to look up a grammar.")
   (setf (gethash (grammar-name grammar) *grammars*) grammar))


+#-sbcl
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (setf (documentation 'seq t) "

@@ -202,8 +203,6 @@ Returns parsed term.
 "))


-
-
 (defgeneric generate-boilerplate (target-language grammar &key trace)
   (:documentation "Generate the boilerplate code needed by the scanner and parser.

@@ -904,6 +903,12 @@ RETURN: the new production set; the new non-terminal set
 ;;; actions := ( <form>* ) .
 ;;; ε is represented as (seq () ('nil))

+
+(defgeneric add-production (grammar non-terminal rhs))
+(defgeneric remove-production (grammar non-terminal rhs))
+(defgeneric eliminate-left-recursion (grammar))
+(defgeneric eliminate-left-recursive-p (grammar))
+
 (defmethod add-production ((grammar grammar) non-terminal rhs)
   (assert (not (terminalp grammar non-terminal)))
   (push (list non-terminal rhs) (grammar-rules grammar))
@@ -945,7 +950,6 @@ RETURN: the new production set; the new non-terminal set
     :finally (compute-all-non-terminals grammar))
   grammar)

-
 (defmethod eliminate-left-recursive-p ((grammar normalized-grammar))
   (error "Not implemented yet."))

@@ -961,6 +965,8 @@ RETURN: the new production set; the new non-terminal set
 (defgeneric gen-scanner-class-name      (target grammar))
 (defgeneric gen-parse-function-name     (target grammar non-terminal))
 (defgeneric generate-parsing-expression (target grammar non-terminal item))
+(defgeneric generate-parsing-sequence (target grammar non-terminal rhs))
+(defgeneric generate-non-terminal-parsing-expression (target grammar non-terminal))

 ;;;------------------------------------------------------------
 ;;; Scanner generator
@@ -1286,7 +1292,6 @@ should be bound for actions.
      (generate-parsing-sequence target grammar non-terminal rhs))
     (t (error "Invalid item ~S found in rule for ~S" rhs non-terminal))))

-
 (defmethod generate-non-terminal-parsing-expression ((target (eql :lisp)) (grammar normalized-grammar) non-terminal)
   (let* ((rhses   (find-rhses grammar non-terminal))
          ;; (firsts  (firsts-set grammar non-terminal))
diff --git a/tools/asdf.lisp b/tools/asdf.lisp
index 670a34c..b4b80ca 100644
--- a/tools/asdf.lisp
+++ b/tools/asdf.lisp
@@ -1,5 +1,5 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
-;;; This is ASDF 3.1.4.20: Another System Definition Facility.
+;;; This is ASDF 3.1.6: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
@@ -2251,7 +2251,9 @@ when merging, making or parsing pathnames")
 where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except
 on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory."
     `(let ((*default-pathname-defaults*
-             ,(or defaults #-(or abcl genera xcl) '*nil-pathname* #+(or abcl genera) '*default-pathname-defaults*)))
+             ,(or defaults
+                  #-(or abcl genera xcl) '*nil-pathname*
+                  #+(or abcl genera xcl) '*default-pathname-defaults*)))
        ,@body)))


@@ -2845,9 +2847,14 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
 ;;; Probing the filesystem
 (with-upgradability ()
   (defun truename* (p)
-    "Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts"
-    ;; avoids both logical-pathname merging and physical resolution issues
-    (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
+    "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
+    (when p
+      (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p))))
+      (values
+       (or (ignore-errors (truename p))
+           ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
+           ;; a trailing directory separator, causes an error on some lisps.
+           #+(or clisp gcl) (if-let (d (ensure-directory-pathname p)) (ignore-errors (truename d)))))))

   (defun safe-file-write-date (pathname)
     "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
@@ -2868,59 +2875,54 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
 probes the filesystem for a file or directory with given pathname.
 If it exists, return its truename is ENSURE-PATHNAME is true,
 or the original (parsed) pathname if it is false (the default)."
-    (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
-      (etypecase p
-        (null nil)
-        (string (probe-file* (parse-namestring p) :truename truename))
-        (pathname
-         (and (not (wild-pathname-p p))
-              (handler-case
-                  (or
-                   #+allegro
-                   (probe-file p :follow-symlinks truename)
-                   #+gcl
-                   (if truename
-                       (truename* p)
-                       (let ((kind (car (si::stat p))))
-                         (when (eq kind :link)
-                           (setf kind (ignore-errors (car (si::stat (truename* p))))))
-                         (ecase kind
-                           ((nil) nil)
-                           ((:file :link)
-                            (cond
-                              ((file-pathname-p p) p)
-                              ((directory-pathname-p p)
-                               (subpathname p (car (last (pathname-directory p)))))))
-                           (:directory (ensure-directory-pathname p)))))
-                   #+clisp
-                   #.(flet ((probe (probe)
-                              `(let ((foundtrue ,probe))
-                                 (cond
-                                   (truename foundtrue)
-                                   (foundtrue p)))))
-                       (let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
-                              (pp (find-symbol* '#:probe-pathname :ext nil))
-                              (resolve (if pp
-                                           `(ignore-errors (,pp p))
-                                           '(or (truename* p)
-                                             (truename* (ignore-errors (ensure-directory-pathname p)))))))
-                         (if fs
-                             `(if truename
-                                  ,resolve
-                                  (and (ignore-errors (,fs p)) p))
-                             (probe resolve))))
-                   #-(or allegro clisp gcl)
-                   (if truename
-                       (probe-file p)
-                       (ignore-errors
-                        (let ((pp (physicalize-pathname p)))
-                          (and
-                           #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
-                           #+(and lispworks unix) (system:get-file-stat pp)
-                           #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
-                           #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
-                           p)))))
-                (file-error () nil)))))))
+    (values
+     (ignore-errors
+      (setf p (funcall 'ensure-pathname p
+                       :namestring :lisp
+                       :ensure-physical t
+                       :ensure-absolute t :defaults 'get-pathname-defaults
+                       :want-non-wild t
+                       :on-error nil))
+      (when p
+        #+allegro
+        (probe-file p :follow-symlinks truename)
+        #+gcl
+        (if truename
+            (truename* p)
+            (let ((kind (car (si::stat p))))
+              (when (eq kind :link)
+                (setf kind (ignore-errors (car (si::stat (truename* p))))))
+              (ecase kind
+                ((nil) nil)
+                ((:file :link)
+                 (cond
+                   ((file-pathname-p p) p)
+                   ((directory-pathname-p p)
+                    (subpathname p (car (last (pathname-directory p)))))))
+                (:directory (ensure-directory-pathname p)))))
+        #+clisp
+        #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
+                 (pp (find-symbol* '#:probe-pathname :ext nil)))
+            `(if truename
+                 ,(if pp
+                      `(values (,pp p))
+                      '(or (truename* p)
+                        (truename* (ignore-errors (ensure-directory-pathname p)))))
+                 ,(cond
+                    (fs `(and (,fs p) p))
+                    (pp `(nth-value 1 (,pp p)))
+                    (t '(or (and (truename* p) p)
+                         (if-let (d (ensure-directory-pathname p))
+                          (and (truename* d) d)))))))
+        #-(or allegro clisp gcl)
+        (if truename
+            (probe-file p)
+            (and
+             #+(or cmu scl) (unix:unix-stat (ext:unix-namestring p))
+             #+(and lispworks unix) (system:get-file-stat p)
+             #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
+             #-(or cmu (and lispworks unix) sbcl scl) (file-write-date p)
+             p))))))

   (defun directory-exists-p (x)
     "Is X the name of a directory that exists on the filesystem?"
@@ -3325,15 +3327,19 @@ NILs."
   (defun lisp-implementation-directory (&key truename)
     "Where are the system files of the current installation of the CL implementation?"
     (declare (ignorable truename))
-    #+(or clasp clozure ecl gcl mkcl sbcl)
     (let ((dir
-            (ignore-errors
-             #+clozure #p"ccl:"
-             #+(or clasp ecl mkcl) #p"SYS:"
-             #+gcl system::*system-directory*
-             #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
-                      (funcall it)
-                      (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
+            #+abcl extensions:*lisp-home*
+            #+(or allegro clasp ecl mkcl) #p"SYS:"
+            ;;#+clisp custom:*lib-directory* ; causes failure in asdf-pathname-test(!)
+            #+clozure #p"ccl:"
+            #+cmu (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:")))
+            #+gcl system::*system-directory*
+            #+lispworks lispworks:*lispworks-directory*
+            #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
+                     (funcall it)
+                     (getenv-pathname "SBCL_HOME" :ensure-directory t))
+            #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/")))
+            #+xcl ext:*xcl-home*))
       (if (and dir truename)
           (truename* dir)
           dir)))
@@ -4031,15 +4037,17 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e
     (check-type direction (member :output :io))
     (assert (or want-stream-p want-pathname-p))
     (loop
-      :with prefix = (native-namestring
-                      (ensure-absolute-pathname
-                       (or prefix "tmp")
-                       (or (ensure-pathname directory :namestring :native :ensure-directory t)
-                           #'temporary-directory)))
-      :with results = ()
+      :with prefix-pn = (ensure-absolute-pathname
+                         (or prefix "tmp")
+                         (or (ensure-pathname directory :namestring :native :ensure-directory t)
+                             #'temporary-directory))
+      :with prefix-nns = (native-namestring prefix-pn)
+      :with results = (progn (ensure-directories-exist prefix-pn)
+                             ())
       :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
       :for pathname = (parse-native-namestring
-                       (format nil "~A~36R~@[~A~]~@[.~A~]" prefix counter suffix type))
+                       (format nil "~A~36R~@[~A~]~@[.~A~]"
+                               prefix-nns counter suffix (unless (eq type :unspecific) type)))
       :for okp = nil :do
         ;; TODO: on Unix, do something about umask
         ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
@@ -4048,6 +4056,7 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e
         ;; Can we at least design some hook?
         (unwind-protect
              (progn
+               (ensure-directories-exist pathname)
                (with-open-file (stream pathname
                                        :direction direction
                                        :element-type element-type
@@ -4127,8 +4136,13 @@ Further KEYS can be passed to MAKE-PATHNAME."
                           :defaults pathname keys))

   (defun tmpize-pathname (x)
-    "Return a new pathname modified from X by adding a trivial deterministic suffix"
-    (add-pathname-suffix x "-TMP"))
+    "Return a new pathname modified from X by adding a trivial random suffix.
+A new empty file with said temporary pathname is created, to ensure there is no
+clash with any concurrent process attempting the same thing."
+    (let* ((px (ensure-pathname x))
+           (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp"))
+           (directory (translate-logical-pathname (pathname-directory-pathname px))))
+      (get-temporary-file :directory directory :prefix prefix :type (pathname-type px))))

   (defun call-with-staging-pathname (pathname fun)
     "Calls FUN with a staging pathname, and atomically
@@ -4146,7 +4160,6 @@ For the latter case, we ought pick a random suffix and atomically open it."
   (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
     "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
     `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
-
 ;;;; -------------------------------------------------------------------------
 ;;;; Starting, Stopping, Dumping a Lisp image

@@ -4291,9 +4304,7 @@ This is designed to abstract away the implementation specific quit forms."
           (dbg:*debug-print-length* *print-length*))
       (dbg:bug-backtrace nil))
     #+sbcl
-    (sb-debug:backtrace
-     #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
-     stream)
+    (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum))
     #+xcl
     (loop :for i :from 0 :below (or count most-positive-fixnum)
           :for frame :in (extensions:backtrace-as-list) :do
@@ -4654,9 +4665,9 @@ as either a recognizing function or a sequence of characters."
      (cond
        ((and good-chars bad-chars)
         (error "only one of good-chars and bad-chars can be provided"))
-       ((functionp good-chars)
+       ((typep good-chars 'function)
         (complement good-chars))
-       ((functionp bad-chars)
+       ((typep bad-chars 'function)
         bad-chars)
        ((and good-chars (typep good-chars 'sequence))
         #'(lambda (c) (not (find c good-chars))))
@@ -4699,10 +4710,14 @@ for use within a MS Windows command-line, outputing to S."
             (otherwise
              (issue (char x i)) (setf i i+1))))))

+  (defun easy-windows-character-p (x)
+    "Is X an \"easy\" character that does not require quoting by the shell?"
+    (or (alphanumericp x) (find x "+-_.,@:/=")))
+
   (defun escape-windows-token (token &optional s)
     "Escape a string TOKEN within double-quotes if needed
 for use within a MS Windows command-line, outputing to S."
-    (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
+    (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
                         :escaper 'escape-windows-token-within-double-quotes))

   (defun escape-sh-token-within-double-quotes (x s &key (quote t))
@@ -4717,7 +4732,7 @@ omit the outer double-quotes if key argument :QUOTE is NIL"

   (defun easy-sh-character-p (x)
     "Is X an \"easy\" character that does not require quoting by the shell?"
-    (or (alphanumericp x) (find x "+-_.,%@:/")))
+    (or (alphanumericp x) (find x "+-_.,%@:/=")))

   (defun escape-sh-token (token &optional s)
     "Escape a string TOKEN within double-quotes if needed
@@ -5042,73 +5057,62 @@ INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer,
 to be normalized by %NORMALIZE-IO-SPECIFIER.
 It returns a process-info plist with possible keys:
      PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
-    ;; NB: these implementations have unix vs windows set at compile-time.
+    ;; NB: these implementations have Unix vs Windows set at compile-time.
     (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists))
     (assert (not (and wait (member :stream (list input output error-output)))))
-    #-(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl)
+    #-(or allegro clasp clisp clozure cmu ecl (and lispworks os-unix) mkcl sbcl scl)
     (progn command keys directory
            (error "run-program not available"))
-    #+(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl)
+    #+(or allegro clasp clisp clozure cmu ecl (and lispworks os-unix) mkcl sbcl scl)
     (let* ((%command (%normalize-command command))
            (%input (%normalize-io-specifier input :input))
            (%output (%normalize-io-specifier output :output))
            (%error-output (%normalize-io-specifier error-output :error-output))
-           #+(and allegro os-windows) (interactive (%interactivep input output error-output))
+           #+(and allegro os-windows)
+           (interactive (%interactivep input output error-output))
            (process*
-             #+allegro
-             (multiple-value-list
+             (nest
+              #+clisp (progn
+                        ;; clisp cannot redirect stderr, so check we don't.
+                        ;; Also, since we now always return a code, we cannot use this code path
+                        ;; if any of the input, output or error-output is :stream.
+                        (assert (eq %error-output :terminal)))
+              #-(or allegro mkcl sbcl) (with-current-directory (directory))
+              #+(or allegro clasp clisp ecl lispworks mkcl) (multiple-value-list)
               (apply
-               'excl:run-shell-command
-               #+os-unix (coerce (cons (first %command) %command) 'vector)
-               #+os-windows %command
-               :input %input
-               :output %output
-               :error-output %error-output
-               :directory directory :wait wait
-               #+os-windows :show-window #+os-windows (if interactive nil :hide)
-               :allow-other-keys t keys))
-             #-allegro
-             (with-current-directory (#-(or sbcl mkcl) directory)
+               #+allegro 'excl:run-shell-command
+               #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector)
+               #+(and allegro os-windows) %command
                #+clisp
-               (flet ((run (f x &rest args)
-                        (multiple-value-list
-                         (apply f x :input %input :output %output
-                                    :allow-other-keys t `(,@args ,@keys)))))
-                 (assert (eq %error-output :terminal))
-                 ;;; since we now always return a code, we can't use this code path, anyway!
-                 (etypecase %command
-                   #+os-windows (string (run 'ext:run-shell-command %command))
-                   (list (run 'ext:run-program (car %command)
-                              :arguments (cdr %command)))))
-               #+(or clasp clozure cmu ecl mkcl sbcl scl)
-               (#-(or clasp ecl mkcl) progn #+(or clasp ecl mkcl) multiple-value-list
-                (apply
-                 '#+(or cmu ecl scl) ext:run-program
-                 #+clozure ccl:run-program #+sbcl sb-ext:run-program #+mkcl mk-ext:run-program
-                 (car %command) (cdr %command)
-                 :input %input
-                 :output %output
-                 :error %error-output
-                 :wait wait
-                 :allow-other-keys t
-                 (append
-                  #+(or clozure cmu mkcl sbcl scl)
-                  `(:if-input-does-not-exist ,if-input-does-not-exist
-                    :if-output-exists ,if-output-exists
-                    :if-error-exists ,if-error-output-exists)
-                  #+sbcl `(:search t
-                           :if-output-does-not-exist :create
-                           :if-error-does-not-exist :create)
-                  #-sbcl keys #+sbcl (if directory keys (remove-plist-key :directory keys)))))
-               #+(and lispworks os-unix) ;; note: only used on Unix in non-interactive case
-               (multiple-value-list
-                (apply
-                 'system:run-shell-command
-                 (cons "/usr/bin/env" %command) ; lispworks wants a full path.
-                 :input %input :if-input-does-not-exist if-input-does-not-exist
-                 :output %output :if-output-exists if-output-exists
-                 :error-output %error-output :if-error-output-exists if-error-output-exists
-                 :wait wait :save-exit-status t :allow-other-keys t keys))))
+               (etypecase %command
+                 #+os-windows
+                 (string (lambda (&rest keys) (apply 'ext:run-shell-command %command keys)))
+                 (list (lambda (&rest keys)
+                         (apply 'ext:run-program (car %command) :arguments (cdr %command) keys))))
+               #+clozure 'ccl:run-program
+               #+(or cmu ecl scl) 'ext:run-program
+               #+lispworks 'system:run-shell-command
+               #+lispworks (cons "/usr/bin/env" %command) ; LW wants a full path
+               #+mkcl 'mk-ext:run-program
+               #+sbcl 'sb-ext:run-program
+               (append
+                #+(or clozure cmu ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command))
+                `(:input ,%input :output ,%output :wait ,wait :allow-other-keys t)
+                #-clisp `(#+(or allegro lispworks) :error-output #-(or allegro lispworks) :error
+                            ,%error-output)
+                #+(and allegro os-windows) `(:show-window ,(if interactive nil :hide))
+                #+(or clozure cmu ecl lispworks mkcl sbcl scl)
+                `(:if-input-does-not-exist ,if-input-does-not-exist
+                  :if-output-exists ,if-output-exists
+                  #-lispworks :if-error-exists #+lispworks :if-error-output-exists
+                  ,if-error-output-exists)
+                #+lispworks `(:save-exit-status t)
+                #+sbcl `(:search t
+                         :if-output-does-not-exist :create
+                         :if-error-does-not-exist :create)
+                #+mkcl `(:directory ,(native-namestring directory))
+                #-sbcl keys
+                #+sbcl (if directory keys (remove-plist-key :directory keys))))))
            (process-info-r ()))
       (flet ((prop (key value) (push key process-info-r) (push value process-info-r)))
         #+allegro
@@ -5139,8 +5143,8 @@ It returns a process-info plist with possible keys:
              (1 (prop :input-stream (first process*)))
              (2 (prop :output-stream (first process*)))
              (3 (prop :bidir-stream (pop process*))
-                (prop :input-stream (pop process*))
-                (prop :output-stream (pop process*))))))
+              (prop :input-stream (pop process*))
+              (prop :output-stream (pop process*))))))
         #+(or clozure cmu sbcl scl)
         (progn
           (prop :process process*)
@@ -5198,13 +5202,12 @@ It returns a process-info plist with possible keys:
             ;; 1- wait
             #+clozure (ccl::external-process-wait process)
             #+(or cmu scl) (ext:process-wait process)
-            #+(and (or clasp ecl) os-unix) (ext:external-process-wait process)
             #+sbcl (sb-ext:process-wait process)
             ;; 2- extract result
             #+allegro (sys:reap-os-subprocess :pid process :wait t)
             #+clozure (nth-value 1 (ccl:external-process-status process))
             #+(or cmu scl) (ext:process-exit-code process)
-            #+(or clasp ecl) (nth-value 1 (ext:external-process-status process))
+            #+(or clasp ecl) (nth-value 1 (ext:external-process-wait process t))
             #+lispworks
             (if-let ((stream (or (getf process-info :input-stream)
                                  (getf process-info :output-stream)
@@ -5469,7 +5472,9 @@ It returns a process-info plist with possible keys:
                       &allow-other-keys)
     "Run program specified by COMMAND,
 either a list of strings specifying a program and list of arguments,
-or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
+or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
+_synchronously_ process its output as specified and return the processing results
+when the program and its output processing are complete.

 Always call a shell (rather than directly execute the command when possible)
 if FORCE-SHELL is specified.  Similarly, never call a shell if FORCE-SHELL is
@@ -5525,11 +5530,15 @@ or an indication of failure via the EXIT-CODE of the process"
     ;; don't override user's specified preference. [2015/06/29:rpg]
     (when (stringp command)
       (unless force-shell-suppliedp
+        #-(and sbcl os-windows) ;; force-shell t isn't working properly on windows as of sbcl 1.2.16
         (setf force-shell t)))
     (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
       (apply (if (or force-shell
-                     #+(or clasp clisp ecl) (or (not ignore-error-status) t)
+                     #+(or clasp clisp) (or (not ignore-error-status) t)
                      #+clisp (member error-output '(:interactive :output))
+                     ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
+                     #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
+                               (lexicographic<= '< ver '(16 0 1)))
                      #+(and lispworks os-unix) (%interactivep input output error-output)
                      #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
                  '%use-system '%use-run-program)
@@ -5540,7 +5549,7 @@ or an indication of failure via the EXIT-CODE of the process"
              :if-output-exists if-output-exists
              :if-error-output-exists if-error-output-exists
              :element-type element-type :external-format external-format
-           keys))))
+             keys))))
 ;;;; -------------------------------------------------------------------------
 ;;;; Support to build (compile and load) Lisp files

@@ -6215,8 +6224,7 @@ it will filter them appropriately."
              (unless (use-ecl-byte-compiler-p)
                (or object-file
                    #+ecl(compile-file-pathname output-file :type :object)
-                   #+clasp (compile-file-pathname output-file :output-type :object)
-                   )))
+                   #+clasp (compile-file-pathname output-file :output-type :object))))
            #+mkcl
            (object-file
              (or object-file
@@ -6329,7 +6337,7 @@ it will filter them appropriately."
                       :members
                       ,(loop :for f :in (reverse fasls)
                              :collect `(,(namestring f) :load-only t))))
-             (scm:concatenate-system output :fasls-to-concatenate))
+             (scm:concatenate-system output :fasls-to-concatenate :force t))
         (loop :for f :in fasls :do (ignore-errors (delete-file f)))
         (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))
 ;;;; ---------------------------------------------------------------------------
@@ -6679,7 +6687,7 @@ also \"Configuration DSL\"\) in the ASDF manual."
     (resolve-absolute-location
      `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
             (os-cond
-             ((os-windows-p) (xdg-data-home "cache"))
+             ((os-windows-p) (xdg-data-home "cache/"))
              (t (subpathname* (user-homedir-pathname) ".cache/"))))
        ,more)))

@@ -6904,7 +6912,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.4.20")
+         (asdf-version "3.1.6")
          (existing-version (asdf-version)))
     (setf *asdf-version* asdf-version)
     (when (and existing-version (not (equal asdf-version existing-version)))
@@ -6989,87 +6997,6 @@ previously-loaded version of ASDF."
   (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration))

 ;;;; -------------------------------------------------------------------------
-;;;; Stamp cache
-
-(uiop/package:define-package :asdf/cache
-  (: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*
-           #:clear-configuration-and-retry #:retry))
-(in-package :asdf/cache)
-
-;;; This stamp cache is useful for:
-;; * consistency of stamps used within a single run
-;; * fewer accesses to the filesystem
-;; * the ability to test with fake timestamps, without touching files
-
-(with-upgradability ()
-  (defvar *asdf-cache* nil)
-
-  (defun set-asdf-cache-entry (key value-list)
-    (apply 'values
-           (if *asdf-cache*
-               (setf (gethash key *asdf-cache*) value-list)
-               value-list)))
-
-  (defun unset-asdf-cache-entry (key)
-    (when *asdf-cache*
-      (remhash key *asdf-cache*)))
-
-  (defun consult-asdf-cache (key &optional thunk)
-    (if *asdf-cache*
-        (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
-          (if foundp
-              (apply 'values results)
-              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
-        (call-function thunk)))
-
-  (defmacro do-asdf-cache (key &body body)
-    `(consult-asdf-cache ,key #'(lambda () ,@body)))
-
-  (defun call-with-asdf-cache (thunk &key override key)
-    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
-      (if (and *asdf-cache* (not override))
-          (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))
-
-  (defun normalize-namestring (pathname)
-    (let ((resolved (resolve-symlinks*
-                     (ensure-absolute-pathname
-                      (physicalize-pathname pathname)
-                      'get-pathname-defaults))))
-      (with-pathname-defaults () (namestring resolved))))
-
-  (defun compute-file-stamp (normalized-namestring)
-    (with-pathname-defaults ()
-      (safe-file-write-date normalized-namestring)))
-
-  (defun register-file-stamp (file &optional (stamp nil stampp))
-    (let* ((namestring (normalize-namestring file))
-           (stamp (if stampp stamp (compute-file-stamp namestring))))
-      (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
-
-  (defun get-file-stamp (file)
-    (when file
-      (let ((namestring (normalize-namestring file)))
-        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
-
-;;;; -------------------------------------------------------------------------
 ;;;; Components

 (uiop/package:define-package :asdf/component
@@ -7301,8 +7228,8 @@ children.")))

   (defmethod component-relative-pathname ((component component))
     ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
-    ;; We ought to be able to extract this from the component alone with COMPONENT-TYPE.
-    ;; TODO: track who uses it, and have them not use it anymore;
+    ;; We ought to be able to extract this from the component alone with FILE-TYPE.
+    ;; TODO: track who uses it in Quicklisp, and have them not use it anymore;
     ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge?
     (parse-unix-namestring
      (or (and (slot-boundp component 'relative-pathname)
@@ -7484,6 +7411,87 @@ in which the system specification (.asd file) is located."
     nil))

 ;;;; -------------------------------------------------------------------------
+;;;; Stamp cache
+
+(uiop/package:define-package :asdf/cache
+  (: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*
+           #:clear-configuration-and-retry #:retry))
+(in-package :asdf/cache)
+
+;;; This stamp cache is useful for:
+;; * consistency of stamps used within a single run
+;; * fewer accesses to the filesystem
+;; * the ability to test with fake timestamps, without touching files
+
+(with-upgradability ()
+  (defvar *asdf-cache* nil)
+
+  (defun set-asdf-cache-entry (key value-list)
+    (apply 'values
+           (if *asdf-cache*
+               (setf (gethash key *asdf-cache*) value-list)
+               value-list)))
+
+  (defun unset-asdf-cache-entry (key)
+    (when *asdf-cache*
+      (remhash key *asdf-cache*)))
+
+  (defun consult-asdf-cache (key &optional thunk)
+    (if *asdf-cache*
+        (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
+          (if foundp
+              (apply 'values results)
+              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
+        (call-function thunk)))
+
+  (defmacro do-asdf-cache (key &body body)
+    `(consult-asdf-cache ,key #'(lambda () ,@body)))
+
+  (defun call-with-asdf-cache (thunk &key override key)
+    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
+      (if (and *asdf-cache* (not override))
+          (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))
+
+  (defun normalize-namestring (pathname)
+    (let ((resolved (resolve-symlinks*
+                     (ensure-absolute-pathname
+                      (physicalize-pathname pathname)
+                      'get-pathname-defaults))))
+      (with-pathname-defaults () (namestring resolved))))
+
+  (defun compute-file-stamp (normalized-namestring)
+    (with-pathname-defaults ()
+      (safe-file-write-date normalized-namestring)))
+
+  (defun register-file-stamp (file &optional (stamp nil stampp))
+    (let* ((namestring (normalize-namestring file))
+           (stamp (if stampp stamp (compute-file-stamp namestring))))
+      (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
+
+  (defun get-file-stamp (file)
+    (when file
+      (let ((namestring (normalize-namestring file)))
+        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
+
+;;;; -------------------------------------------------------------------------
 ;;;; Finding systems

 (uiop/package:define-package :asdf/find-system
@@ -7503,7 +7511,8 @@ in which the system specification (.asd file) is located."
    #:find-system-if-being-defined
    #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
    #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
-   #:*defined-systems* #:clear-defined-systems #:*immutable-systems* #:register-immutable-system
+   #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems*
+   #:*defined-systems* #:clear-defined-systems
    ;; defined in source-registry, but specially mentioned here:
    #:initialize-source-registry #:sysdef-source-registry-search))
 (in-package :asdf/find-system)
@@ -8610,7 +8619,13 @@ in some previous image, or T if it needs to be done.")
                &optional
                  #+(or clasp ecl mkcl) object-file
                  #+clisp lib-file
-                 warnings-file) outputs
+                 warnings-file &rest rest) outputs
+            ;; Allow for extra outputs that are not of type warnings-file
+            ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional.
+            (declare (ignore rest))
+            (when warnings-file
+              (unless (equal (pathname-type warnings-file) (warnings-file-type))
+                (setf warnings-file nil)))
             (call-with-around-compile-hook
              c #'(lambda (&rest flags)
                    (apply 'compile-file* input-file
@@ -8967,7 +8982,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
             (latest-in (stamps-latest (cons dep-stamp in-stamps))))
        (when (and missing-in (not just-done)) (return (values t nil))))
      ;; collect timestamps from outputs, and exit early if any is missing
-     (let* ((out-files (output-files o c))
+     (let* ((out-files (remove-if 'null (output-files o c)))
             (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
             (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
             (earliest-out (stamps-earliest out-stamps)))
@@ -9470,1613 +9485,1644 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
   (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))


-;;;; -------------------------------------------------------------------------
-;;;; Defsystem
+;;;; ---------------------------------------------------------------------------
+;;;; asdf-output-translations

-(uiop/package:define-package :asdf/parse-defsystem
-  (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
-  (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
-  (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
-   :asdf/cache :asdf/component :asdf/system
-   :asdf/find-system :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate)
-  (:import-from :asdf/system #:depends-on #:weakly-depends-on)
+(uiop/package:define-package :asdf/output-translations
+  (:recycle :asdf/output-translations :asdf)
+  (:use :uiop/common-lisp :uiop :asdf/upgrade)
   (:export
-   #:defsystem #:register-system-definition
-   #:class-for-type #:*default-component-class*
-   #:determine-system-directory #:parse-component-form
-   #:non-toplevel-system #:non-system-system
-   #:sysdef-error-component #:check-component-input))
-(in-package :asdf/parse-defsystem)
-
-;;; Pathname
-(with-upgradability ()
-  (defun determine-system-directory (pathname)
-    ;; The defsystem macro calls this function to determine
-    ;; the pathname of a system as follows:
-    ;; 1. if the pathname argument is an pathname object (NOT a namestring),
-    ;;    that is already an absolute pathname, return it.
-    ;; 2. otherwise, the directory containing the LOAD-PATHNAME
-    ;;    is considered (as deduced from e.g. *LOAD-PATHNAME*), and
-    ;;    if it is indeed available and an absolute pathname, then
-    ;;    the PATHNAME argument is normalized to a relative pathname
-    ;;    as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
-    ;;    and merged into that DIRECTORY as per SUBPATHNAME.
-    ;;    Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
-    ;;    and may be from within the EVAL-WHEN of a file compilation.
-    ;; If no absolute pathname was found, we return NIL.
-    (check-type pathname (or null string pathname))
-    (pathname-directory-pathname
-     (resolve-symlinks*
-      (ensure-absolute-pathname
-       (parse-unix-namestring pathname :type :directory)
-       #'(lambda () (ensure-absolute-pathname
-                     (load-pathname) 'get-pathname-defaults nil))
-       nil)))))
+   #:*output-translations* #:*output-translations-parameter*
+   #:invalid-output-translation
+   #:output-translations #:output-translations-initialized-p
+   #:initialize-output-translations #:clear-output-translations
+   #:disable-output-translations #:ensure-output-translations
+   #:apply-output-translations
+   #:validate-output-translations-directive #:validate-output-translations-form
+   #:validate-output-translations-file #:validate-output-translations-directory
+   #:parse-output-translations-string #:wrapping-output-translations
+   #:user-output-translations-pathname #:system-output-translations-pathname
+   #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
+   #:environment-output-translations #:process-output-translations
+   #:compute-output-translations
+   #+abcl #:translate-jar-pathname
+   ))
+(in-package :asdf/output-translations)

+(when-upgrading () (undefine-function '(setf output-translations)))

-;;; Component class
 (with-upgradability ()
-  (defvar *default-component-class* 'cl-source-file)
+  (define-condition invalid-output-translation (invalid-configuration warning)
+    ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))

-  (defun class-for-type (parent type)
-      (or (coerce-class type :package :asdf/interface :super 'component :error nil)
-          (and (eq type :file)
-               (coerce-class
-                (or (loop :for p = parent :then (component-parent p) :while p
-                            :thereis (module-default-component-class p))
-                    *default-component-class*)
-                :package :asdf/interface :super 'component :error nil))
-          (sysdef-error "don't recognize component type ~S" type))))
+  (defvar *output-translations* ()
+    "Either NIL (for uninitialized), or a list of one element,
+said element itself being a sorted list of mappings.
+Each mapping is a pair of a source pathname and destination pathname,
+and the order is by decreasing length of namestring of the source pathname.")

+  (defun output-translations ()
+    (car *output-translations*))

-;;; Check inputs
-(with-upgradability ()
-  (define-condition non-system-system (system-definition-error)
-    ((name :initarg :name :reader non-system-system-name)
-     (class-name :initarg :class-name :reader non-system-system-class-name))
-    (:report (lambda (c s)
-               (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
-                       (non-system-system-name c) (non-system-system-class-name c) 'system))))
+  (defun set-output-translations (new-value)
+    (setf *output-translations*
+          (list
+           (stable-sort (copy-list new-value) #'>
+                        :key #'(lambda (x)
+                                 (etypecase (car x)
+                                   ((eql t) -1)
+                                   (pathname
+                                    (let ((directory (pathname-directory (car x))))
+                                      (if (listp directory) (length directory) 0))))))))
+    new-value)
+  (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))

-  (define-condition non-toplevel-system (system-definition-error)
-    ((parent :initarg :parent :reader non-toplevel-system-parent)
-     (name :initarg :name :reader non-toplevel-system-name))
-    (:report (lambda (c s)
-               (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
-                       (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
+  (defun output-translations-initialized-p ()
+    (and *output-translations* t))

-  (defun sysdef-error-component (msg type name value)
-    (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
-                  type name value))
+  (defun clear-output-translations ()
+    "Undoes any initialization of the output translations."
+    (setf *output-translations* '())
+    (values))
+  (register-clear-configuration-hook 'clear-output-translations)

-  (defun check-component-input (type name weakly-depends-on
-                                depends-on components)
-    "A partial test of the values of a component."
-    (unless (listp depends-on)
-      (sysdef-error-component ":depends-on must be a list."
-                              type name depends-on))
-    (unless (listp weakly-depends-on)
-      (sysdef-error-component ":weakly-depends-on must be a list."
-                              type name weakly-depends-on))
-    (unless (listp components)
-      (sysdef-error-component ":components must be NIL or a list of components."
-                              type name components)))
+  (defun validate-output-translations-directive (directive)
+    (or (member directive '(:enable-user-cache :disable-cache nil))
+        (and (consp directive)
+             (or (and (length=n-p directive 2)
+                      (or (and (eq (first directive) :include)
+                               (typep (second directive) '(or string pathname null)))
+                          (and (location-designator-p (first directive))
+                               (or (location-designator-p (second directive))
+                                   (location-function-p (second directive))))))
+                 (and (length=n-p directive 1)
+                      (location-designator-p (first directive)))))))

-  (defun* (normalize-version) (form &key pathname component parent)
-    (labels ((invalid (&optional (continuation "using NIL instead"))
-               (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
-                     form component parent pathname continuation))
-             (invalid-parse (control &rest args)
-               (unless (if-let (target (find-component parent component)) (builtin-system-p target))
-                 (apply 'warn control args)
-                 (invalid))))
-      (if-let (v (typecase form
-                   ((or string null) form)
-                   (real
-                    (invalid "Substituting a string")
-                    (format nil "~D" form)) ;; 1.0 becomes "1.0"
-                   (cons
-                    (case (first form)
-                      ((:read-file-form)
-                       (destructuring-bind (subpath &key (at 0)) (rest form)
-                         (safe-read-file-form (subpathname pathname subpath)
-                                              :at at :package :asdf-user)))
-                      ((:read-file-line)
-                       (destructuring-bind (subpath &key (at 0)) (rest form)
-                         (safe-read-file-line (subpathname pathname subpath)
-                                              :at at)))
-                      (otherwise
-                       (invalid))))
-                   (t
-                    (invalid))))
-        (if-let (pv (parse-version v #'invalid-parse))
-          (unparse-version pv)
-          (invalid))))))
+  (defun validate-output-translations-form (form &key location)
+    (validate-configuration-form
+     form
+     :output-translations
+     'validate-output-translations-directive
+     :location location :invalid-form-reporter 'invalid-output-translation))

+  (defun validate-output-translations-file (file)
+    (validate-configuration-file
+     file 'validate-output-translations-form :description "output translations"))

-;;; "inline methods"
-(with-upgradability ()
-  (defparameter* +asdf-methods+
-    '(perform-with-restarts perform explain output-files operation-done-p))
+  (defun validate-output-translations-directory (directory)
+    (validate-configuration-directory
+     directory :output-translations 'validate-output-translations-directive
+               :invalid-form-reporter 'invalid-output-translation))

-  (defun %remove-component-inline-methods (component)
-    (dolist (name +asdf-methods+)
-      (map ()
-           ;; this is inefficient as most of the stored
-           ;; methods will not be for this particular gf
-           ;; But this is hardly performance-critical
-           #'(lambda (m)
-               (remove-method (symbol-function name) m))
-           (component-inline-methods component)))
-    (component-inline-methods component) nil)
+  (defun parse-output-translations-string (string &key location)
+    (cond
+      ((or (null string) (equal string ""))
+       '(:output-translations :inherit-configuration))
+      ((not (stringp string))
+       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
+      ((eql (char string 0) #\")
+       (parse-output-translations-string (read-from-string string) :location location))
+      ((eql (char string 0) #\()
+       (validate-output-translations-form (read-from-string string) :location location))
+      (t
+       (loop
+         :with inherit = nil
+         :with directives = ()
+         :with start = 0
+         :with end = (length string)
+         :with source = nil
+         :with separator = (inter-directory-separator)
+         :for i = (or (position separator string :start start) end) :do
+           (let ((s (subseq string start i)))
+             (cond
+               (source
+                (push (list source (if (equal "" s) nil s)) directives)
+                (setf source nil))
+               ((equal "" s)
+                (when inherit
+                  (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+                         string))
+                (setf inherit t)
+                (push :inherit-configuration directives))
+               (t
+                (setf source s)))
+             (setf start (1+ i))
+             (when (> start end)
+               (when source
+                 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
+                        string))
+               (unless inherit
+                 (push :ignore-inherited-configuration directives))
+               (return `(:output-translations ,@(nreverse directives)))))))))

-  (defun %define-component-inline-methods (ret rest)
-    (loop* :for (key value) :on rest :by #'cddr
-           :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
-           :when name :do
-           (destructuring-bind (op &rest body) value
-             (loop :for arg = (pop body)
-                   :while (atom arg)
-                   :collect arg :into qualifiers
-                   :finally
-                      (destructuring-bind (o c) arg
-                        (pushnew
-                         (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
-                         (component-inline-methods ret)))))))
+  (defparameter* *default-output-translations*
+    '(environment-output-translations
+      user-output-translations-pathname
+      user-output-translations-directory-pathname
+      system-output-translations-pathname
+      system-output-translations-directory-pathname))

-  (defun %refresh-component-inline-methods (component rest)
-    ;; clear methods, then add the new ones
-    (%remove-component-inline-methods component)
-    (%define-component-inline-methods component rest)))
+  (defun wrapping-output-translations ()
+    `(:output-translations
+    ;; Some implementations have precompiled ASDF systems,
+    ;; so we must disable translations for implementation paths.
+      #+(or clasp #|clozure|# ecl mkcl sbcl)
+      ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
+          (when h `(((,h ,*wild-path*) ()))))
+      #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
+      ;; All-import, here is where we want user stuff to be:
+      :inherit-configuration
+      ;; These are for convenience, and can be overridden by the user:
+      #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
+      #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
+      ;; We enable the user cache by default, and here is the place we do:
+      :enable-user-cache))

+  (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
+  (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))

-;;; Main parsing function
-(with-upgradability ()
-  (defun* parse-dependency-def (dd)
-    (if (listp dd)
-        (case (first dd)
-          (:feature
-           (unless (= (length dd) 3)
-             (sysdef-error "Ill-formed feature dependency: ~s" dd))
-           (let ((embedded (parse-dependency-def (third dd))))
-             `(:feature ,(second dd) ,embedded)))
-          (feature
-           (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd))
-          (:require
-           (unless (= (length dd) 2)
-             (sysdef-error "Ill-formed require dependency: ~s" dd))
-           dd)
-          (:version
-           (unless (= (length dd) 3)
-             (sysdef-error "Ill-formed version dependency: ~s" dd))
-           `(:version ,(coerce-name (second dd)) ,(third dd)))
-          (otherwise (sysdef-error "Ill-formed dependency: ~s" dd)))
-      (coerce-name dd)))
+  (defun user-output-translations-pathname (&key (direction :input))
+    (xdg-config-pathname *output-translations-file* direction))
+  (defun system-output-translations-pathname (&key (direction :input))
+    (find-preferred-file (system-config-pathnames *output-translations-file*)
+                         :direction direction))
+  (defun user-output-translations-directory-pathname (&key (direction :input))
+    (xdg-config-pathname *output-translations-directory* direction))
+  (defun system-output-translations-directory-pathname (&key (direction :input))
+    (find-preferred-file (system-config-pathnames *output-translations-directory*)
+                         :direction direction))
+  (defun environment-output-translations ()
+    (getenv "ASDF_OUTPUT_TRANSLATIONS"))

-  (defun* parse-dependency-defs (dd-list)
-    "Parse the dependency defs in DD-LIST into canonical form by translating all
-system names contained using COERCE-NAME. Return the result."
-    (mapcar 'parse-dependency-def dd-list))
+  (defgeneric process-output-translations (spec &key inherit collect))

-  (defun* (parse-component-form) (parent options &key previous-serial-component)
-    (destructuring-bind
-        (type name &rest rest &key
-                                (builtin-system-p () bspp)
-                                ;; the following list of keywords is reproduced below in the
-                                ;; remove-plist-keys form.  important to keep them in sync
-                                components pathname perform explain output-files operation-done-p
-                                weakly-depends-on depends-on serial
-                                do-first if-component-dep-fails version
-                                ;; list ends
-         &allow-other-keys) options
-      (declare (ignore perform explain output-files operation-done-p builtin-system-p))
-      (check-component-input type name weakly-depends-on depends-on components)
-      (when (and parent
-                 (find-component parent name)
-                 (not ;; ignore the same object when rereading the defsystem
-                  (typep (find-component parent name)
-                         (class-for-type parent type))))
-        (error 'duplicate-names :name name))
-      (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
-      (let* ((name (coerce-name name))
-             (args `(:name ,name
-                     :pathname ,pathname
-                     ,@(when parent `(:parent ,parent))
-                     ,@(remove-plist-keys
-                        '(:components :pathname :if-component-dep-fails :version
-                          :perform :explain :output-files :operation-done-p
-                          :weakly-depends-on :depends-on :serial)
-                        rest)))
-             (component (find-component parent name))
-             (class (class-for-type parent type)))
-        (when (and parent (subtypep class 'system))
-          (error 'non-toplevel-system :parent parent :name name))
-        (if component ; preserve identity
-            (apply 'reinitialize-instance component args)
-            (setf component (apply 'make-instance class args)))
-        (component-pathname component) ; eagerly compute the absolute pathname
-        (when (typep component 'system)
-          ;; cache information for introspection
-          (setf (slot-value component 'depends-on)
-                (parse-dependency-defs depends-on)
-                (slot-value component 'weakly-depends-on)
-                ;; these must be a list of systems, cannot be features or versioned systems
-                (mapcar 'coerce-name weakly-depends-on)))
-        (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
-          (when (and (typep component 'system) (not bspp))
-            (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
-          (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
-        ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
-        ;; A better fix is required.
-        (setf (slot-value component 'version) version)
-        (when (typep component 'parent-component)
-          (setf (component-children component)
-                (loop
-                  :with previous-component = nil
-                  :for c-form :in components
-                  :for c = (parse-component-form component c-form
-                                                 :previous-serial-component previous-component)
-                  :for name = (component-name c)
-                  :collect c
-                  :when serial :do (setf previous-component name)))
-          (compute-children-by-name component))
-        (when previous-serial-component
-          (push previous-serial-component depends-on))
-        (when weakly-depends-on
-          ;; ASDF4: deprecate this feature and remove it.
-          (appendf depends-on
-                   (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
-        ;; Used by POIU. ASDF4: rename to component-depends-on?
-        (setf (component-sideway-dependencies component) depends-on)
-        (%refresh-component-inline-methods component rest)
-        (when if-component-dep-fails
-          (error "The system definition for ~S uses deprecated ~
-            ASDF option :IF-COMPONENT-DEP-FAILS. ~
-            Starting with ASDF 3, please use :IF-FEATURE instead"
-           (coerce-name (component-system component))))
-        component)))
-
-  (defun register-system-definition
-      (name &rest options &key pathname (class 'system) (source-file () sfp)
-                            defsystem-depends-on &allow-other-keys)
-    ;; The system must be registered before we parse the body,
-    ;; otherwise we recur when trying to find an existing system
-    ;; of the same name to reuse options (e.g. pathname) from.
-    ;; To avoid infinite recursion in cases where you defsystem a system
-    ;; that is registered to a different location to find-system,
-    ;; we also need to remember it in the asdf-cache.
-    (with-asdf-cache ()
-      (let* ((name (coerce-name name))
-             (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
-             (registered (system-registered-p name))
-             (registered! (if registered
-                              (rplaca registered (get-file-stamp source-file))
-                              (register-system
-                               (make-instance 'system :name name :source-file source-file))))
-             (system (reset-system (cdr registered!)
-                                   :name name :source-file source-file))
-             (component-options
-              (remove-plist-keys '(:defsystem-depends-on :class) options))
-             (defsystem-dependencies (loop :for spec :in defsystem-depends-on
-                                           :when (resolve-dependency-spec nil spec)
-                                           :collect :it)))
-        ;; cache defsystem-depends-on in canonical form
-        (when defsystem-depends-on
-          (setf component-options
-                (append `(:defsystem-depends-on ,(parse-dependency-defs defsystem-depends-on))
-                        component-options)))
-        (set-asdf-cache-entry `(find-system ,name) (list system))
-        (load-systems* defsystem-dependencies)
-        ;; We change-class AFTER we loaded the defsystem-depends-on
-        ;; since the class might be defined as part of those.
-        (let ((class (class-for-type nil class)))
-          (unless (subtypep class 'system)
-            (error 'non-system-system :name name :class-name (class-name class)))
-          (unless (eq (type-of system) class)
-            (change-class system class)))
-        (parse-component-form
-         nil (list*
-              :module name
-              :pathname (determine-system-directory pathname)
-              component-options)))))
-
-  (defmacro defsystem (name &body options)
-    `(apply 'register-system-definition ',name ',options)))
-;;;; -------------------------------------------------------------------------
-;;;; ASDF-Bundle
-
-(uiop/package:define-package :asdf/bundle
-  (:recycle :asdf/bundle :asdf)
-  (:use :uiop/common-lisp :uiop :asdf/upgrade
-   :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
-   :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem)
-  (:export
-   #:bundle-op #:bundle-type #:program-system
-   #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
-   #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
-   #:basic-compile-bundle-op #:prepare-bundle-op
-   #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
-   #:lib-op #:monolithic-lib-op
-   #:dll-op #:monolithic-dll-op
-   #:deliver-asd-op #:monolithic-deliver-asd-op
-   #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
-   #:user-system-p #:user-system #:trivial-system-p
-   #:make-build
-   #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
-(in-package :asdf/bundle)
-
-(with-upgradability ()
-  (defclass bundle-op (basic-compile-op)
-    ((build-args :initarg :args :initform nil :accessor extra-build-args)
-     (name-suffix :initarg :name-suffix :initform nil)
-     (bundle-type :initform :no-output-file :reader bundle-type)
-     #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files)))
-
-  (defclass monolithic-op (operation) ()
-    (:documentation "A MONOLITHIC operation operates on a system *and all of its
-dependencies*.  So, for example, a monolithic concatenate operation will
-concatenate together a system's components and all of its dependencies, but a
-simple concatenate operation will concatenate only the components of the system
-itself.")) ;; operation on a system and its dependencies
-
-  (defclass monolithic-bundle-op (monolithic-op bundle-op)
-    ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation
-    ((prologue-code :initform nil :accessor prologue-code)
-     (epilogue-code :initform nil :accessor epilogue-code)))
-
-  (defclass program-system (system)
-    ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
-    ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
-     (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
-     (no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
-     (prefix-lisp-object-files :initarg :prefix-lisp-object-files
-                               :initform nil :accessor prefix-lisp-object-files)
-     (postfix-lisp-object-files :initarg :postfix-lisp-object-files
-                                :initform nil :accessor postfix-lisp-object-files)
-     (extra-object-files :initarg :extra-object-files
-                         :initform nil :accessor extra-object-files)
-     (extra-build-args :initarg :extra-build-args
-                       :initform nil :accessor extra-build-args)))
+  (defun inherit-output-translations (inherit &key collect)
+    (when inherit
+      (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))

-  (defmethod prologue-code ((x t)) nil)
-  (defmethod epilogue-code ((x t)) nil)
-  (defmethod no-uiop ((x t)) nil)
-  (defmethod prefix-lisp-object-files ((x t)) nil)
-  (defmethod postfix-lisp-object-files ((x t)) nil)
-  (defmethod extra-object-files ((x t)) nil)
-  (defmethod extra-build-args ((x t)) nil)
+  (defun* (process-output-translations-directive) (directive &key inherit collect)
+    (if (atom directive)
+        (ecase directive
+          ((:enable-user-cache)
+           (process-output-translations-directive '(t :user-cache) :collect collect))
+          ((:disable-cache)
+           (process-output-translations-directive '(t t) :collect collect))
+          ((:inherit-configuration)
+           (inherit-output-translations inherit :collect collect))
+          ((:ignore-inherited-configuration :ignore-invalid-entries nil)
+           nil))
+        (let ((src (first directive))
+              (dst (second directive)))
+          (if (eq src :include)
+              (when dst
+                (process-output-translations (pathname dst) :inherit nil :collect collect))
+              (when src
+                (let ((trusrc (or (eql src t)
+                                  (let ((loc (resolve-location src :ensure-directory t :wilden t)))
+                                    (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
+                  (cond
+                    ((location-function-p dst)
+                     (funcall collect
+                              (list trusrc (ensure-function (second dst)))))
+                    ((typep dst 'boolean)
+                     (funcall collect (list trusrc t)))
+                    (t
+                     (let* ((trudst (resolve-location dst :ensure-directory t :wilden t)))
+                       (funcall collect (list trudst t))
+                       (funcall collect (list trusrc trudst)))))))))))

-  (defclass link-op (bundle-op) ()
-    (:documentation "Abstract operation for linking files together"))
+  (defmethod process-output-translations ((x symbol) &key
+                                                       (inherit *default-output-translations*)
+                                                       collect)
+    (process-output-translations (funcall x) :inherit inherit :collect collect))
+  (defmethod process-output-translations ((pathname pathname) &key inherit collect)
+    (cond
+      ((directory-pathname-p pathname)
+       (process-output-translations (validate-output-translations-directory pathname)
+                                    :inherit inherit :collect collect))
+      ((probe-file* pathname :truename *resolve-symlinks*)
+       (process-output-translations (validate-output-translations-file pathname)
+                                    :inherit inherit :collect collect))
+      (t
+       (inherit-output-translations inherit :collect collect))))
+  (defmethod process-output-translations ((string string) &key inherit collect)
+    (process-output-translations (parse-output-translations-string string)
+                                 :inherit inherit :collect collect))
+  (defmethod process-output-translations ((x null) &key inherit collect)
+    (inherit-output-translations inherit :collect collect))
+  (defmethod process-output-translations ((form cons) &key inherit collect)
+    (dolist (directive (cdr (validate-output-translations-form form)))
+      (process-output-translations-directive directive :inherit inherit :collect collect)))

-  (defclass gather-op (bundle-op)
-    ((gather-op :initform nil :allocation :class :reader gather-op))
-    (:documentation "Abstract operation for gathering many input files from a system"))
+  (defun compute-output-translations (&optional parameter)
+    "read the configuration, return it"
+    (remove-duplicates
+     (while-collecting (c)
+       (inherit-output-translations
+        `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
+     :test 'equal :from-end t))

-  (defun operation-monolithic-p (op)
-    (typep op 'monolithic-op))
+  (defvar *output-translations-parameter* nil)

-  (defmethod component-depends-on ((o gather-op) (s system))
-    (let* ((mono (operation-monolithic-p o))
-           (deps
-             (required-components
-              s :other-systems mono :component-type (if mono 'system '(not system))
-                :goal-operation (find-operation o 'load-op)
-                :keep-operation 'compile-op)))
-      ;; NB: the explicit make-operation on ECL and MKCL
-      ;; ensures that we drop the original-initargs and its magic flags when recursing.
-      `((,(make-operation (or (gather-op o) (if mono 'lib-op 'compile-op))) ,@deps)
-        ,@(call-next-method))))
+  (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
+    "read the configuration, initialize the internal configuration variable,
+return the configuration"
+    (setf *output-translations-parameter* parameter
+          (output-translations) (compute-output-translations parameter)))

-  ;; create a single fasl for the entire library
-  (defclass basic-compile-bundle-op (bundle-op)
-    ((bundle-type :initform :fasl)))
+  (defun disable-output-translations ()
+    "Initialize output translations in a way that maps every file to itself,
+effectively disabling the output translation facility."
+    (initialize-output-translations
+     '(:output-translations :disable-cache :ignore-inherited-configuration)))

-  (defclass prepare-bundle-op (sideway-operation)
-    ((sideway-operation
-      :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
-      :allocation :class)))
+  ;; checks an initial variable to see whether the state is initialized
+  ;; or cleared. In the former case, return current configuration; in
+  ;; the latter, initialize.  ASDF will call this function at the start
+  ;; of (asdf:find-system).
+  (defun ensure-output-translations ()
+    (if (output-translations-initialized-p)
+        (output-translations)
+        (initialize-output-translations)))

-  (defclass lib-op (link-op gather-op non-propagating-operation)
-    ((bundle-type :initform :lib))
-    (:documentation "compile the system and produce linkable (.a) library for it."))
+  (defun* (apply-output-translations) (path)
+    (etypecase path
+      (logical-pathname
+       path)
+      ((or pathname string)
+       (ensure-output-translations)
+       (loop* :with p = (resolve-symlinks* path)
+              :for (source destination) :in (car *output-translations*)
+              :for root = (when (or (eq source t)
+                                    (and (pathnamep source)
+                                         (not (absolute-pathname-p source))))
+                            (pathname-root p))
+              :for absolute-source = (cond
+                                       ((eq source t) (wilden root))
+                                       (root (merge-pathnames* source root))
+                                       (t source))
+              :when (or (eq source t) (pathname-match-p p absolute-source))
+              :return (translate-pathname* p absolute-source destination root source)
+              :finally (return p)))))

-  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
-                               #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op)
-    ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op)
-                         :allocation :class)))
+  ;; Hook into uiop's output-translation mechanism
+  #-cormanlisp
+  (setf *output-translation-function* 'apply-output-translations)

-  (defclass load-bundle-op (basic-load-op selfward-operation)
-    ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class)))
+  #+abcl
+  (defun translate-jar-pathname (source wildcard)
+    (declare (ignore wildcard))
+    (flet ((normalize-device (pathname)
+             (if (find :windows *features*)
+                 pathname
+                 (make-pathname :defaults pathname :device :unspecific))))
+      (let* ((jar
+               (pathname (first (pathname-device source))))
+             (target-root-directory-namestring
+               (format nil "/___jar___file___root___/~@[~A/~]"
+                       (and (find :windows *features*)
+                            (pathname-device jar))))
+             (relative-source
+               (relativize-pathname-directory source))
+             (relative-jar
+               (relativize-pathname-directory (ensure-directory-pathname jar)))
+             (target-root-directory
+               (normalize-device
+                (pathname-directory-pathname
+                 (parse-namestring target-root-directory-namestring))))
+             (target-root
+               (merge-pathnames* relative-jar target-root-directory))
+             (target
+               (merge-pathnames* relative-source target-root)))
+        (normalize-device (apply-output-translations target))))))

-  ;; NB: since the monolithic-op's can't be sideway-operation's,
-  ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's,
-  ;; 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-compile-bundle-op above.
+;;;; -----------------------------------------------------------------
+;;;; Source Registry Configuration, by Francois-Rene Rideau
+;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918

-  (defclass dll-op (link-op gather-op non-propagating-operation)
-    ((bundle-type :initform :dll))
-    (:documentation "compile the system and produce dynamic (.so/.dll) library for it."))
+(uiop/package:define-package :asdf/source-registry
+  (:recycle :asdf/source-registry :asdf)
+  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
+  (:export
+   #:*source-registry-parameter* #:*default-source-registries*
+   #:invalid-source-registry
+   #:source-registry-initialized-p
+   #:initialize-source-registry #:clear-source-registry #:*source-registry*
+   #:ensure-source-registry #:*source-registry-parameter*
+   #:*default-source-registry-exclusions* #:*source-registry-exclusions*
+   #:*wild-asd* #:directory-asd-files #:register-asd-directory
+   #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files
+   #:validate-source-registry-directive #:validate-source-registry-form
+   #:validate-source-registry-file #:validate-source-registry-directory
+   #:parse-source-registry-string #:wrapping-source-registry
+   #:default-user-source-registry #:default-system-source-registry
+   #:user-source-registry #:system-source-registry
+   #:user-source-registry-directory #:system-source-registry-directory
+   #:environment-source-registry #:process-source-registry #:inherit-source-registry
+   #:compute-source-registry #:flatten-source-registry
+   #:sysdef-source-registry-search))
+(in-package :asdf/source-registry)

-  (defclass deliver-asd-op (basic-compile-op selfward-operation)
-    ((selfward-operation :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) :allocation :class))
-    (:documentation "produce an asd file for delivering the system as a single fasl"))
+(with-upgradability ()
+  (define-condition invalid-source-registry (invalid-configuration warning)
+    ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))

+  ;; Using ack 1.2 exclusions
+  (defvar *default-source-registry-exclusions*
+    '(".bzr" ".cdv"
+      ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
+      ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
+      "_sgbak" "autom4te.cache" "cover_db" "_build"
+      "debian")) ;; debian often builds stuff under the debian directory... BAD.

-  (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
-    ((selfward-operation
-      :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
-      :allocation :class))
-    (:documentation "produce fasl and asd files for combined system and dependencies."))
+  (defvar *source-registry-exclusions* *default-source-registry-exclusions*)

-  (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op
-                                          #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation)
-    ((gather-op :initform #+(or clasp ecl mkcl) 'lib-op #-(or clasp ecl mkcl) 'compile-bundle-op :allocation :class))
-    (:documentation "Create a single fasl for the system and its dependencies."))
+  (defvar *source-registry* nil
+    "Either NIL (for uninitialized), or an equal hash-table, mapping
+system names to pathnames of .asd files")

-  (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op)
-    ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
-    (:documentation "Load a single fasl for the system and its dependencies."))
+  (defvar *source-registry-parameter* nil)

-  (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation) ()
-    (:documentation "Create a single linkable library for the system and its dependencies."))
+  (defun source-registry-initialized-p ()
+    (typep *source-registry* 'hash-table))

-  (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation)
-    ((bundle-type :initform :dll))
-    (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
+  (defun clear-source-registry ()
+    "Undoes any initialization of the source registry."
+    (setf *source-registry* nil)
+    (values))
+  (register-clear-configuration-hook 'clear-source-registry)

-  (defclass image-op (monolithic-bundle-op selfward-operation
-                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op)
-    ((bundle-type :initform :image)
-     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
-    (:documentation "create an image file from the system and its dependencies"))
+  (defparameter *wild-asd*
+    (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))

-  (defclass program-op (image-op)
-    ((bundle-type :initform :program))
-    (:documentation "create an executable file from the system and its dependencies"))
+  (defun directory-asd-files (directory)
+    (directory-files directory *wild-asd*))

-  (defun bundle-pathname-type (bundle-type)
-    (etypecase bundle-type
-      ((eql :no-output-file) nil) ;; should we error out instead?
-      ((or null string) bundle-type)
-      ((eql :fasl) #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")
-      #+(or clasp ecl)
-      ((member :dll :lib :shared-library :static-library :program :object :program)
-       (compile-file-type :type bundle-type))
-      ((member :image) #-allegro "image" #+allegro "dxl")
-      ((member :dll :shared-library) (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
-      ((member :lib :static-library) (os-cond ((os-unix-p) "a")
-                                              ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
-      ((eql :program) (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
+  (defun collect-asds-in-directory (directory collect)
+    (let ((asds (directory-asd-files directory)))
+      (map () collect asds)
+      asds))

-  (defun bundle-output-files (o c)
-    (let ((bundle-type (bundle-type o)))
-      (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
-                  (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))
-        (let ((name (or (component-build-pathname c)
-                        (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
-              (type (bundle-pathname-type bundle-type)))
-          (values (list (subpathname (component-pathname c) name :type type))
-                  (eq (type-of o) (component-build-operation c)))))))
+  (defvar *recurse-beyond-asds* t
+    "Should :tree entries of the source-registry recurse in subdirectories
+after having found a .asd file? True by default.")

-  (defmethod output-files ((o bundle-op) (c system))
-    (bundle-output-files o c))
+  (defun process-source-registry-cache (directory collect)
+    (let ((cache (ignore-errors
+                  (safe-read-file-form (subpathname directory ".cl-source-registry.cache")))))
+      (when (and (listp cache) (eq :source-registry-cache (first cache)))
+        (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s)))
+        t)))

-  #-(or clasp ecl mkcl)
-  (progn
-    (defmethod perform ((o image-op) (c system))
-      (dump-image (output-file o c) :executable (typep o 'program-op)))
-    (defmethod perform :before ((o program-op) (c system))
-      (setf *image-entry-point* (ensure-function (component-entry-point c)))))
+  (defun collect-sub*directories-asd-files
+      (directory &key (exclude *default-source-registry-exclusions*) collect
+                   (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache)
+    (collect-sub*directories
+     directory
+     #'(lambda (dir)
+         (unless (and (not ignore-cache) (process-source-registry-cache directory collect))
+           (let ((asds (collect-asds-in-directory dir collect)))
+             (or recurse-beyond-asds (not asds)))))
+     #'(lambda (x)
+         (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
+     (constantly nil)))

-  (defclass compiled-file (file-component)
-    ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")))
+  (defun validate-source-registry-directive (directive)
+    (or (member directive '(:default-registry))
+        (and (consp directive)
+             (let ((rest (rest directive)))
+               (case (first directive)
+                 ((:include :directory :tree)
+                  (and (length=n-p rest 1)
+                       (location-designator-p (first rest))))
+                 ((:exclude :also-exclude)
+                  (every #'stringp rest))
+                 ((:default-registry)
+                  (null rest)))))))

-  (defclass precompiled-system (system)
-    ((build-pathname :initarg :fasl)))
+  (defun validate-source-registry-form (form &key location)
+    (validate-configuration-form
+     form :source-registry 'validate-source-registry-directive
+          :location location :invalid-form-reporter 'invalid-source-registry))

-  (defclass prebuilt-system (system)
-    ((build-pathname :initarg :static-library :initarg :lib
-                     :accessor prebuilt-system-static-library))))
+  (defun validate-source-registry-file (file)
+    (validate-configuration-file
+     file 'validate-source-registry-form :description "a source registry"))

+  (defun validate-source-registry-directory (directory)
+    (validate-configuration-directory
+     directory :source-registry 'validate-source-registry-directive
+               :invalid-form-reporter 'invalid-source-registry))

-;;;
-;;; BUNDLE-OP
-;;;
-;;; This operation takes all components from one or more systems and
-;;; creates a single output file, which may be
-;;; a FASL, a statically linked library, a shared library, etc.
-;;; The different targets are defined by specialization.
-;;;
-(with-upgradability ()
-  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
-                                         &key (name-suffix nil name-suffix-p)
-                                         &allow-other-keys)
-    (declare (ignore initargs name-suffix))
-    (unless name-suffix-p
-      (setf (slot-value instance 'name-suffix)
-            (unless (typep instance 'program-op)
-              ;; "." is no good separator for Logical Pathnames, so we use "--"
-              (if (operation-monolithic-p instance) "--all-systems" #-(or clasp ecl mkcl) "--system"))))
-    (when (typep instance 'monolithic-bundle-op)
-      (destructuring-bind (&key lisp-files prologue-code epilogue-code
-                           &allow-other-keys)
-          (operation-original-initargs instance)
-        (setf (prologue-code instance) prologue-code
-              (epilogue-code instance) epilogue-code)
-        #-(or clasp ecl) (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
-        #+(or clasp ecl) (setf (extra-object-files instance) lisp-files)))
-    (setf (extra-build-args instance)
-          (remove-plist-keys
-           '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files
-             :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments
-           (operation-original-initargs instance))))
+  (defun parse-source-registry-string (string &key location)
+    (cond
+      ((or (null string) (equal string ""))
+       '(:source-registry :inherit-configuration))
+      ((not (stringp string))
+       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
+      ((find (char string 0) "\"(")
+       (validate-source-registry-form (read-from-string string) :location location))
+      (t
+       (loop
+         :with inherit = nil
+         :with directives = ()
+         :with start = 0
+         :with end = (length string)
+         :with separator = (inter-directory-separator)
+         :for pos = (position separator string :start start) :do
+           (let ((s (subseq string start (or pos end))))
+             (flet ((check (dir)
+                      (unless (absolute-pathname-p dir)
+                        (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
+                      dir))
+               (cond
+                 ((equal "" s) ; empty element: inherit
+                  (when inherit
+                    (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+                           string))
+                  (setf inherit t)
+                  (push ':inherit-configuration directives))
+                 ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
+                  (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
+                 (t
+                  (push `(:directory ,(check s)) directives))))
+             (cond
+               (pos
+                (setf start (1+ pos)))
+               (t
+                (unless inherit
+                  (push '(:ignore-inherited-configuration) directives))
+                (return `(:source-registry ,@(nreverse directives))))))))))

-  (defun bundlable-file-p (pathname)
-    (let ((type (pathname-type pathname)))
-      (declare (ignorable type))
-      (or #+(or clasp ecl) (or (equalp type (compile-file-type :type :object))
-                               (equalp type (compile-file-type :type :static-library)))
-          #+mkcl (or (equalp type (compile-file-type :fasl-p nil))
-                     #+(or unix mingw32 mingw64) (equalp type "a") ;; valid on Unix and MinGW
-                     #+(and windows (not (or mingw32 mingw64))) (equalp type "lib"))
-          #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
+  (defun register-asd-directory (directory &key recurse exclude collect)
+    (if (not recurse)
+        (collect-asds-in-directory directory collect)
+        (collect-sub*directories-asd-files
+         directory :exclude exclude :collect collect)))

-  (defgeneric* (trivial-system-p) (component))
+  (defparameter* *default-source-registries*
+    '(environment-source-registry
+      user-source-registry
+      user-source-registry-directory
+      default-user-source-registry
+      system-source-registry
+      system-source-registry-directory
+      default-system-source-registry)
+    "List of default source registries" "3.1.0.102")

-  (defun user-system-p (s)
-    (and (typep s 'system)
-         (not (builtin-system-p s))
-         (not (trivial-system-p s)))))
+  (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
+  (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))

-(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
-  (deftype user-system () '(and system (satisfies user-system-p))))
+  (defun wrapping-source-registry ()
+    `(:source-registry
+      #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
+      :inherit-configuration
+      #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
+      #+cmu (:tree #p"modules:")
+      #+scl (:tree #p"file://modules/")))
+  (defun default-user-source-registry ()
+    `(:source-registry
+      (:tree (:home "common-lisp/"))
+      #+sbcl (:directory (:home ".sbcl/systems/"))
+      (:directory ,(xdg-data-home "common-lisp/systems/"))
+      (:tree ,(xdg-data-home "common-lisp/source/"))
+      :inherit-configuration))
+  (defun default-system-source-registry ()
+    `(:source-registry
+      ,@(loop :for dir :in (xdg-data-dirs "common-lisp/")
+              :collect `(:directory (,dir "systems/"))
+              :collect `(:tree (,dir "source/")))
+      :inherit-configuration))
+  (defun user-source-registry (&key (direction :input))
+    (xdg-config-pathname *source-registry-file* direction))
+  (defun system-source-registry (&key (direction :input))
+    (find-preferred-file (system-config-pathnames *source-registry-file*)
+                         :direction direction))
+  (defun user-source-registry-directory (&key (direction :input))
+    (xdg-config-pathname *source-registry-directory* direction))
+  (defun system-source-registry-directory (&key (direction :input))
+    (find-preferred-file (system-config-pathnames *source-registry-directory*)
+                         :direction direction))
+  (defun environment-source-registry ()
+    (getenv "CL_SOURCE_REGISTRY"))

-;;;
-;;; First we handle monolithic bundles.
-;;; These are standalone systems which contain everything,
-;;; including other ASDF systems required by the current one.
-;;; A PROGRAM is always monolithic.
-;;;
-;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
-;;;
-(with-upgradability ()
-  (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
-    ;; This file selects output files from direct dependencies;
-    ;; your component-depends-on method better gathered the correct dependencies in the correct order.
-    (while-collecting (collect)
-      (map-direct-dependencies
-       t o c #'(lambda (sub-o sub-c)
-                 (loop :for f :in (funcall key sub-o sub-c)
-                       :when (funcall test f) :do (collect f))))))
+  (defgeneric* (process-source-registry) (spec &key inherit register))

-  (defmethod input-files ((o gather-op) (c system))
-    (unless (eq (bundle-type o) :no-output-file)
-      (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)))
+  (defun* (inherit-source-registry) (inherit &key register)
+    (when inherit
+      (process-source-registry (first inherit) :register register :inherit (rest inherit))))

-  (defun select-bundle-operation (type &optional monolithic)
-    (ecase type
-      ((:dll :shared-library)
-       (if monolithic 'monolithic-dll-op 'dll-op))
-      ((:lib :static-library)
-       (if monolithic 'monolithic-lib-op 'lib-op))
-      ((:fasl)
-       (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
-      ((:image)
-       'image-op)
-      ((:program)
-       'program-op)))
+  (defun* (process-source-registry-directive) (directive &key inherit register)
+    (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
+      (ecase kw
+        ((:include)
+         (destructuring-bind (pathname) rest
+           (process-source-registry (resolve-location pathname) :inherit nil :register register)))
+        ((:directory)
+         (destructuring-bind (pathname) rest
+           (when pathname
+             (funcall register (resolve-location pathname :ensure-directory t)))))
+        ((:tree)
+         (destructuring-bind (pathname) rest
+           (when pathname
+             (funcall register (resolve-location pathname :ensure-directory t)
+                      :recurse t :exclude *source-registry-exclusions*))))
+        ((:exclude)
+         (setf *source-registry-exclusions* rest))
+        ((:also-exclude)
+         (appendf *source-registry-exclusions* rest))
+        ((:default-registry)
+         (inherit-source-registry
+          '(default-user-source-registry default-system-source-registry) :register register))
+        ((:inherit-configuration)
+         (inherit-source-registry inherit :register register))
+        ((:ignore-inherited-configuration)
+         nil)))
+    nil)

-  ;; DEPRECATED. This is originally from asdf-ecl.lisp. Does anyone use it?
-  (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
-                             (move-here nil move-here-p)
-                             &allow-other-keys)
-    (let* ((operation-name (select-bundle-operation type monolithic))
-           (move-here-path (if (and move-here
-                                    (typep move-here '(or pathname string)))
-                               (ensure-pathname move-here :namestring :lisp :ensure-directory t)
-                               (system-relative-pathname system "asdf-output/")))
-           (operation (apply #'operate operation-name
-                             system
-                             (remove-plist-keys '(:monolithic :type :move-here) args)))
-           (system (find-system system))
-           (files (and system (output-files operation system))))
-      (if (or move-here (and (null move-here-p)
-                             (member operation-name '(:program :image))))
-          (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
-                :for f :in files
-                :for new-f = (make-pathname :name (pathname-name f)
-                                            :type (pathname-type f)
-                                            :defaults dest-path)
-                :do (rename-file-overwriting-target f new-f)
-                :collect new-f)
-          files)))
+  (defmethod process-source-registry ((x symbol) &key inherit register)
+    (process-source-registry (funcall x) :inherit inherit :register register))
+  (defmethod process-source-registry ((pathname pathname) &key inherit register)
+    (cond
+      ((directory-pathname-p pathname)
+       (let ((*here-directory* (resolve-symlinks* pathname)))
+         (process-source-registry (validate-source-registry-directory pathname)
+                                  :inherit inherit :register register)))
+      ((probe-file* pathname :truename *resolve-symlinks*)
+       (let ((*here-directory* (pathname-directory-pathname pathname)))
+         (process-source-registry (validate-source-registry-file pathname)
+                                  :inherit inherit :register register)))
+      (t
+       (inherit-source-registry inherit :register register))))
+  (defmethod process-source-registry ((string string) &key inherit register)
+    (process-source-registry (parse-source-registry-string string)
+                             :inherit inherit :register register))
+  (defmethod process-source-registry ((x null) &key inherit register)
+    (inherit-source-registry inherit :register register))
+  (defmethod process-source-registry ((form cons) &key inherit register)
+    (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
+      (dolist (directive (cdr (validate-source-registry-form form)))
+        (process-source-registry-directive directive :inherit inherit :register register))))

-  ;; DEPRECATED. Does anyone use this?
-  (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
-    (declare (ignore force verbose version))
-    (apply #'operate 'deliver-asd-op system args)))
+  (defun flatten-source-registry (&optional (parameter *source-registry-parameter*))
+    (remove-duplicates
+     (while-collecting (collect)
+       (with-pathname-defaults () ;; be location-independent
+         (inherit-source-registry
+          `(wrapping-source-registry
+            ,parameter
+            ,@*default-source-registries*)
+          :register #'(lambda (directory &key recurse exclude)
+                        (collect (list directory :recurse recurse :exclude exclude))))))
+     :test 'equal :from-end t))

-;;;
-;;; LOAD-BUNDLE-OP
-;;;
-;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
-;;;
-(with-upgradability ()
-  (defmethod component-depends-on ((o load-bundle-op) (c system))
-    `((,o ,@(component-sideway-dependencies c))
-      (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
-      ,@(call-next-method)))
+  ;; Will read the configuration and initialize all internal variables.
+  (defun compute-source-registry (&optional (parameter *source-registry-parameter*) (registry *source-registry*))
+    (dolist (entry (flatten-source-registry parameter))
+      (destructuring-bind (directory &key recurse exclude) entry
+        (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
+          (register-asd-directory
+           directory :recurse recurse :exclude exclude :collect
+           #'(lambda (asd)
+               (let* ((name (pathname-name asd))
+                      (name (if (typep asd 'logical-pathname)
+                                ;; logical pathnames are upper-case,
+                                ;; at least in the CLHS and on SBCL,
+                                ;; yet (coerce-name :foo) is lower-case.
+                                ;; won't work well with (load-system "Foo")
+                                ;; instead of (load-system 'foo)
+                                (string-downcase name)
+                                name)))
+                 (cond
+                   ((gethash name registry) ; already shadowed by something else
+                    nil)
+                   ((gethash name h) ; conflict at current level
+                    (when *verbose-out*
+                      (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
+                                found several entries for ~A - picking ~S over ~S~:>")
+                            directory recurse name (gethash name h) asd)))
+                   (t
+                    (setf (gethash name registry) asd)
+                    (setf (gethash name h) asd))))))
+          h)))
+    (values))

-  (defmethod input-files ((o load-bundle-op) (c system))
-    (when (user-system-p c)
-      (output-files (find-operation o 'compile-bundle-op) c)))
+  (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
+    ;; Record the parameter used to configure the registry
+    (setf *source-registry-parameter* parameter)
+    ;; Clear the previous registry database:
+    (setf *source-registry* (make-hash-table :test 'equal))
+    ;; Do it!
+    (compute-source-registry parameter))

-  (defmethod perform ((o load-bundle-op) (c system))
-    (when (input-files o c)
-      (perform-lisp-load-fasl o c)))
+  ;; Checks an initial variable to see whether the state is initialized
+  ;; or cleared. In the former case, return current configuration; in
+  ;; the latter, initialize.  ASDF will call this function at the start
+  ;; of (asdf:find-system) to make sure the source registry is initialized.
+  ;; However, it will do so *without* a parameter, at which point it
+  ;; will be too late to provide a parameter to this function, though
+  ;; you may override the configuration explicitly by calling
+  ;; initialize-source-registry directly with your parameter.
+  (defun ensure-source-registry (&optional parameter)
+    (unless (source-registry-initialized-p)
+      (initialize-source-registry parameter))
+    (values))

-  (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
-    (mark-operation-done (find-operation o 'load-op) c)))
+  (defun sysdef-source-registry-search (system)
+    (ensure-source-registry)
+    (values (gethash (primary-system-name system) *source-registry*))))

-;;;
-;;; PRECOMPILED FILES
-;;;
-;;; This component can be used to distribute ASDF systems in precompiled form.
-;;; Only useful when the dependencies have also been precompiled.
-;;;
-(with-upgradability ()
-  (defmethod trivial-system-p ((s system))
-    (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))

-  (defmethod input-files ((o operation) (c compiled-file))
-    (list (component-pathname c)))
-  (defmethod perform ((o load-op) (c compiled-file))
-    (perform-lisp-load-fasl o c))
-  (defmethod perform ((o load-source-op) (c compiled-file))
-    (perform (find-operation o 'load-op) c))
-  (defmethod perform ((o operation) (c compiled-file))
-    nil))
+;;;; -------------------------------------------------------------------------
+;;;; Defsystem

-;;;
-;;; Pre-built systems
-;;;
-(with-upgradability ()
-  (defmethod trivial-system-p ((s prebuilt-system))
-    t)
+(uiop/package:define-package :asdf/parse-defsystem
+  (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
+  (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
+  (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/cache :asdf/component :asdf/system
+   :asdf/find-system :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate)
+  (:import-from :asdf/system #:depends-on #:weakly-depends-on)
+  (:export
+   #:defsystem #:register-system-definition
+   #:class-for-type #:*default-component-class*
+   #:determine-system-directory #:parse-component-form
+   #:non-toplevel-system #:non-system-system
+   #:sysdef-error-component #:check-component-input))
+(in-package :asdf/parse-defsystem)

-  (defmethod perform ((o link-op) (c prebuilt-system))
-    nil)
+;;; Pathname
+(with-upgradability ()
+  (defun determine-system-directory (pathname)
+    ;; The defsystem macro calls this function to determine
+    ;; the pathname of a system as follows:
+    ;; 1. if the pathname argument is an pathname object (NOT a namestring),
+    ;;    that is already an absolute pathname, return it.
+    ;; 2. otherwise, the directory containing the LOAD-PATHNAME
+    ;;    is considered (as deduced from e.g. *LOAD-PATHNAME*), and
+    ;;    if it is indeed available and an absolute pathname, then
+    ;;    the PATHNAME argument is normalized to a relative pathname
+    ;;    as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
+    ;;    and merged into that DIRECTORY as per SUBPATHNAME.
+    ;;    Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
+    ;;    and may be from within the EVAL-WHEN of a file compilation.
+    ;; If no absolute pathname was found, we return NIL.
+    (check-type pathname (or null string pathname))
+    (pathname-directory-pathname
+     (resolve-symlinks*
+      (ensure-absolute-pathname
+       (parse-unix-namestring pathname :type :directory)
+       #'(lambda () (ensure-absolute-pathname
+                     (load-pathname) 'get-pathname-defaults nil))
+       nil)))))

-  (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
-    nil)

-  (defmethod perform ((o lib-op) (c prebuilt-system))
-    nil)
+;;; Component class
+(with-upgradability ()
+  (defvar *default-component-class* 'cl-source-file)

-  (defmethod perform ((o dll-op) (c prebuilt-system))
-    nil)
+  (defun class-for-type (parent type)
+      (or (coerce-class type :package :asdf/interface :super 'component :error nil)
+          (and (eq type :file)
+               (coerce-class
+                (or (loop :for p = parent :then (component-parent p) :while p
+                            :thereis (module-default-component-class p))
+                    *default-component-class*)
+                :package :asdf/interface :super 'component :error nil))
+          (sysdef-error "don't recognize component type ~S" type))))

-  (defmethod component-depends-on ((o gather-op) (c prebuilt-system))
-    nil)

-  (defmethod output-files ((o lib-op) (c prebuilt-system))
-    (values (list (prebuilt-system-static-library c)) t)))
+;;; Check inputs
+(with-upgradability ()
+  (define-condition non-system-system (system-definition-error)
+    ((name :initarg :name :reader non-system-system-name)
+     (class-name :initarg :class-name :reader non-system-system-class-name))
+    (:report (lambda (c s)
+               (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
+                       (non-system-system-name c) (non-system-system-class-name c) 'system))))

+  (define-condition non-toplevel-system (system-definition-error)
+    ((parent :initarg :parent :reader non-toplevel-system-parent)
+     (name :initarg :name :reader non-toplevel-system-name))
+    (:report (lambda (c s)
+               (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
+                       (non-toplevel-system-parent c) (non-toplevel-system-name c)))))

-;;;
-;;; PREBUILT SYSTEM CREATOR
-;;;
-(with-upgradability ()
-  (defmethod output-files ((o deliver-asd-op) (s system))
-    (list (make-pathname :name (component-name s) :type "asd"
-                         :defaults (component-pathname s))))
+  (defun sysdef-error-component (msg type name value)
+    (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
+                  type name value))

-  (defmethod perform ((o deliver-asd-op) (s system))
-    (let* ((inputs (input-files o s))
-           (fasl (first inputs))
-           (library (second inputs))
-           (asd (first (output-files o s)))
-           (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
-           (version (component-version s))
-           (dependencies
-             (if (operation-monolithic-p o)
-                 (remove-if-not 'builtin-system-p
-                                (required-components s :component-type 'system
-                                                       :keep-operation 'load-op))
-                 (while-collecting (x) ;; resolve the sideway-dependencies of s
-                   (map-direct-dependencies
-                    t 'load-op s
-                    #'(lambda (o c)
-                        (when (and (typep o 'load-op) (typep c 'system))
-                          (x c)))))))
-           (depends-on (mapcar 'coerce-name dependencies)))
-      (when (pathname-equal asd (system-source-file s))
-        (cerror "overwrite the asd file"
-                "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
-                (cons o s) asd))
-      (with-open-file (s asd :direction :output :if-exists :supersede
-                             :if-does-not-exist :create)
-        (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
-                (operation-monolithic-p o) name)
-        (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
-                (lisp-implementation-type)
-                (lisp-implementation-version)
-                (software-type)
-                (machine-type)
-                (software-version))
-        (let ((*package* (find-package :asdf-user)))
-          (pprint `(defsystem ,name
-                     :class prebuilt-system
-                     :version ,version
-                     :depends-on ,depends-on
-                     :components ((:compiled-file ,(pathname-name fasl)))
-                     ,@(when library `(:lib ,(file-namestring library))))
-                  s)
-          (terpri s)))))
+  (defun check-component-input (type name weakly-depends-on
+                                depends-on components)
+    "A partial test of the values of a component."
+    (unless (listp depends-on)
+      (sysdef-error-component ":depends-on must be a list."
+                              type name depends-on))
+    (unless (listp weakly-depends-on)
+      (sysdef-error-component ":weakly-depends-on must be a list."
+                              type name weakly-depends-on))
+    (unless (listp components)
+      (sysdef-error-component ":components must be NIL or a list of components."
+                              type name components)))

-  #-(or clasp ecl mkcl)
-  (defmethod perform ((o basic-compile-bundle-op) (c system))
-    (let* ((input-files (input-files o c))
-           (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
-           (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
-           (output-files (output-files o c))
-           (output-file (first output-files)))
-      (assert (eq (not input-files) (not output-files)))
-      (when input-files
-        (when non-fasl-files
-          (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
-                 (implementation-type) non-fasl-files))
-        (when (or (prologue-code o) (epilogue-code o)
-                  (prologue-code c) (epilogue-code c))
-          (error "prologue-code and epilogue-code are not supported on ~A"
-                 (implementation-type)))
-        (with-staging-pathname (output-file)
-          (combine-fasls fasl-files output-file)))))
+  (defun* (normalize-version) (form &key pathname component parent)
+    (labels ((invalid (&optional (continuation "using NIL instead"))
+               (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
+                     form component parent pathname continuation))
+             (invalid-parse (control &rest args)
+               (unless (if-let (target (find-component parent component)) (builtin-system-p target))
+                 (apply 'warn control args)
+                 (invalid))))
+      (if-let (v (typecase form
+                   ((or string null) form)
+                   (real
+                    (invalid "Substituting a string")
+                    (format nil "~D" form)) ;; 1.0 becomes "1.0"
+                   (cons
+                    (case (first form)
+                      ((:read-file-form)
+                       (destructuring-bind (subpath &key (at 0)) (rest form)
+                         (safe-read-file-form (subpathname pathname subpath)
+                                              :at at :package :asdf-user)))
+                      ((:read-file-line)
+                       (destructuring-bind (subpath &key (at 0)) (rest form)
+                         (safe-read-file-line (subpathname pathname subpath)
+                                              :at at)))
+                      (otherwise
+                       (invalid))))
+                   (t
+                    (invalid))))
+        (if-let (pv (parse-version v #'invalid-parse))
+          (unparse-version pv)
+          (invalid))))))

-  (defmethod input-files ((o load-op) (s precompiled-system))
-    (bundle-output-files (find-operation o 'compile-bundle-op) s))

-  (defmethod perform ((o load-op) (s precompiled-system))
-    (perform-lisp-load-fasl o s))
+;;; "inline methods"
+(with-upgradability ()
+  (defparameter* +asdf-methods+
+    '(perform-with-restarts perform explain output-files operation-done-p))

-  (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
-    #+xcl (declare (ignorable o))
-    `((load-op ,s) ,@(call-next-method))))
+  (defun %remove-component-inline-methods (component)
+    (dolist (name +asdf-methods+)
+      (map ()
+           ;; this is inefficient as most of the stored
+           ;; methods will not be for this particular gf
+           ;; But this is hardly performance-critical
+           #'(lambda (m)
+               (remove-method (symbol-function name) m))
+           (component-inline-methods component)))
+    (component-inline-methods component) nil)

-#| ;; Example use:
-(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
-(asdf:load-system :precompiled-asdf-utils)
-|#
+  (defun %define-component-inline-methods (ret rest)
+    (loop* :for (key value) :on rest :by #'cddr
+           :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
+           :when name :do
+           (destructuring-bind (op &rest body) value
+             (loop :for arg = (pop body)
+                   :while (atom arg)
+                   :collect arg :into qualifiers
+                   :finally
+                      (destructuring-bind (o c) arg
+                        (pushnew
+                         (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
+                         (component-inline-methods ret)))))))

-#+(or clasp ecl mkcl)
+  (defun %refresh-component-inline-methods (component rest)
+    ;; clear methods, then add the new ones
+    (%remove-component-inline-methods component)
+    (%define-component-inline-methods component rest)))
+
+
+;;; Main parsing function
 (with-upgradability ()
-  ;; I think that Juanjo intended for this to be,
-  ;; but beware the weird bug in test-xach-update-bug.script,
-  ;; and also it makes mkcl fail test-logical-pathname.script,
-  ;; and ecl fail test-bundle.script.
-  ;;(unless (or #+(or clasp ecl) (use-ecl-byte-compiler-p))
-  ;;  (setf *load-system-operation* 'load-bundle-op))
+  (defun* parse-dependency-def (dd)
+    (if (listp dd)
+        (case (first dd)
+          (:feature
+           (unless (= (length dd) 3)
+             (sysdef-error "Ill-formed feature dependency: ~s" dd))
+           (let ((embedded (parse-dependency-def (third dd))))
+             `(:feature ,(second dd) ,embedded)))
+          (feature
+           (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd))
+          (:require
+           (unless (= (length dd) 2)
+             (sysdef-error "Ill-formed require dependency: ~s" dd))
+           dd)
+          (:version
+           (unless (= (length dd) 3)
+             (sysdef-error "Ill-formed version dependency: ~s" dd))
+           `(:version ,(coerce-name (second dd)) ,(third dd)))
+          (otherwise (sysdef-error "Ill-formed dependency: ~s" dd)))
+      (coerce-name dd)))

-  (defun uiop-library-pathname ()
-    #+clasp (probe-file* (compile-file-pathname "sys:uiop" :output-type :object))
-    #+ecl (or (probe-file* (compile-file-pathname "sys:uiop" :type :lib)) ;; new style
-              (probe-file* (compile-file-pathname "sys:uiop" :type :object))) ;; old style
-    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;uiop"))
+  (defun* parse-dependency-defs (dd-list)
+    "Parse the dependency defs in DD-LIST into canonical form by translating all
+system names contained using COERCE-NAME. Return the result."
+    (mapcar 'parse-dependency-def dd-list))

-  (defun asdf-library-pathname ()
-    #+clasp (probe-file* (compile-file-pathname "sys:asdf" :output-type :object))
-    #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style
-              (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style
-    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf"))
+  (defun* (parse-component-form) (parent options &key previous-serial-component)
+    (destructuring-bind
+        (type name &rest rest &key
+                                (builtin-system-p () bspp)
+                                ;; the following list of keywords is reproduced below in the
+                                ;; remove-plist-keys form.  important to keep them in sync
+                                components pathname perform explain output-files operation-done-p
+                                weakly-depends-on depends-on serial
+                                do-first if-component-dep-fails version
+                                ;; list ends
+         &allow-other-keys) options
+      (declare (ignore perform explain output-files operation-done-p builtin-system-p))
+      (check-component-input type name weakly-depends-on depends-on components)
+      (when (and parent
+                 (find-component parent name)
+                 (not ;; ignore the same object when rereading the defsystem
+                  (typep (find-component parent name)
+                         (class-for-type parent type))))
+        (error 'duplicate-names :name name))
+      (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
+      (let* ((name (coerce-name name))
+             (args `(:name ,name
+                     :pathname ,pathname
+                     ,@(when parent `(:parent ,parent))
+                     ,@(remove-plist-keys
+                        '(:components :pathname :if-component-dep-fails :version
+                          :perform :explain :output-files :operation-done-p
+                          :weakly-depends-on :depends-on :serial)
+                        rest)))
+             (component (find-component parent name))
+             (class (class-for-type parent type)))
+        (when (and parent (subtypep class 'system))
+          (error 'non-toplevel-system :parent parent :name name))
+        (if component ; preserve identity
+            (apply 'reinitialize-instance component args)
+            (setf component (apply 'make-instance class args)))
+        (component-pathname component) ; eagerly compute the absolute pathname
+        (when (typep component 'system)
+          ;; cache information for introspection
+          (setf (slot-value component 'depends-on)
+                (parse-dependency-defs depends-on)
+                (slot-value component 'weakly-depends-on)
+                ;; these must be a list of systems, cannot be features or versioned systems
+                (mapcar 'coerce-name weakly-depends-on)))
+        (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
+          (when (and (typep component 'system) (not bspp))
+            (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
+          (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
+        ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
+        ;; A better fix is required.
+        (setf (slot-value component 'version) version)
+        (when (typep component 'parent-component)
+          (setf (component-children component)
+                (loop
+                  :with previous-component = nil
+                  :for c-form :in components
+                  :for c = (parse-component-form component c-form
+                                                 :previous-serial-component previous-component)
+                  :for name = (component-name c)
+                  :collect c
+                  :when serial :do (setf previous-component name)))
+          (compute-children-by-name component))
+        (when previous-serial-component
+          (push previous-serial-component depends-on))
+        (when weakly-depends-on
+          ;; ASDF4: deprecate this feature and remove it.
+          (appendf depends-on
+                   (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
+        ;; Used by POIU. ASDF4: rename to component-depends-on?
+        (setf (component-sideway-dependencies component) depends-on)
+        (%refresh-component-inline-methods component rest)
+        (when if-component-dep-fails
+          (error "The system definition for ~S uses deprecated ~
+            ASDF option :IF-COMPONENT-DEP-FAILS. ~
+            Starting with ASDF 3, please use :IF-FEATURE instead"
+           (coerce-name (component-system component))))
+        component)))
+
+  (defun register-system-definition
+      (name &rest options &key pathname (class 'system) (source-file () sfp)
+                            defsystem-depends-on &allow-other-keys)
+    ;; The system must be registered before we parse the body,
+    ;; otherwise we recur when trying to find an existing system
+    ;; of the same name to reuse options (e.g. pathname) from.
+    ;; To avoid infinite recursion in cases where you defsystem a system
+    ;; that is registered to a different location to find-system,
+    ;; we also need to remember it in the asdf-cache.
+    (with-asdf-cache ()
+      (let* ((name (coerce-name name))
+             (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
+             (registered (system-registered-p name))
+             (registered! (if registered
+                              (rplaca registered (get-file-stamp source-file))
+                              (register-system
+                               (make-instance 'system :name name :source-file source-file))))
+             (system (reset-system (cdr registered!)
+                                   :name name :source-file source-file))
+             (component-options
+              (remove-plist-keys '(:defsystem-depends-on :class) options))
+             (defsystem-dependencies (loop :for spec :in defsystem-depends-on
+                                           :when (resolve-dependency-spec nil spec)
+                                           :collect :it)))
+        ;; cache defsystem-depends-on in canonical form
+        (when defsystem-depends-on
+          (setf component-options
+                (append `(:defsystem-depends-on ,(parse-dependency-defs defsystem-depends-on))
+                        component-options)))
+        (set-asdf-cache-entry `(find-system ,name) (list system))
+        (load-systems* defsystem-dependencies)
+        ;; We change-class AFTER we loaded the defsystem-depends-on
+        ;; since the class might be defined as part of those.
+        (let ((class (class-for-type nil class)))
+          (unless (subtypep class 'system)
+            (error 'non-system-system :name name :class-name (class-name class)))
+          (unless (eq (type-of system) class)
+            (change-class system class)))
+        (parse-component-form
+         nil (list*
+              :module name
+              :pathname (determine-system-directory pathname)
+              component-options)))))

-  (defun compiler-library-pathname ()
-    #+clasp (compile-file-pathname "sys:cmp" :output-type :lib)
-    #+ecl (compile-file-pathname "sys:cmp" :type :lib)
-    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))
+  (defmacro defsystem (name &body options)
+    `(apply 'register-system-definition ',name ',options)))
+;;;; -------------------------------------------------------------------------
+;;;; ASDF-Bundle

-  (defun make-library-system (name pathname)
-    (make-instance 'prebuilt-system
-                   :name (coerce-name name) :static-library (resolve-symlinks* pathname)))
+(uiop/package:define-package :asdf/bundle
+  (:recycle :asdf/bundle :asdf)
+  (:use :uiop/common-lisp :uiop :asdf/upgrade
+   :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
+   :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem)
+  (:export
+   #:bundle-op #:bundle-type #:program-system
+   #:bundle-system #:bundle-pathname-type #:direct-dependency-files
+   #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
+   #:basic-compile-bundle-op #:prepare-bundle-op
+   #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
+   #:lib-op #:monolithic-lib-op
+   #:dll-op #:monolithic-dll-op
+   #:deliver-asd-op #:monolithic-deliver-asd-op
+   #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
+   #:user-system-p #:user-system #:trivial-system-p
+   #:make-build
+   #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
+(in-package :asdf/bundle)

-  (defmethod component-depends-on :around ((o image-op) (c system))
-    (destructuring-bind ((lib-op . deps)) (call-next-method)
-      (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)))
-        `((,lib-op
-           ,@(unless (or (no-uiop c) (has-it-p "cmp"))
-               `(,(make-library-system
-                   "cmp" (compiler-library-pathname))))
-           ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
-               `(cond
-                  ((system-source-directory :uiop) `(,(find-system :uiop)))
-                  ((system-source-directory :asdf) `(,(find-system :asdf)))
-                  (t `(,@(if-let (uiop (uiop-library-pathname))
-                           `(,(make-library-system "uiop" uiop)))
-                       ,(make-library-system "asdf" (asdf-library-pathname))))))
-           ,@deps)))))
+(with-upgradability ()
+  (defclass bundle-op (basic-compile-op)
+    ((build-args :initarg :args :initform nil :accessor extra-build-args)
+     (name-suffix :initarg :name-suffix :initform nil)
+     (bundle-type :initform :no-output-file :reader bundle-type)
+     #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files)))

-  (defmethod perform ((o link-op) (c system))
-    (let* ((object-files (input-files o c))
-           (output (output-files o c))
-           (bundle (first output))
-           (programp (typep o 'program-op))
-           (kind (bundle-type o)))
-      (when output
-        (apply 'create-image
-               bundle (append
-                       (when programp (prefix-lisp-object-files c))
-                       object-files
-                       (when programp (postfix-lisp-object-files c)))
-               :kind kind
-               :prologue-code (or (prologue-code o) (when programp (prologue-code c)))
-               :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
-               :build-args (or (extra-build-args o) (when programp (extra-build-args c)))
-               :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c)))
-               :no-uiop (no-uiop c)
-               (when programp `(:entry-point ,(component-entry-point c))))))))
+  (defclass monolithic-op (operation) ()
+    (:documentation "A MONOLITHIC operation operates on a system *and all of its
+dependencies*.  So, for example, a monolithic concatenate operation will
+concatenate together a system's components and all of its dependencies, but a
+simple concatenate operation will concatenate only the components of the system
+itself.")) ;; operation on a system and its dependencies

-#+(and (not asdf-use-unsafe-mac-bundle-op)
-       (or (and clasp ecl darwin)
-           (and abcl darwin (not abcl-bundle-op-supported))))
-(defmethod perform :before ((o basic-compile-bundle-op) (c component))
-  (unless (featurep :asdf-use-unsafe-mac-bundle-op)
-    (cerror "Continue after modifying *FEATURES*."
-            "BASIC-COMPILE-BUNDLE-OP operations are not supported on Mac OS X for this lisp.~%~T~
-To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~
-Please report to ASDF-DEVEL if this works for you.")))
+  (defclass monolithic-bundle-op (monolithic-op bundle-op)
+    ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation
+    ((prologue-code :initform nil :accessor prologue-code)
+     (epilogue-code :initform nil :accessor epilogue-code)))

+  (defclass program-system (system)
+    ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
+    ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
+     (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
+     (no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
+     (prefix-lisp-object-files :initarg :prefix-lisp-object-files
+                               :initform nil :accessor prefix-lisp-object-files)
+     (postfix-lisp-object-files :initarg :postfix-lisp-object-files
+                                :initform nil :accessor postfix-lisp-object-files)
+     (extra-object-files :initarg :extra-object-files
+                         :initform nil :accessor extra-object-files)
+     (extra-build-args :initarg :extra-build-args
+                       :initform nil :accessor extra-build-args)))

-;;; Backward compatibility with pre-3.1.2 names
-;; (defclass fasl-op (selfward-operation)
-;;   ((selfward-operation :initform 'compile-bundle-op :allocation :class)))
-;; (defclass load-fasl-op (selfward-operation)
-;;   ((selfward-operation :initform 'load-bundle-op :allocation :class)))
-;; (defclass binary-op (selfward-operation)
-;;   ((selfward-operation :initform 'deliver-asd-op :allocation :class)))
-;; (defclass monolithic-fasl-op (selfward-operation)
-;;   ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)))
-;; (defclass monolithic-load-fasl-op (selfward-operation)
-;;   ((selfward-operation :initform 'monolithic-load-bundle-op :allocation :class)))
-;; (defclass monolithic-binary-op (selfward-operation)
-;;   ((selfward-operation :initform 'monolithic-deliver-asd-op :allocation :class)))
-;;;; -------------------------------------------------------------------------
-;;;; Concatenate-source
+  (defmethod prologue-code ((x t)) nil)
+  (defmethod epilogue-code ((x t)) nil)
+  (defmethod no-uiop ((x t)) nil)
+  (defmethod prefix-lisp-object-files ((x t)) nil)
+  (defmethod postfix-lisp-object-files ((x t)) nil)
+  (defmethod extra-object-files ((x t)) nil)
+  (defmethod extra-build-args ((x t)) nil)

-(uiop/package:define-package :asdf/concatenate-source
-  (:recycle :asdf/concatenate-source :asdf)
-  (:use :uiop/common-lisp :uiop :asdf/upgrade
-   :asdf/component :asdf/operation
-   :asdf/system :asdf/find-system
-   :asdf/action :asdf/lisp-action :asdf/bundle)
-  (:export
-   #:concatenate-source-op
-   #:load-concatenated-source-op
-   #:compile-concatenated-source-op
-   #:load-compiled-concatenated-source-op
-   #:monolithic-concatenate-source-op
-   #:monolithic-load-concatenated-source-op
-   #:monolithic-compile-concatenated-source-op
-   #:monolithic-load-compiled-concatenated-source-op))
-(in-package :asdf/concatenate-source)
+  (defclass link-op (bundle-op) ()
+    (:documentation "Abstract operation for linking files together"))

-;;;
-;;; Concatenate sources
-;;;
-(with-upgradability ()
-  (defclass basic-concatenate-source-op (bundle-op)
-    ((bundle-type :initform "lisp")))
-  (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
-  (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
-  (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
+  (defclass gather-op (bundle-op)
+    ((gather-op :initform nil :allocation :class :reader gather-op)
+     (gather-type :initform :no-output-file :allocation :class :reader gather-type))
+    (:documentation "Abstract operation for gathering many input files from a system"))

-  (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ())
-  (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
-    ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)))
-  (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
-    ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)))
-  (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
-    ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class)))
+  (defun operation-monolithic-p (op)
+    (typep op 'monolithic-op))

-  (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ())
-  (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
-    ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)))
-  (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
-    ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)))
-  (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
-    ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class)))
+  (defmethod component-depends-on ((o gather-op) (s system))
+    (let* ((mono (operation-monolithic-p o))
+           (deps
+             (required-components
+              s :other-systems mono :component-type (if mono 'system '(not system))
+                :goal-operation (find-operation o 'load-op)
+                :keep-operation 'compile-op)))
+      ;; NB: the explicit make-operation on ECL and MKCL
+      ;; ensures that we drop the original-initargs and its magic flags when recursing.
+      `((,(make-operation (or (gather-op o) (if mono 'lib-op 'compile-op))) ,@deps)
+        ,@(call-next-method))))

-  (defmethod input-files ((operation basic-concatenate-source-op) (s system))
-    (loop :with encoding = (or (component-encoding s) *default-encoding*)
-          :with other-encodings = '()
-          :with around-compile = (around-compile-hook s)
-          :with other-around-compile = '()
-          :for c :in (required-components
-                      s :goal-operation 'compile-op
-                        :keep-operation 'compile-op
-                        :other-systems (operation-monolithic-p operation))
-          :append
-          (when (typep c 'cl-source-file)
-            (let ((e (component-encoding c)))
-              (unless (equal e encoding)
-                (let ((a (assoc e other-encodings)))
-                  (if a (push (component-find-path c) (cdr a))
-                      (push (list a (component-find-path c)) other-encodings)))))
-            (unless (equal around-compile (around-compile-hook c))
-              (push (component-find-path c) other-around-compile))
-            (input-files (make-operation 'compile-op) c)) :into inputs
-          :finally
-             (when other-encodings
-               (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}"
-                     operation encoding
-                     (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x)))))
-                             other-encodings)))
-             (when other-around-compile
-               (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
-                     operation around-compile other-around-compile))
-             (return inputs)))
-  (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
-    (lisp-compilation-output-files o s))
+  ;; create a single fasl for the entire library
+  (defclass basic-compile-bundle-op (bundle-op)
+    ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
+                  :allocation :class)
+     (bundle-type :initform :fasl :allocation :class)))

-  (defmethod perform ((o basic-concatenate-source-op) (s system))
-    (let* ((ins (input-files o s))
-           (out (output-file o s))
-           (tmp (tmpize-pathname out)))
-      (concatenate-files ins tmp)
-      (rename-file-overwriting-target tmp out)))
-  (defmethod perform ((o basic-load-concatenated-source-op) (s system))
-    (perform-lisp-load-source o s))
-  (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
-    (perform-lisp-compilation o s))
-  (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
-    (perform-lisp-load-fasl o s)))
+  (defclass prepare-bundle-op (sideway-operation)
+    ((sideway-operation
+      :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
+      :allocation :class)))

-;;;; ---------------------------------------------------------------------------
-;;;; asdf-output-translations
+  (defclass lib-op (link-op gather-op non-propagating-operation)
+    ((gather-type :initform :object :allocation :class)
+     (bundle-type :initform :lib :allocation :class))
+    (:documentation "Compile the system and produce a linkable static library (.a/.lib)
+for all the linkable object files associated with the system. Compare with DLL-OP.

-(uiop/package:define-package :asdf/output-translations
-  (:recycle :asdf/output-translations :asdf)
-  (:use :uiop/common-lisp :uiop :asdf/upgrade)
-  (:export
-   #:*output-translations* #:*output-translations-parameter*
-   #:invalid-output-translation
-   #:output-translations #:output-translations-initialized-p
-   #:initialize-output-translations #:clear-output-translations
-   #:disable-output-translations #:ensure-output-translations
-   #:apply-output-translations
-   #:validate-output-translations-directive #:validate-output-translations-form
-   #:validate-output-translations-file #:validate-output-translations-directory
-   #:parse-output-translations-string #:wrapping-output-translations
-   #:user-output-translations-pathname #:system-output-translations-pathname
-   #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
-   #:environment-output-translations #:process-output-translations
-   #:compute-output-translations
-   #+abcl #:translate-jar-pathname
-   ))
-(in-package :asdf/output-translations)
+On most implementations, these object files only include extensions to the runtime
+written in C or another language with a compiler producing linkable object files.
+On CLASP, ECL, MKCL, these object files also include the contents of Lisp files
+themselves. In any case, this operation will produce what you need to further build
+a static runtime for your system, or a dynamic library to load in an existing runtime."))

-(when-upgrading () (undefine-function '(setf output-translations)))
+  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
+                               #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op)
+    ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op)
+                         :allocation :class))
+    (:documentation "This operator is an alternative to COMPILE-OP. Build a system
+and all of its dependencies, but build only a single (\"monolithic\") FASL, instead
+of one per source file, which may be more resource efficient.  That monolithic
+FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP."))

-(with-upgradability ()
-  (define-condition invalid-output-translation (invalid-configuration warning)
-    ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
+  (defclass load-bundle-op (basic-load-op selfward-operation)
+    ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))
+    (:documentation "This operator is an alternative to LOAD-OP. Build a system
+and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with
+respect to LOAD-OP is that it builds only a single FASL, which may be
+faster and more resource efficient."))

-  (defvar *output-translations* ()
-    "Either NIL (for uninitialized), or a list of one element,
-said element itself being a sorted list of mappings.
-Each mapping is a pair of a source pathname and destination pathname,
-and the order is by decreasing length of namestring of the source pathname.")
+  ;; NB: since the monolithic-op's can't be sideway-operation's,
+  ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's,
+  ;; 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-compile-bundle-op above.

-  (defun output-translations ()
-    (car *output-translations*))
+  (defclass dll-op (link-op gather-op non-propagating-operation)
+    ((gather-type :initform :object :allocation :class)
+     (bundle-type :initform :dll :allocation :class))
+    (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
+for all the linkable object files associated with the system. Compare with LIB-OP."))
+
+  (defclass deliver-asd-op (basic-compile-op selfward-operation)
+    ((selfward-operation
+      ;; TODO: implement link-op on all implementations, and make that
+      ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op)
+      :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op)
+      :allocation :class))
+    (:documentation "produce an asd file for delivering the system as a single fasl"))

-  (defun set-output-translations (new-value)
-    (setf *output-translations*
-          (list
-           (stable-sort (copy-list new-value) #'>
-                        :key #'(lambda (x)
-                                 (etypecase (car x)
-                                   ((eql t) -1)
-                                   (pathname
-                                    (let ((directory (pathname-directory (car x))))
-                                      (if (listp directory) (length directory) 0))))))))
-    new-value)
-  (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))

-  (defun output-translations-initialized-p ()
-    (and *output-translations* t))
+  (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
+    ((selfward-operation
+      ;; TODO: implement link-op on all implementations, and make that
+      ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)
+      :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
+      :allocation :class))
+    (:documentation "produce fasl and asd files for combined system and dependencies."))

-  (defun clear-output-translations ()
-    "Undoes any initialization of the output translations."
-    (setf *output-translations* '())
-    (values))
-  (register-clear-configuration-hook 'clear-output-translations)
+  (defclass monolithic-compile-bundle-op
+      (monolithic-bundle-op basic-compile-bundle-op
+       #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation)
+    ((gather-op :initform #-(or clasp ecl mkcl) 'compile-bundle-op #+(or clasp ecl mkcl) 'lib-op
+                :allocation :class)
+     (gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :static-library
+                  :allocation :class))
+    (:documentation "Create a single fasl for the system and its dependencies."))

-  (defun validate-output-translations-directive (directive)
-    (or (member directive '(:enable-user-cache :disable-cache nil))
-        (and (consp directive)
-             (or (and (length=n-p directive 2)
-                      (or (and (eq (first directive) :include)
-                               (typep (second directive) '(or string pathname null)))
-                          (and (location-designator-p (first directive))
-                               (or (location-designator-p (second directive))
-                                   (location-function-p (second directive))))))
-                 (and (length=n-p directive 1)
-                      (location-designator-p (first directive)))))))
+  (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op)
+    ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
+    (:documentation "Load a single fasl for the system and its dependencies."))

-  (defun validate-output-translations-form (form &key location)
-    (validate-configuration-form
-     form
-     :output-translations
-     'validate-output-translations-directive
-     :location location :invalid-form-reporter 'invalid-output-translation))
+  (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation)
+    ((gather-type :initform :static-library :allocation :class))
+    (:documentation "Compile the system and produce a linkable static library (.a/.lib)
+for all the linkable object files associated with the system or its dependencies. See LIB-OP."))

-  (defun validate-output-translations-file (file)
-    (validate-configuration-file
-     file 'validate-output-translations-form :description "output translations"))
+  (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation)
+    ((gather-type :initform :static-library :allocation :class))
+    (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
+for all the linkable object files associated with the system or its dependencies. See LIB-OP"))

-  (defun validate-output-translations-directory (directory)
-    (validate-configuration-directory
-     directory :output-translations 'validate-output-translations-directive
-               :invalid-form-reporter 'invalid-output-translation))
+  (defclass image-op (monolithic-bundle-op selfward-operation
+                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op)
+    ((bundle-type :initform :image)
+     #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
+     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
+    (:documentation "create an image file from the system and its dependencies"))

-  (defun parse-output-translations-string (string &key location)
-    (cond
-      ((or (null string) (equal string ""))
-       '(:output-translations :inherit-configuration))
-      ((not (stringp string))
-       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
-      ((eql (char string 0) #\")
-       (parse-output-translations-string (read-from-string string) :location location))
-      ((eql (char string 0) #\()
-       (validate-output-translations-form (read-from-string string) :location location))
-      (t
-       (loop
-         :with inherit = nil
-         :with directives = ()
-         :with start = 0
-         :with end = (length string)
-         :with source = nil
-         :with separator = (inter-directory-separator)
-         :for i = (or (position separator string :start start) end) :do
-           (let ((s (subseq string start i)))
-             (cond
-               (source
-                (push (list source (if (equal "" s) nil s)) directives)
-                (setf source nil))
-               ((equal "" s)
-                (when inherit
-                  (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
-                         string))
-                (setf inherit t)
-                (push :inherit-configuration directives))
-               (t
-                (setf source s)))
-             (setf start (1+ i))
-             (when (> start end)
-               (when source
-                 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
-                        string))
-               (unless inherit
-                 (push :ignore-inherited-configuration directives))
-               (return `(:output-translations ,@(nreverse directives)))))))))
+  (defclass program-op (image-op)
+    ((bundle-type :initform :program))
+    (:documentation "create an executable file from the system and its dependencies"))

-  (defparameter* *default-output-translations*
-    '(environment-output-translations
-      user-output-translations-pathname
-      user-output-translations-directory-pathname
-      system-output-translations-pathname
-      system-output-translations-directory-pathname))
+  (defun bundle-pathname-type (bundle-type)
+    (etypecase bundle-type
+      ((or null string) ;; pass through nil or string literal
+       bundle-type)
+      ((eql :no-output-file) ;; marker for a bundle-type that has NO output file
+       (error "No output file, therefore no pathname type"))
+      ((eql :fasl) ;; the type of a fasl
+       #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output
+       #+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used as output for system bundles
+      ((member :image)
+       #+allegro "dxl"
+       #+(and clisp os-windows) "exe"
+       #-(or allegro (and clisp os-windows)) "image")
+      ;; NB: on CLASP and ECL these implementations, we better agree with
+      ;; (compile-file-type :type bundle-type))
+      ((eql :object) ;; the type of a linkable object file
+       (os-cond ((os-unix-p) "o")
+                ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj"))))
+      ((member :lib :static-library) ;; the type of a linkable library
+       (os-cond ((os-unix-p) "a")
+                ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
+      ((member :dll :shared-library) ;; the type of a shared library
+       (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
+      ((eql :program) ;; the type of an executable program
+       (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))

-  (defun wrapping-output-translations ()
-    `(:output-translations
-    ;; Some implementations have precompiled ASDF systems,
-    ;; so we must disable translations for implementation paths.
-      #+(or clasp #|clozure|# ecl mkcl sbcl)
-      ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
-          (when h `(((,h ,*wild-path*) ()))))
-      #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
-      ;; All-import, here is where we want user stuff to be:
-      :inherit-configuration
-      ;; These are for convenience, and can be overridden by the user:
-      #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
-      #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
-      ;; We enable the user cache by default, and here is the place we do:
-      :enable-user-cache))
+  (defun bundle-output-files (o c)
+    (let ((bundle-type (bundle-type o)))
+      (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
+                  (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))
+        (let ((name (or (component-build-pathname c)
+                        (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
+              (type (bundle-pathname-type bundle-type)))
+          (values (list (subpathname (component-pathname c) name :type type))
+                  (eq (type-of o) (coerce-class (component-build-operation c)
+                                                :package :asdf/interface
+                                                :super 'operation
+                                                :error nil)))))))

-  (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
-  (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
+  (defmethod output-files ((o bundle-op) (c system))
+    (bundle-output-files o c))

-  (defun user-output-translations-pathname (&key (direction :input))
-    (xdg-config-pathname *output-translations-file* direction))
-  (defun system-output-translations-pathname (&key (direction :input))
-    (find-preferred-file (system-config-pathnames *output-translations-file*)
-                         :direction direction))
-  (defun user-output-translations-directory-pathname (&key (direction :input))
-    (xdg-config-pathname *output-translations-directory* direction))
-  (defun system-output-translations-directory-pathname (&key (direction :input))
-    (find-preferred-file (system-config-pathnames *output-translations-directory*)
-                         :direction direction))
-  (defun environment-output-translations ()
-    (getenv "ASDF_OUTPUT_TRANSLATIONS"))
+  #-(or clasp ecl mkcl)
+  (progn
+    (defmethod perform ((o image-op) (c system))
+      (dump-image (output-file o c) :executable (typep o 'program-op)))
+    (defmethod perform :before ((o program-op) (c system))
+      (setf *image-entry-point* (ensure-function (component-entry-point c)))))

-  (defgeneric process-output-translations (spec &key inherit collect))
+  (defclass compiled-file (file-component)
+    ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")))

-  (defun inherit-output-translations (inherit &key collect)
-    (when inherit
-      (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
+  (defclass precompiled-system (system)
+    ((build-pathname :initarg :fasl)))

-  (defun* (process-output-translations-directive) (directive &key inherit collect)
-    (if (atom directive)
-        (ecase directive
-          ((:enable-user-cache)
-           (process-output-translations-directive '(t :user-cache) :collect collect))
-          ((:disable-cache)
-           (process-output-translations-directive '(t t) :collect collect))
-          ((:inherit-configuration)
-           (inherit-output-translations inherit :collect collect))
-          ((:ignore-inherited-configuration :ignore-invalid-entries nil)
-           nil))
-        (let ((src (first directive))
-              (dst (second directive)))
-          (if (eq src :include)
-              (when dst
-                (process-output-translations (pathname dst) :inherit nil :collect collect))
-              (when src
-                (let ((trusrc (or (eql src t)
-                                  (let ((loc (resolve-location src :ensure-directory t :wilden t)))
-                                    (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
-                  (cond
-                    ((location-function-p dst)
-                     (funcall collect
-                              (list trusrc (ensure-function (second dst)))))
-                    ((typep dst 'boolean)
-                     (funcall collect (list trusrc t)))
-                    (t
-                     (let* ((trudst (resolve-location dst :ensure-directory t :wilden t)))
-                       (funcall collect (list trudst t))
-                       (funcall collect (list trusrc trudst)))))))))))
+  (defclass prebuilt-system (system)
+    ((build-pathname :initarg :static-library :initarg :lib
+                     :accessor prebuilt-system-static-library))))

-  (defmethod process-output-translations ((x symbol) &key
-                                                       (inherit *default-output-translations*)
-                                                       collect)
-    (process-output-translations (funcall x) :inherit inherit :collect collect))
-  (defmethod process-output-translations ((pathname pathname) &key inherit collect)
-    (cond
-      ((directory-pathname-p pathname)
-       (process-output-translations (validate-output-translations-directory pathname)
-                                    :inherit inherit :collect collect))
-      ((probe-file* pathname :truename *resolve-symlinks*)
-       (process-output-translations (validate-output-translations-file pathname)
-                                    :inherit inherit :collect collect))
-      (t
-       (inherit-output-translations inherit :collect collect))))
-  (defmethod process-output-translations ((string string) &key inherit collect)
-    (process-output-translations (parse-output-translations-string string)
-                                 :inherit inherit :collect collect))
-  (defmethod process-output-translations ((x null) &key inherit collect)
-    (inherit-output-translations inherit :collect collect))
-  (defmethod process-output-translations ((form cons) &key inherit collect)
-    (dolist (directive (cdr (validate-output-translations-form form)))
-      (process-output-translations-directive directive :inherit inherit :collect collect)))

-  (defun compute-output-translations (&optional parameter)
-    "read the configuration, return it"
-    (remove-duplicates
-     (while-collecting (c)
-       (inherit-output-translations
-        `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
-     :test 'equal :from-end t))
+;;;
+;;; BUNDLE-OP
+;;;
+;;; This operation takes all components from one or more systems and
+;;; creates a single output file, which may be
+;;; a FASL, a statically linked library, a shared library, etc.
+;;; The different targets are defined by specialization.
+;;;
+(with-upgradability ()
+  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
+                                         &key (name-suffix nil name-suffix-p)
+                                         &allow-other-keys)
+    (declare (ignore initargs name-suffix))
+    (unless name-suffix-p
+      (setf (slot-value instance 'name-suffix)
+            (unless (typep instance 'program-op)
+              ;; "." is no good separator for Logical Pathnames, so we use "--"
+              (if (operation-monolithic-p instance) "--all-systems" #-(or clasp ecl mkcl) "--system"))))
+    (when (typep instance 'monolithic-bundle-op)
+      (destructuring-bind (&key lisp-files prologue-code epilogue-code
+                           &allow-other-keys)
+          (operation-original-initargs instance)
+        (setf (prologue-code instance) prologue-code
+              (epilogue-code instance) epilogue-code)
+        #-(or clasp ecl) (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
+        #+(or clasp ecl) (setf (extra-object-files instance) lisp-files)))
+    (setf (extra-build-args instance)
+          (remove-plist-keys
+           '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files
+             :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments
+           (operation-original-initargs instance))))

-  (defvar *output-translations-parameter* nil)
+  (defgeneric* (trivial-system-p) (component))

-  (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
-    "read the configuration, initialize the internal configuration variable,
-return the configuration"
-    (setf *output-translations-parameter* parameter
-          (output-translations) (compute-output-translations parameter)))
+  (defun user-system-p (s)
+    (and (typep s 'system)
+         (not (builtin-system-p s))
+         (not (trivial-system-p s)))))

-  (defun disable-output-translations ()
-    "Initialize output translations in a way that maps every file to itself,
-effectively disabling the output translation facility."
-    (initialize-output-translations
-     '(:output-translations :disable-cache :ignore-inherited-configuration)))
+(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
+  (deftype user-system () '(and system (satisfies user-system-p))))

-  ;; checks an initial variable to see whether the state is initialized
-  ;; or cleared. In the former case, return current configuration; in
-  ;; the latter, initialize.  ASDF will call this function at the start
-  ;; of (asdf:find-system).
-  (defun ensure-output-translations ()
-    (if (output-translations-initialized-p)
-        (output-translations)
-        (initialize-output-translations)))
+;;;
+;;; First we handle monolithic bundles.
+;;; These are standalone systems which contain everything,
+;;; including other ASDF systems required by the current one.
+;;; A PROGRAM is always monolithic.
+;;;
+;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
+;;;
+(with-upgradability ()
+  (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
+    ;; This file selects output files from direct dependencies;
+    ;; your component-depends-on method better gathered the correct dependencies in the correct order.
+    (while-collecting (collect)
+      (map-direct-dependencies
+       t o c #'(lambda (sub-o sub-c)
+                 (loop :for f :in (funcall key sub-o sub-c)
+                       :when (funcall test f) :do (collect f))))))

-  (defun* (apply-output-translations) (path)
-    (etypecase path
-      (logical-pathname
-       path)
-      ((or pathname string)
-       (ensure-output-translations)
-       (loop* :with p = (resolve-symlinks* path)
-              :for (source destination) :in (car *output-translations*)
-              :for root = (when (or (eq source t)
-                                    (and (pathnamep source)
-                                         (not (absolute-pathname-p source))))
-                            (pathname-root p))
-              :for absolute-source = (cond
-                                       ((eq source t) (wilden root))
-                                       (root (merge-pathnames* source root))
-                                       (t source))
-              :when (or (eq source t) (pathname-match-p p absolute-source))
-              :return (translate-pathname* p absolute-source destination root source)
-              :finally (return p)))))
+  (defun pathname-type-equal-function (type)
+    #'(lambda (p) (equal (pathname-type p) type)))

-  ;; Hook into uiop's output-translation mechanism
-  #-cormanlisp
-  (setf *output-translation-function* 'apply-output-translations)
+  (defmethod input-files ((o gather-op) (c system))
+    (unless (eq (bundle-type o) :no-output-file)
+      (direct-dependency-files
+       o c :key 'output-files
+           :test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))

-  #+abcl
-  (defun translate-jar-pathname (source wildcard)
-    (declare (ignore wildcard))
-    (flet ((normalize-device (pathname)
-             (if (find :windows *features*)
-                 pathname
-                 (make-pathname :defaults pathname :device :unspecific))))
-      (let* ((jar
-               (pathname (first (pathname-device source))))
-             (target-root-directory-namestring
-               (format nil "/___jar___file___root___/~@[~A/~]"
-                       (and (find :windows *features*)
-                            (pathname-device jar))))
-             (relative-source
-               (relativize-pathname-directory source))
-             (relative-jar
-               (relativize-pathname-directory (ensure-directory-pathname jar)))
-             (target-root-directory
-               (normalize-device
-                (pathname-directory-pathname
-                 (parse-namestring target-root-directory-namestring))))
-             (target-root
-               (merge-pathnames* relative-jar target-root-directory))
-             (target
-               (merge-pathnames* relative-source target-root)))
-        (normalize-device (apply-output-translations target))))))
+  (defun select-bundle-operation (type &optional monolithic)
+    (ecase type
+      ((:dll :shared-library)
+       (if monolithic 'monolithic-dll-op 'dll-op))
+      ((:lib :static-library)
+       (if monolithic 'monolithic-lib-op 'lib-op))
+      ((:fasl)
+       (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
+      ((:image)
+       'image-op)
+      ((:program)
+       'program-op)))

-;;;; -----------------------------------------------------------------
-;;;; Source Registry Configuration, by Francois-Rene Rideau
-;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
+  ;; DEPRECATED. This is originally from asdf-ecl.lisp. Does anyone use it?
+  (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
+                             (move-here nil move-here-p)
+                             &allow-other-keys)
+    (let* ((operation-name (select-bundle-operation type monolithic))
+           (move-here-path (if (and move-here
+                                    (typep move-here '(or pathname string)))
+                               (ensure-pathname move-here :namestring :lisp :ensure-directory t)
+                               (system-relative-pathname system "asdf-output/")))
+           (operation (apply #'operate operation-name
+                             system
+                             (remove-plist-keys '(:monolithic :type :move-here) args)))
+           (system (find-system system))
+           (files (and system (output-files operation system))))
+      (if (or move-here (and (null move-here-p)
+                             (member operation-name '(:program :image))))
+          (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
+                :for f :in files
+                :for new-f = (make-pathname :name (pathname-name f)
+                                            :type (pathname-type f)
+                                            :defaults dest-path)
+                :do (rename-file-overwriting-target f new-f)
+                :collect new-f)
+          files)))

-(uiop/package:define-package :asdf/source-registry
-  (:recycle :asdf/source-registry :asdf)
-  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
-  (:export
-   #:*source-registry-parameter* #:*default-source-registries*
-   #:invalid-source-registry
-   #:source-registry-initialized-p
-   #:initialize-source-registry #:clear-source-registry #:*source-registry*
-   #:ensure-source-registry #:*source-registry-parameter*
-   #:*default-source-registry-exclusions* #:*source-registry-exclusions*
-   #:*wild-asd* #:directory-asd-files #:register-asd-directory
-   #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files
-   #:validate-source-registry-directive #:validate-source-registry-form
-   #:validate-source-registry-file #:validate-source-registry-directory
-   #:parse-source-registry-string #:wrapping-source-registry
-   #:default-user-source-registry #:default-system-source-registry
-   #:user-source-registry #:system-source-registry
-   #:user-source-registry-directory #:system-source-registry-directory
-   #:environment-source-registry #:process-source-registry
-   #:compute-source-registry #:flatten-source-registry
-   #:sysdef-source-registry-search))
-(in-package :asdf/source-registry)
+  ;; DEPRECATED. Does anyone use this?
+  (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
+    (declare (ignore force verbose version))
+    (apply #'operate 'deliver-asd-op system args)))

+;;;
+;;; LOAD-BUNDLE-OP
+;;;
+;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
+;;;
 (with-upgradability ()
-  (define-condition invalid-source-registry (invalid-configuration warning)
-    ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-
-  ;; Using ack 1.2 exclusions
-  (defvar *default-source-registry-exclusions*
-    '(".bzr" ".cdv"
-      ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
-      ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
-      "_sgbak" "autom4te.cache" "cover_db" "_build"
-      "debian")) ;; debian often builds stuff under the debian directory... BAD.
-
-  (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
+  (defmethod component-depends-on ((o load-bundle-op) (c system))
+    `((,o ,@(component-sideway-dependencies c))
+      (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
+      ,@(call-next-method)))

-  (defvar *source-registry* nil
-    "Either NIL (for uninitialized), or an equal hash-table, mapping
-system names to pathnames of .asd files")
+  (defmethod input-files ((o load-bundle-op) (c system))
+    (when (user-system-p c)
+      (output-files (find-operation o 'compile-bundle-op) c)))

-  (defun source-registry-initialized-p ()
-    (typep *source-registry* 'hash-table))
+  (defmethod perform ((o load-bundle-op) (c system))
+    (when (input-files o c)
+      (perform-lisp-load-fasl o c)))

-  (defun clear-source-registry ()
-    "Undoes any initialization of the source registry."
-    (setf *source-registry* nil)
-    (values))
-  (register-clear-configuration-hook 'clear-source-registry)
+  (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
+    (mark-operation-done (find-operation o 'load-op) c)))

-  (defparameter *wild-asd*
-    (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
+;;;
+;;; PRECOMPILED FILES
+;;;
+;;; This component can be used to distribute ASDF systems in precompiled form.
+;;; Only useful when the dependencies have also been precompiled.
+;;;
+(with-upgradability ()
+  (defmethod trivial-system-p ((s system))
+    (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))

-  (defun directory-asd-files (directory)
-    (directory-files directory *wild-asd*))
+  (defmethod input-files ((o operation) (c compiled-file))
+    (list (component-pathname c)))
+  (defmethod perform ((o load-op) (c compiled-file))
+    (perform-lisp-load-fasl o c))
+  (defmethod perform ((o load-source-op) (c compiled-file))
+    (perform (find-operation o 'load-op) c))
+  (defmethod perform ((o operation) (c compiled-file))
+    nil))

-  (defun collect-asds-in-directory (directory collect)
-    (let ((asds (directory-asd-files directory)))
-      (map () collect asds)
-      asds))
+;;;
+;;; Pre-built systems
+;;;
+(with-upgradability ()
+  (defmethod trivial-system-p ((s prebuilt-system))
+    t)

-  (defvar *recurse-beyond-asds* t
-    "Should :tree entries of the source-registry recurse in subdirectories
-after having found a .asd file? True by default.")
+  (defmethod perform ((o link-op) (c prebuilt-system))
+    nil)

-  (defun process-source-registry-cache (directory collect)
-    (let ((cache (ignore-errors
-                  (safe-read-file-form (subpathname directory ".cl-source-registry.cache")))))
-      (when (and (listp cache) (eq :source-registry-cache (first cache)))
-        (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s)))
-        t)))
+  (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
+    nil)

-  (defun collect-sub*directories-asd-files
-      (directory &key (exclude *default-source-registry-exclusions*) collect
-                   (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache)
-    (collect-sub*directories
-     directory
-     #'(lambda (dir)
-         (unless (and (not ignore-cache) (process-source-registry-cache directory collect))
-           (let ((asds (collect-asds-in-directory dir collect)))
-             (or recurse-beyond-asds (not asds)))))
-     #'(lambda (x)
-         (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
-     (constantly nil)))
+  (defmethod perform ((o lib-op) (c prebuilt-system))
+    nil)

-  (defun validate-source-registry-directive (directive)
-    (or (member directive '(:default-registry))
-        (and (consp directive)
-             (let ((rest (rest directive)))
-               (case (first directive)
-                 ((:include :directory :tree)
-                  (and (length=n-p rest 1)
-                       (location-designator-p (first rest))))
-                 ((:exclude :also-exclude)
-                  (every #'stringp rest))
-                 ((:default-registry)
-                  (null rest)))))))
+  (defmethod perform ((o dll-op) (c prebuilt-system))
+    nil)

-  (defun validate-source-registry-form (form &key location)
-    (validate-configuration-form
-     form :source-registry 'validate-source-registry-directive
-          :location location :invalid-form-reporter 'invalid-source-registry))
+  (defmethod component-depends-on ((o gather-op) (c prebuilt-system))
+    nil)

-  (defun validate-source-registry-file (file)
-    (validate-configuration-file
-     file 'validate-source-registry-form :description "a source registry"))
+  (defmethod output-files ((o lib-op) (c prebuilt-system))
+    (values (list (prebuilt-system-static-library c)) t)))

-  (defun validate-source-registry-directory (directory)
-    (validate-configuration-directory
-     directory :source-registry 'validate-source-registry-directive
-               :invalid-form-reporter 'invalid-source-registry))

-  (defun parse-source-registry-string (string &key location)
-    (cond
-      ((or (null string) (equal string ""))
-       '(:source-registry :inherit-configuration))
-      ((not (stringp string))
-       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
-      ((find (char string 0) "\"(")
-       (validate-source-registry-form (read-from-string string) :location location))
-      (t
-       (loop
-         :with inherit = nil
-         :with directives = ()
-         :with start = 0
-         :with end = (length string)
-         :with separator = (inter-directory-separator)
-         :for pos = (position separator string :start start) :do
-           (let ((s (subseq string start (or pos end))))
-             (flet ((check (dir)
-                      (unless (absolute-pathname-p dir)
-                        (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
-                      dir))
-               (cond
-                 ((equal "" s) ; empty element: inherit
-                  (when inherit
-                    (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
-                           string))
-                  (setf inherit t)
-                  (push ':inherit-configuration directives))
-                 ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
-                  (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
-                 (t
-                  (push `(:directory ,(check s)) directives))))
-             (cond
-               (pos
-                (setf start (1+ pos)))
-               (t
-                (unless inherit
-                  (push '(:ignore-inherited-configuration) directives))
-                (return `(:source-registry ,@(nreverse directives))))))))))
+;;;
+;;; PREBUILT SYSTEM CREATOR
+;;;
+(with-upgradability ()
+  (defmethod output-files ((o deliver-asd-op) (s system))
+    (list (make-pathname :name (component-name s) :type "asd"
+                         :defaults (component-pathname s))))

-  (defun register-asd-directory (directory &key recurse exclude collect)
-    (if (not recurse)
-        (collect-asds-in-directory directory collect)
-        (collect-sub*directories-asd-files
-         directory :exclude exclude :collect collect)))
+  (defmethod perform ((o deliver-asd-op) (s system))
+    (let* ((inputs (input-files o s))
+           (fasl (first inputs))
+           (library (second inputs))
+           (asd (first (output-files o s)))
+           (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
+           (version (component-version s))
+           (dependencies
+             (if (operation-monolithic-p o)
+                 (remove-if-not 'builtin-system-p
+                                (required-components s :component-type 'system
+                                                       :keep-operation 'load-op))
+                 (while-collecting (x) ;; resolve the sideway-dependencies of s
+                   (map-direct-dependencies
+                    t 'load-op s
+                    #'(lambda (o c)
+                        (when (and (typep o 'load-op) (typep c 'system))
+                          (x c)))))))
+           (depends-on (mapcar 'coerce-name dependencies)))
+      (when (pathname-equal asd (system-source-file s))
+        (cerror "overwrite the asd file"
+                "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
+                (cons o s) asd))
+      (with-open-file (s asd :direction :output :if-exists :supersede
+                             :if-does-not-exist :create)
+        (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
+                (operation-monolithic-p o) name)
+        (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
+                (lisp-implementation-type)
+                (lisp-implementation-version)
+                (software-type)
+                (machine-type)
+                (software-version))
+        (let ((*package* (find-package :asdf-user)))
+          (pprint `(defsystem ,name
+                     :class prebuilt-system
+                     :version ,version
+                     :depends-on ,depends-on
+                     :components ((:compiled-file ,(pathname-name fasl)))
+                     ,@(when library `(:lib ,(file-namestring library))))
+                  s)
+          (terpri s)))))

-  (defparameter* *default-source-registries*
-    '(environment-source-registry
-      user-source-registry
-      user-source-registry-directory
-      default-user-source-registry
-      system-source-registry
-      system-source-registry-directory
-      default-system-source-registry)
-    "List of default source registries" "3.1.0.102")
+  #-(or clasp ecl mkcl)
+  (defmethod perform ((o basic-compile-bundle-op) (c system))
+    (let* ((input-files (input-files o c))
+           (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
+           (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
+           (output-files (output-files o c))
+           (output-file (first output-files)))
+      (assert (eq (not input-files) (not output-files)))
+      (when input-files
+        (when non-fasl-files
+          (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
+                 (implementation-type) non-fasl-files))
+        (when (or (prologue-code o) (epilogue-code o)
+                  (prologue-code c) (epilogue-code c))
+          (error "prologue-code and epilogue-code are not supported on ~A"
+                 (implementation-type)))
+        (with-staging-pathname (output-file)
+          (combine-fasls fasl-files output-file)))))

-  (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
-  (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))
+  (defmethod input-files ((o load-op) (s precompiled-system))
+    (bundle-output-files (find-operation o 'compile-bundle-op) s))

-  (defun wrapping-source-registry ()
-    `(:source-registry
-      #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
-      :inherit-configuration
-      #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
-      #+cmu (:tree #p"modules:")
-      #+scl (:tree #p"file://modules/")))
-  (defun default-user-source-registry ()
-    `(:source-registry
-      (:tree (:home "common-lisp/"))
-      #+sbcl (:directory (:home ".sbcl/systems/"))
-      (:directory ,(xdg-data-home "common-lisp/systems/"))
-      (:tree ,(xdg-data-home "common-lisp/source/"))
-      :inherit-configuration))
-  (defun default-system-source-registry ()
-    `(:source-registry
-      ,@(loop :for dir :in (xdg-data-dirs "common-lisp/")
-              :collect `(:directory (,dir "systems/"))
-              :collect `(:tree (,dir "source/")))
-      :inherit-configuration))
-  (defun user-source-registry (&key (direction :input))
-    (xdg-config-pathname *source-registry-file* direction))
-  (defun system-source-registry (&key (direction :input))
-    (find-preferred-file (system-config-pathnames *source-registry-file*)
-                         :direction direction))
-  (defun user-source-registry-directory (&key (direction :input))
-    (xdg-config-pathname *source-registry-directory* direction))
-  (defun system-source-registry-directory (&key (direction :input))
-    (find-preferred-file (system-config-pathnames *source-registry-directory*)
-                         :direction direction))
-  (defun environment-source-registry ()
-    (getenv "CL_SOURCE_REGISTRY"))
+  (defmethod perform ((o load-op) (s precompiled-system))
+    (perform-lisp-load-fasl o s))

-  (defgeneric* (process-source-registry) (spec &key inherit register))
+  (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
+    #+xcl (declare (ignorable o))
+    `((load-op ,s) ,@(call-next-method))))

-  (defun* (inherit-source-registry) (inherit &key register)
-    (when inherit
-      (process-source-registry (first inherit) :register register :inherit (rest inherit))))
+#| ;; Example use:
+(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
+(asdf:load-system :precompiled-asdf-utils)
+|#

-  (defun* (process-source-registry-directive) (directive &key inherit register)
-    (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
-      (ecase kw
-        ((:include)
-         (destructuring-bind (pathname) rest
-           (process-source-registry (resolve-location pathname) :inherit nil :register register)))
-        ((:directory)
-         (destructuring-bind (pathname) rest
-           (when pathname
-             (funcall register (resolve-location pathname :ensure-directory t)))))
-        ((:tree)
-         (destructuring-bind (pathname) rest
-           (when pathname
-             (funcall register (resolve-location pathname :ensure-directory t)
-                      :recurse t :exclude *source-registry-exclusions*))))
-        ((:exclude)
-         (setf *source-registry-exclusions* rest))
-        ((:also-exclude)
-         (appendf *source-registry-exclusions* rest))
-        ((:default-registry)
-         (inherit-source-registry
-          '(default-user-source-registry default-system-source-registry) :register register))
-        ((:inherit-configuration)
-         (inherit-source-registry inherit :register register))
-        ((:ignore-inherited-configuration)
-         nil)))
-    nil)
+#+(or clasp ecl mkcl)
+(with-upgradability ()
+  ;; I think that Juanjo intended for this to be, but it was disabled before 3.1
+  ;; due to implementation bugs in ECL and MKCL that seem to have been fixed since
+  ;; -- see for ECL test-xach-update-bug.script and test-bundle.script,
+  ;; and for MKCL test-logical-pathname.script.
+  ;; We should probably reenable these after consulting with ECL and MKCL maintainers.
+  ;;(unless (or #+(or clasp ecl) (use-ecl-byte-compiler-p))
+  ;;  (setf *load-system-operation* 'load-bundle-op))
+
+  (defun uiop-library-pathname ()
+    #+clasp (probe-file* (compile-file-pathname "sys:uiop" :output-type :object))
+    #+ecl (or (probe-file* (compile-file-pathname "sys:uiop" :type :lib)) ;; new style
+              (probe-file* (compile-file-pathname "sys:uiop" :type :object))) ;; old style
+    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;uiop"))
+
+  (defun asdf-library-pathname ()
+    #+clasp (probe-file* (compile-file-pathname "sys:asdf" :output-type :object))
+    #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style
+              (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style
+    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf"))
+
+  (defun compiler-library-pathname ()
+    #+clasp (compile-file-pathname "sys:cmp" :output-type :lib)
+    #+ecl (compile-file-pathname "sys:cmp" :type :lib)
+    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))
+
+  (defun make-library-system (name pathname)
+    (make-instance 'prebuilt-system
+                   :name (coerce-name name) :static-library (resolve-symlinks* pathname)))
+
+  (defmethod component-depends-on :around ((o image-op) (c system))
+    (destructuring-bind ((lib-op . deps)) (call-next-method)
+      (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)))
+        `((,lib-op
+           ,@(unless (or (no-uiop c) (has-it-p "cmp"))
+               `(,(make-library-system
+                   "cmp" (compiler-library-pathname))))
+           ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
+               (cond
+                 ((system-source-directory :uiop) `(,(find-system :uiop)))
+                 ((system-source-directory :asdf) `(,(find-system :asdf)))
+                 (t `(,@(if-let (uiop (uiop-library-pathname))
+                          `(,(make-library-system "uiop" uiop)))
+                      ,(make-library-system "asdf" (asdf-library-pathname))))))
+           ,@deps)))))

-  (defmethod process-source-registry ((x symbol) &key inherit register)
-    (process-source-registry (funcall x) :inherit inherit :register register))
-  (defmethod process-source-registry ((pathname pathname) &key inherit register)
-    (cond
-      ((directory-pathname-p pathname)
-       (let ((*here-directory* (resolve-symlinks* pathname)))
-         (process-source-registry (validate-source-registry-directory pathname)
-                                  :inherit inherit :register register)))
-      ((probe-file* pathname :truename *resolve-symlinks*)
-       (let ((*here-directory* (pathname-directory-pathname pathname)))
-         (process-source-registry (validate-source-registry-file pathname)
-                                  :inherit inherit :register register)))
-      (t
-       (inherit-source-registry inherit :register register))))
-  (defmethod process-source-registry ((string string) &key inherit register)
-    (process-source-registry (parse-source-registry-string string)
-                             :inherit inherit :register register))
-  (defmethod process-source-registry ((x null) &key inherit register)
-    (inherit-source-registry inherit :register register))
-  (defmethod process-source-registry ((form cons) &key inherit register)
-    (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
-      (dolist (directive (cdr (validate-source-registry-form form)))
-        (process-source-registry-directive directive :inherit inherit :register register))))
+  (defmethod perform ((o link-op) (c system))
+    (let* ((object-files (input-files o c))
+           (output (output-files o c))
+           (bundle (first output))
+           (programp (typep o 'program-op))
+           (kind (bundle-type o)))
+      (when output
+        (apply 'create-image
+               bundle (append
+                       (when programp (prefix-lisp-object-files c))
+                       object-files
+                       (when programp (postfix-lisp-object-files c)))
+               :kind kind
+               :prologue-code (or (prologue-code o) (when programp (prologue-code c)))
+               :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
+               :build-args (or (extra-build-args o) (when programp (extra-build-args c)))
+               :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c)))
+               :no-uiop (no-uiop c)
+               (when programp `(:entry-point ,(component-entry-point c))))))))

-  (defun flatten-source-registry (&optional parameter)
-    (remove-duplicates
-     (while-collecting (collect)
-       (with-pathname-defaults () ;; be location-independent
-         (inherit-source-registry
-          `(wrapping-source-registry
-            ,parameter
-            ,@*default-source-registries*)
-          :register #'(lambda (directory &key recurse exclude)
-                        (collect (list directory :recurse recurse :exclude exclude))))))
-     :test 'equal :from-end t))
+#+(and (not asdf-use-unsafe-mac-bundle-op)
+       (or (and clasp ecl darwin)
+           (and abcl darwin (not abcl-bundle-op-supported))))
+(defmethod perform :before ((o basic-compile-bundle-op) (c component))
+  (unless (featurep :asdf-use-unsafe-mac-bundle-op)
+    (cerror "Continue after modifying *FEATURES*."
+            "BASIC-COMPILE-BUNDLE-OP operations are not supported on Mac OS X for this lisp.~%~T~
+To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~
+Please report to ASDF-DEVEL if this works for you.")))
+;;;; -------------------------------------------------------------------------
+;;;; Concatenate-source

-  ;; Will read the configuration and initialize all internal variables.
-  (defun compute-source-registry (&optional parameter (registry *source-registry*))
-    (dolist (entry (flatten-source-registry parameter))
-      (destructuring-bind (directory &key recurse exclude) entry
-        (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
-          (register-asd-directory
-           directory :recurse recurse :exclude exclude :collect
-           #'(lambda (asd)
-               (let* ((name (pathname-name asd))
-                      (name (if (typep asd 'logical-pathname)
-                                ;; logical pathnames are upper-case,
-                                ;; at least in the CLHS and on SBCL,
-                                ;; yet (coerce-name :foo) is lower-case.
-                                ;; won't work well with (load-system "Foo")
-                                ;; instead of (load-system 'foo)
-                                (string-downcase name)
-                                name)))
-                 (cond
-                   ((gethash name registry) ; already shadowed by something else
-                    nil)
-                   ((gethash name h) ; conflict at current level
-                    (when *verbose-out*
-                      (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
-                                found several entries for ~A - picking ~S over ~S~:>")
-                            directory recurse name (gethash name h) asd)))
-                   (t
-                    (setf (gethash name registry) asd)
-                    (setf (gethash name h) asd))))))
-          h)))
-    (values))
+(uiop/package:define-package :asdf/concatenate-source
+  (:recycle :asdf/concatenate-source :asdf)
+  (:use :uiop/common-lisp :uiop :asdf/upgrade
+   :asdf/component :asdf/operation
+   :asdf/system :asdf/find-system
+   :asdf/action :asdf/lisp-action :asdf/bundle)
+  (:export
+   #:concatenate-source-op
+   #:load-concatenated-source-op
+   #:compile-concatenated-source-op
+   #:load-compiled-concatenated-source-op
+   #:monolithic-concatenate-source-op
+   #:monolithic-load-concatenated-source-op
+   #:monolithic-compile-concatenated-source-op
+   #:monolithic-load-compiled-concatenated-source-op))
+(in-package :asdf/concatenate-source)

-  (defvar *source-registry-parameter* nil)
+;;;
+;;; Concatenate sources
+;;;
+(with-upgradability ()
+  (defclass basic-concatenate-source-op (bundle-op)
+    ((bundle-type :initform "lisp")))
+  (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
+  (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
+  (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())

-  (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
-    ;; Record the parameter used to configure the registry
-    (setf *source-registry-parameter* parameter)
-    ;; Clear the previous registry database:
-    (setf *source-registry* (make-hash-table :test 'equal))
-    ;; Do it!
-    (compute-source-registry parameter))
+  (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ())
+  (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
+    ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)))
+  (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
+    ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)))
+  (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
+    ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class)))

-  ;; Checks an initial variable to see whether the state is initialized
-  ;; or cleared. In the former case, return current configuration; in
-  ;; the latter, initialize.  ASDF will call this function at the start
-  ;; of (asdf:find-system) to make sure the source registry is initialized.
-  ;; However, it will do so *without* a parameter, at which point it
-  ;; will be too late to provide a parameter to this function, though
-  ;; you may override the configuration explicitly by calling
-  ;; initialize-source-registry directly with your parameter.
-  (defun ensure-source-registry (&optional parameter)
-    (unless (source-registry-initialized-p)
-      (initialize-source-registry parameter))
-    (values))
+  (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ())
+  (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
+    ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)))
+  (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
+    ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)))
+  (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
+    ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class)))

-  (defun sysdef-source-registry-search (system)
-    (ensure-source-registry)
-    (values (gethash (primary-system-name system) *source-registry*))))
+  (defmethod input-files ((operation basic-concatenate-source-op) (s system))
+    (loop :with encoding = (or (component-encoding s) *default-encoding*)
+          :with other-encodings = '()
+          :with around-compile = (around-compile-hook s)
+          :with other-around-compile = '()
+          :for c :in (required-components
+                      s :goal-operation 'compile-op
+                        :keep-operation 'compile-op
+                        :other-systems (operation-monolithic-p operation))
+          :append
+          (when (typep c 'cl-source-file)
+            (let ((e (component-encoding c)))
+              (unless (equal e encoding)
+                (let ((a (assoc e other-encodings)))
+                  (if a (push (component-find-path c) (cdr a))
+                      (push (list a (component-find-path c)) other-encodings)))))
+            (unless (equal around-compile (around-compile-hook c))
+              (push (component-find-path c) other-around-compile))
+            (input-files (make-operation 'compile-op) c)) :into inputs
+          :finally
+             (when other-encodings
+               (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}"
+                     operation encoding
+                     (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x)))))
+                             other-encodings)))
+             (when other-around-compile
+               (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
+                     operation around-compile other-around-compile))
+             (return inputs)))
+  (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
+    (lisp-compilation-output-files o s))

+  (defmethod perform ((o basic-concatenate-source-op) (s system))
+    (let* ((ins (input-files o s))
+           (out (output-file o s))
+           (tmp (tmpize-pathname out)))
+      (concatenate-files ins tmp)
+      (rename-file-overwriting-target tmp out)))
+  (defmethod perform ((o basic-load-concatenated-source-op) (s system))
+    (perform-lisp-load-source o s))
+  (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
+    (perform-lisp-compilation o s))
+  (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
+    (perform-lisp-load-fasl o s)))

 ;;;; -------------------------------------------------------------------------
 ;;;; Package systems in the style of quick-build or faslpath
@@ -11191,7 +11237,7 @@ otherwise return a default system name computed from PACKAGE-NAME."
       (unless (equal primary system)
         (let ((top (find-system primary nil)))
           (when (typep top 'package-inferred-system)
-            (if-let (dir (system-source-directory top))
+            (if-let (dir (component-pathname top))
               (let* ((sub (subseq system (1+ (length primary))))
                      (f (probe-file* (subpathname dir sub :type "lisp")
                                      :truename *resolve-symlinks*)))
@@ -11213,6 +11259,33 @@ otherwise return a default system name computed from PACKAGE-NAME."
         (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
                 *system-definition-search-functions*)))
 ;;;; -------------------------------------------------------------------------
+;;; Internal hacks for backward-compatibility
+
+(uiop/package:define-package :asdf/backward-internals
+  (:recycle :asdf/backward-internals :asdf)
+  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
+  (:export ;; for internal use
+   #:make-sub-operation
+   #:load-sysdef #:make-temporary-package))
+(in-package :asdf/backward-internals)
+
+(when-upgrading (:when (fboundp 'make-sub-operation))
+  (defun make-sub-operation (c o dep-c dep-o)
+    (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
+
+;;;; load-sysdef
+(with-upgradability ()
+  (defun load-sysdef (name pathname)
+    (load-asd pathname :name name))
+
+  (defun make-temporary-package ()
+    ;; For loading a .asd file, we don't make a temporary package anymore,
+    ;; but use ASDF-USER. I'd like to have this function do this,
+    ;; but since whoever uses it is likely to delete-package the result afterwards,
+    ;; this would be a bad idea, so preserve the old behavior.
+    (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
+
+;;;; -------------------------------------------------------------------------
 ;;; Backward-compatible interfaces

 (uiop/package:define-package :asdf/backward-interface
@@ -11385,33 +11458,6 @@ Please use UIOP:RUN-PROGRAM instead."
           (setf (slot-value c 'properties)
                 (acons property new-value (slot-value c 'properties)))))
     new-value))
-;;;; -------------------------------------------------------------------------
-;;; Internal hacks for backward-compatibility
-
-(uiop/package:define-package :asdf/backward-internals
-  (:recycle :asdf/backward-internals :asdf)
-  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
-  (:export ;; for internal use
-   #:make-sub-operation
-   #:load-sysdef #:make-temporary-package))
-(in-package :asdf/backward-internals)
-
-(when-upgrading (:when (fboundp 'make-sub-operation))
-  (defun make-sub-operation (c o dep-c dep-o)
-    (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
-
-;;;; load-sysdef
-(with-upgradability ()
-  (defun load-sysdef (name pathname)
-    (load-asd pathname :name name))
-
-  (defun make-temporary-package ()
-    ;; For loading a .asd file, we don't make a temporary package anymore,
-    ;; but use ASDF-USER. I'd like to have this function do this,
-    ;; but since whoever uses it is likely to delete-package the result afterwards,
-    ;; this would be a bad idea, so preserve the old behavior.
-    (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
-
 ;;;; ---------------------------------------------------------------------------
 ;;;; Handle ASDF package upgrade, including implementation-dependent magic.

@@ -11472,7 +11518,8 @@ Please use UIOP:RUN-PROGRAM instead."
    #:static-file #:doc-file #:html-file
    #:file-type #:source-file-type

-   #:register-preloaded-system #:register-immutable-system
+   #:register-preloaded-system #:sysdef-preloaded-system-search
+   #:register-immutable-system #:sysdef-immutable-system-search

    #:package-inferred-system #:register-system-packages
    #:package-system ;; backward-compatibility during migration, to be removed in a further release.
@@ -11518,7 +11565,7 @@ Please use UIOP:RUN-PROGRAM instead."
    #:*compile-file-warnings-behaviour*
    #:*compile-file-failure-behaviour*
    #:*resolve-symlinks*
-   #:*load-system-operation* #:*immutable-systems*
+   #:*load-system-operation*
    #:*asdf-verbose* ;; unused. For backward-compatibility only.
    #:*verbose-out*

diff --git a/tools/com.informatimago.tools.try-systems.asd b/tools/com.informatimago.tools.try-systems.asd
index 8eb1c17..b059907 100644
--- a/tools/com.informatimago.tools.try-systems.asd
+++ b/tools/com.informatimago.tools.try-systems.asd
@@ -32,11 +32,6 @@
 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 ;;;;**************************************************************************

-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (if (find-package "UIOP")
-      (push :uiop *features*)
-      (setf *features* (remove :uiop *features*))))
-
 #+mocl
 (asdf:defsystem "com.informatimago.tools.try-systems"
   :description "Tries to compile systems like in quicklisp validation compilations."
@@ -70,9 +65,11 @@ by forking an sbcl instance per system.
   :depends-on ("com.informatimago.common-lisp.cesarum"
                "com.informatimago.tools.source"
                "com.informatimago.tools.script"
-               "split-sequence")
-  :components ((:file "dummy-uiop")
-               (:file "try-systems" :depends-on ("dummy-uiop")))
+               "split-sequence"
+               "uiop")
+  :components (;; (:file "dummy-uiop")
+               (:file "try-systems" :depends-on (;; "dummy-uiop"
+                                                 )))
   #+asdf-unicode :encoding #+asdf-unicode :utf-8)


diff --git a/tools/try-systems.lisp b/tools/try-systems.lisp
index 55384df..b6926dd 100644
--- a/tools/try-systems.lisp
+++ b/tools/try-systems.lisp
@@ -40,7 +40,10 @@
         "SPLIT-SEQUENCE"
         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.FILE"
         "COM.INFORMATIMAGO.TOOLS.ASDF-FILE"
-        "COM.INFORMATIMAGO.TOOLS.SCRIPT"))
+        "COM.INFORMATIMAGO.TOOLS.SCRIPT")
+  (:export
+   "TRY-SYSTEMS-IN-DIRECTORY"
+   "TRY-SYSTEMS"))
 (in-package "COM.INFORMATIMAGO.TOOLS.TRY-SYSTEMS")

 (defmacro in-home (relative-path)
@@ -207,4 +210,7 @@
   (format t "~2%;; Usage:~2%~S~2%"
           '(try-systems-in-directory #P"~/src/public/lisp/")))

+(defun try-systems ()
+  (try-systems-in-directory #P"~/src/public/lisp/"))
+
 ;;;; THE END ;;;;
ViewGit