Changeset 14593


Ignore:
Timestamp:
01/04/14 22:54:49 (7 years ago)
Author:
Mark Evenson
Message:

Updating to ASDF 3.1.0.36 which seems to mostly work.

BUNDLE-OP is still borked.

Location:
trunk/abcl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/doc/asdf/asdf.texinfo

    r14583 r14593  
    784784* The defsystem grammar::
    785785* Other code in .asd files::
     786* The package-system extension::
    786787@end menu
    787788
     
    13521353Please use the @code{if-feature} option instead.
    13531354
    1354 @node Other code in .asd files,  , The defsystem grammar, Defining systems with defsystem
     1355@node Other code in .asd files, The package-system extension, The defsystem grammar, Defining systems with defsystem
    13551356@section Other code in .asd files
    13561357
     
    13791380@end itemize
    13801381
     1382
     1383@node The package-system extension,  , Other code in .asd files, Defining systems with defsystem
     1384@section The package-system extension
     1385
     1386Starting with ASDF 3.0.3,
     1387ASDF supports a one-package-per-file style of programming,
     1388whereby each file is its own system,
     1389and dependencies are deduced from the @code{defpackage} form.
     1390
     1391In this style, packages referring to a same-named system (downcased);
     1392and if a system is defined with @code{:class package-system},
     1393then system names that start with that name
     1394(using the slash @code{/} separator)
     1395refer to files under the filesystem hierarchy where the system is defined.
     1396For instance, if system @code{my-lib} is defined in
     1397@file{/foo/bar/my-lib/my-lib.asd}, then system @code{my-lib/src/utility}
     1398will be found in file @file{/foo/bar/my-lib/src/utility.lisp}.
     1399
     1400This style was made popular by @code{faslpath} and @code{quick-build} before,
     1401and at the cost of a stricter package discipline,
     1402seems to make for more maintainable code.
     1403It is used by ASDF itself (starting with ASDF 3) and by @code{lisp-interface-library}.
     1404
     1405To use this style, choose a toplevel system name, e.g. @code{my-lib},
     1406and create a file @file{my-lib.asd}
     1407with the @code{:class :package-system} option in its @code{defsystem}.
     1408For instance:
     1409@example
     1410#-asdf (error "my-lib requires ASDF 3")
     1411(defsystem my-lib
     1412  :class :package-system
     1413  :defsystem-depends-on (:asdf-package-system)
     1414  :depends-on (:my-lib/src/all)
     1415  :in-order-to ((test-op (load-op :my-lib/test/all)))
     1416  :perform (test-op (o c) (symbol-call :my-lib/test/all :test-suite)))
     1417(register-system-packages :closer-mop
     1418 '(:c2mop :closer-common-lisp :c2cl :closer-common-lisp-user :c2cl-user))
     1419@end example
     1420
     1421In the code above, the
     1422@code{:defsystem-depends-on (:asdf-package-system)} is
     1423for compatibility with older versions of ASDF 3 (ASDF 2 not supported),
     1424and requires the @code{asdf-package-system} library to be present
     1425(it is implicitly provided by ASDF starting with ASDF 3.0.3).
     1426
     1427The function @code{register-system-packages} has to be called to register
     1428packages used or provided by your system and its components
     1429where the name of the system that provides the package
     1430is not the downcase of the package name.
     1431
     1432File @file{my-lib/src/utility.lisp} might start with:
     1433
     1434@example
     1435(defpackage :my-lib/src/utility
     1436  (:use :closer-common-lisp :my-lib/src/macros :my-lib/src/variables)
     1437  (:import-from :cl-ppcre #:register-groups-bind)
     1438  (:export #:foo #:bar))
     1439@end example
     1440
     1441And from the @code{:use} and @code{:import-from} clauses,
     1442ASDF could tell that you depend on systems @code{closer-mop} (registered above),
     1443@code{cl-ppcre} (package and system names match), and
     1444@code{my-lib/src/macros} and @code{my-lib/src/variables}
     1445(package and system names match, and they will be looked up hierarchically).
     1446
     1447The form @code{uiop:define-package} is supported as well as @code{defpackage},
     1448and has many options that prove useful in this context,
     1449such as @code{:use-reexport} and @code{:mix-reexport}
     1450that allow for ``inheritance'' of symbols being exported.
    13811451
    13821452@node The object model of ASDF, Controlling where ASDF searches for systems, Defining systems with defsystem, Top
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r14583 r14593  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 3.0.3: Another System Definition Facility.
     2;;; This is ASDF 3.1.0.36: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    5555  (setf ext:*gc-verbose* nil))
    5656
    57 #+(or abcl clisp clozure cmu ecl xcl) ;; punt on hard package upgrade on those implementations
     57#+(or abcl clozure cmu ecl xcl) ;; punt on hard package upgrade on those implementations
    5858(eval-when (:load-toplevel :compile-toplevel :execute)
    5959  (unless (member :asdf3 *features*)
     
    7676        (when *load-verbose*
    7777          (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))))
    78 
    7978;;;; ---------------------------------------------------------------------------
    8079;;;; Handle ASDF package upgrade, including implementation-dependent magic.
     
    616615             (when intern
    617616               (intern* name package))))))))
    618   (declaim (ftype function ensure-exported))
     617  (declaim (ftype (function (t t t &optional t) t) ensure-exported))
    619618  (defun ensure-exported-to-user (name symbol to-package &optional recycle)
    620619    (check-type name string)
     
    657656                                recycle mix reexport
    658657                                unintern)
    659     #+(or gcl2.6 genera) (declare (ignore documentation))
     658    #+genera (declare (ignore documentation))
    660659    (let* ((package-name (string name))
    661660           (nicknames (mapcar #'string nicknames))
     
    679678           (inherited (make-hash-table :test 'equal)))
    680679      (when-package-fishiness (record-fishy package-name))
    681       #-(or gcl2.6 genera)
     680      #-genera
    682681      (when documentation (setf (documentation package t) documentation))
    683682      (loop :for p :in (set-difference (package-use-list package) (append mix use))
     
    759758      :for (kw . args) :in clauses
    760759      :when (eq kw :nicknames) :append args :into nicknames :else
    761         :when (eq kw :documentation)
    762           :do (cond
    763                 (documentation (error "define-package: can't define documentation twice"))
    764                 ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
    765                 (t (setf documentation (car args)))) :else
     760      :when (eq kw :documentation)
     761        :do (cond
     762              (documentation (error "define-package: can't define documentation twice"))
     763              ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
     764              (t (setf documentation (car args)))) :else
    766765      :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
    767         :when (eq kw :shadow) :append args :into shadow :else
    768           :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
    769             :when (eq kw :import-from) :collect args :into import-from :else
    770               :when (eq kw :export) :append args :into export :else
    771                 :when (eq kw :intern) :append args :into intern :else
    772                   :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
    773                     :when (eq kw :mix) :append args :into mix :else
    774                       :when (eq kw :reexport) :append args :into reexport :else
    775                         :when (eq kw :unintern) :append args :into unintern :else
    776                           :do (error "unrecognized define-package keyword ~S" kw)
     766      :when (eq kw :shadow) :append args :into shadow :else
     767      :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
     768      :when (eq kw :import-from) :collect args :into import-from :else
     769      :when (eq kw :export) :append args :into export :else
     770      :when (eq kw :intern) :append args :into intern :else
     771      :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
     772      :when (eq kw :mix) :append args :into mix :else
     773      :when (eq kw :reexport) :append args :into reexport :else
     774      :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport
     775        :and :do (setf use-p t) :else
     776      :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
     777        :and :do (setf use-p t) :else
     778      :when (eq kw :unintern) :append args :into unintern :else
     779        :do (error "unrecognized define-package keyword ~S" kw)
    777780      :finally (return `(,package
    778781                         :nicknames ,nicknames :documentation ,documentation
     
    801804\(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
    802805resolve conflicts in favor of the first found symbol.  It may still yield
    803 an error if there is a conflict with an explicitly :SHADOWING-IMPORT-FROM symbol.
     806an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
    804807REEXPORT -- Takes a list of package designators.  For each package, p, in the list,
    805808export symbols with the same name as those exported from p.  Note that in the case
     
    809812          `(apply 'ensure-package ',(parse-define-package-form package clauses))))
    810813    `(progn
    811        #+clisp
    812        (eval-when (:compile-toplevel :load-toplevel :execute)
    813          ,ensure-form)
    814        #+(or clisp ecl gcl) (defpackage ,package (:use))
     814       #+(or ecl gcl) (defpackage ,package (:use))
    815815       (eval-when (:compile-toplevel :load-toplevel :execute)
    816816         ,ensure-form))))
     
    824824  (setf excl::*autoload-package-name-alist*
    825825        (remove "asdf" excl::*autoload-package-name-alist*
    826                 :test 'equalp :key 'car))
    827   #+gcl
    828   ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff,
    829   ;; but can run ASDF 2.011. GCL 2.6 has even more issues.
    830   (cond
    831     ((or (< system::*gcl-major-version* 2)
    832          (and (= system::*gcl-major-version* 2)
    833               (< system::*gcl-minor-version* 6)))
    834      (error "GCL 2.6 or later required to use ASDF"))
    835     ((and (= system::*gcl-major-version* 2)
    836           (= system::*gcl-minor-version* 6))
    837      (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
    838      (pushnew :gcl2.6 *features*))
    839     (t
    840      (pushnew :gcl2.7 *features*))))
     826                :test 'equalp :key 'car)))
    841827
    842828;; Compatibility with whoever calls asdf/package
     
    861847   #:logical-pathname #:translate-logical-pathname
    862848   #:make-broadcast-stream #:file-namestring)
    863   #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
    864   #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
    865849  #+genera (:shadowing-import-from :scl #:boolean)
    866850  #+genera (:export #:boolean #:ensure-directories-exist)
     
    926910  (unless (use-ecl-byte-compiler-p) (require :cmp)))
    927911
    928 #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
     912#+gcl
    929913(eval-when (:load-toplevel :compile-toplevel :execute)
    930914  (unless (member :ansi-cl *features*)
    931915    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
    932916  (setf compiler::*compiler-default-type* (pathname "")
    933         compiler::*lsp-ext* ""))
    934 
    935 #+gcl2.6
    936 (eval-when (:compile-toplevel :load-toplevel :execute)
    937   (shadow 'type-of :uiop/common-lisp)
    938   (shadowing-import 'system:*load-pathname* :uiop/common-lisp))
    939 
    940 #+gcl2.6
    941 (eval-when (:compile-toplevel :load-toplevel :execute)
    942   (export 'type-of :uiop/common-lisp)
    943   (export 'system:*load-pathname* :uiop/common-lisp))
    944 
    945 #+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
    946 (eval-when (:load-toplevel :compile-toplevel :execute)
    947   (defvar *gcl2.6* t)
    948   (deftype logical-pathname () nil)
    949   (defun type-of (x) (class-name (class-of x)))
    950   (defun wild-pathname-p (path) (declare (ignore path)) nil)
    951   (defun translate-logical-pathname (x) x)
    952   (defvar *compile-file-pathname* nil)
    953   (defun pathname-match-p (in-pathname wild-pathname)
    954     (declare (ignore in-wildname wild-wildname)) nil)
    955   (defun translate-pathname (source from-wildname to-wildname &key)
    956     (declare (ignore from-wildname to-wildname)) source)
    957   (defun %print-unreadable-object (object stream type identity thunk)
    958     (format stream "#<~@[~S ~]" (when type (type-of object)))
    959     (funcall thunk)
    960     (format stream "~@[ ~X~]>" (when identity (system:address object))))
    961   (defmacro with-standard-io-syntax (&body body)
    962     `(progn ,@body))
    963   (defmacro with-compilation-unit (options &body body)
    964     (declare (ignore options)) `(progn ,@body))
    965   (defmacro print-unreadable-object ((object stream &key type identity) &body body)
    966     `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body)))
    967   (defun ensure-directories-exist (path)
    968     (lisp:system (format nil "mkdir -p ~S"
    969                          (namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
     917        compiler::*lsp-ext* "")
     918  #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later.
     919            (cond
     920              #+gcl
     921              ((or (< system::*gcl-major-version* 2)
     922                   (and (= system::*gcl-major-version* 2)
     923                        (< system::*gcl-minor-version* 7)))
     924               '(error "GCL 2.7 or later required to use ASDF")))))
     925      (eval code)
     926      code))
    970927
    971928#+genera
     
    1016973call FROB with the match and a function that emits a string in the output.
    1017974Return a string made of the parts not omitted or emitted by FROB."
    1018     (declare (optimize (speed 0) (safety 3) (debug 3)))
     975    (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3)))
    1019976    (let ((length (length string)) (stream nil))
    1020977      (labels ((emit-string (x &optional (start 0) (end (length x)))
     
    10501007  (defmacro compatfmt (format)
    10511008    #+(or gcl genera)
    1052     (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
     1009    (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>")))
    10531010    #-(or gcl genera) format))
    10541011;;;; -------------------------------------------------------------------------
     
    10671024   ;; magic helper to define debugging functions:
    10681025   #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
    1069    #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
    1070    #:if-let ;; basic flow control
     1026   #:with-upgradability ;; (un)defining functions in an upgrade-friendly way
     1027   #:undefine-function #:undefine-functions #:defun* #:defgeneric*
     1028   #:nest #:if-let ;; basic flow control
    10711029   #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
    10721030   #:remove-plist-keys #:remove-plist-key ;; plists
     
    10991057    (cond
    11001058      ((symbolp function-spec)
     1059       ;; undefining the previous function is the portable way
     1060       ;; of overriding any incompatible previous gf,
     1061       ;; but CLISP needs extra help with getting rid of previous methods.
    11011062       #+clisp
    11021063       (let ((f (and (fboundp function-spec) (fdefinition function-spec))))
     
    11071068      ((and (consp function-spec) (eq (car function-spec) 'setf)
    11081069            (consp (cdr function-spec)) (null (cddr function-spec)))
    1109        #-gcl2.6 (fmakunbound function-spec))
     1070       (fmakunbound function-spec))
    11101071      (t (error "bad function spec ~S" function-spec))))
    11111072  (defun undefine-functions (function-spec-list)
     
    11201081              (declare (ignorable supersede))
    11211082              `(progn
    1122                  ;; undefining the previous function is the portable way
    1123                  ;; of overriding any incompatible previous gf, except on CLISP.
    11241083                 ;; We usually try to do it only for the functions that need it,
    1125                  ;; which happens in asdf/upgrade - however, for ECL, we need this hammer
    1126                  ;; (which causes issues in clisp)
    1127                  ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t)
     1084                 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
     1085                 ,@(when (or supersede #+ecl t)
    11281086                     `((undefine-function ',name)))
    1129                  #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
    11301087                 ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
    11311088                     `((declaim (notinline ,name))))
     
    11341091    (defdef defun* defun))
    11351092  (defmacro with-upgradability ((&optional) &body body)
     1093    "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified
     1094to also declare the functions NOTINLINE and to accept a wrapping the function name
     1095specification into a list with keyword argument SUPERSEDE (which defaults to T if the name
     1096is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION
     1097to supersede any previous definition."
    11361098    `(eval-when (:compile-toplevel :load-toplevel :execute)
    11371099       ,@(loop :for form :in body :collect
     
    11401102                     (case car
    11411103                       ((defun) `(defun* ,@cdr))
    1142                        ((defgeneric)
    1143                         (unless (or #+gcl2.6 (and (consp (car cdr)) (eq 'setf (caar cdr))))
    1144                           `(defgeneric* ,@cdr)))
     1104                       ((defgeneric) `(defgeneric* ,@cdr))
    11451105                       (otherwise form)))
    11461106                   form)))))
     
    11681128              (error "Failed to locate debug utility file: ~S" utility-file)))))))
    11691129
    1170 
    11711130;;; Flow control
    11721131(with-upgradability ()
     1132  (defmacro nest (&rest things)
     1133    "Macro to do keep code nesting and indentation under control." ;; Thanks to mbaringer
     1134    (reduce #'(lambda (outer inner) `(,@outer ,inner))
     1135            things :from-end t))
     1136
    11731137  (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
    11741138    ;; bindings can be (var form) or ((var1 form1) ...)
     
    12951259    (when (or start end) (setf strings (subseq strings start end)))
    12961260    (when key (setf strings (mapcar key strings)))
    1297     (loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s)))
     1261    (loop :with output = (make-string (loop :for s :in strings
     1262                                            :sum (if (characterp s) 1 (length s)))
    12981263                                      :element-type (strings-common-element-type strings))
    12991264          :with pos = 0
     
    13811346    (etypecase x
    13821347      ((or standard-class built-in-class) x)
    1383       #+gcl2.6 (keyword nil)
    13841348      (symbol (find-class x errorp environment)))))
    13851349
     
    16011565
    16021566  (defmacro with-muffled-conditions ((conditions) &body body)
     1567    "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
    16031568    `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
    16041569
     
    18511816  (defun getcwd ()
    18521817    "Get the current working directory as per POSIX getcwd(3), as a pathname object"
    1853     (or #+abcl (parse-namestring
    1854                 (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
     1818    (or #+abcl (symbol-call :asdf/filesystem :parse-native-namestring
     1819                            (java:jstatic "getProperty" "java.lang.System" "user.dir")
     1820                                                     :ensure-directory t)
    18551821        #+allegro (excl::current-directory)
    18561822        #+clisp (ext:default-directory)
     
    18601826        #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
    18611827        #+ecl (ext:getcwd)
    1862         #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
    1863                (first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines)))
     1828        #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
    18641829        #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
    18651830        #+lispworks (system:current-directory)
     
    20191984implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
    20201985that is a list and not a string."
    2021     #+gcl2.6 (setf directory (substitute :back :parent directory))
    20221986    (cond
    20231987      #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
    20241988      ((stringp directory) `(:absolute ,directory))
    2025       #+gcl2.6
    2026       ((and (consp directory) (eq :root (first directory)))
    2027        `(:absolute ,@(rest directory)))
    20281989      ((or (null directory)
    20291990           (and (consp directory) (member (first directory) '(:absolute :relative))))
    20301991       directory)
    2031       #+gcl2.6
     1992      #+gcl
    20321993      ((consp directory)
    2033        `(:relative ,@directory))
     1994       (cons :relative directory))
    20341995      (t
    20351996       (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
     
    20381999    "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
    20392000by the underlying implementation's MAKE-PATHNAME and other primitives"
    2040     #-gcl2.6 directory-component
    2041     #+gcl2.6
    2042     (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
    2043                             directory-component)))
    2044       (cond
    2045         ((and (consp d) (eq :relative (first d))) (rest d))
    2046         ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
    2047         (t d))))
     2001    directory-component)
    20482002
    20492003  (defun merge-pathname-directory-components (specified defaults)
     
    20742028  ;; This will be :unspecific if supported, or NIL if not.
    20752029  (defparameter *unspecific-pathname-type*
    2076     #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
    2077     #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil
     2030    #+(or abcl allegro clozure cmu genera lispworks mkcl sbcl scl xcl) :unspecific
     2031    #+(or clisp ecl gcl #|These haven't been tested:|# cormanlisp mcl) nil
    20782032    "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
    20792033
    2080   (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
     2034  (defun make-pathname* (&rest keys &key (directory nil)
    20812035                                      host (device () #+allegro devicep) name type version defaults
    20822036                                      #+scl &allow-other-keys)
     
    20892043           (append
    20902044            #+allegro (when (and devicep (null device)) `(:device :unspecific))
    2091             #+gcl2.6
    2092             (when directoryp
    2093               `(:directory ,(denormalize-pathname-directory-component directory)))
    20942045            keys)))
    20952046
     
    25852536  (defparameter *wild* (or #+cormanlisp "*" :wild)
    25862537    "Wild component for use with MAKE-PATHNAME")
    2587   (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild)
     2538  (defparameter *wild-directory-component* (or :wild)
    25882539    "Wild directory component for use with MAKE-PATHNAME")
    2589   (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors)
     2540  (defparameter *wild-inferiors-component* (or :wild-inferiors)
    25902541    "Wild-inferiors directory component for use with MAKE-PATHNAME")
    25912542  (defparameter *wild-file*
     
    28122763                   #+allegro
    28132764                   (probe-file p :follow-symlinks truename)
    2814                    #-(or allegro clisp gcl2.6)
     2765                   #+gcl
    28152766                   (if truename
    2816                        (probe-file p)
    2817                        (ignore-errors
    2818                         (let ((pp (physicalize-pathname p)))
    2819                           (and
    2820                            #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
    2821                            #+(and lispworks unix) (system:get-file-stat pp)
    2822                            #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
    2823                            #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
    2824                            p))))
    2825                    #+(or clisp gcl2.6)
     2767                       (truename* p)
     2768                       (let ((kind (car (si::stat p))))
     2769                         (when (eq kind :link)
     2770                           (setf kind (ignore-errors (car (si::stat (truename* p))))))
     2771                         (ecase kind
     2772                           ((nil) nil)
     2773                           ((:file :link)
     2774                            (cond
     2775                              ((file-pathname-p p) p)
     2776                              ((directory-pathname-p p)
     2777                               (subpathname p (car (last (pathname-directory p)))))))
     2778                           (:directory (ensure-directory-pathname p)))))
     2779                   #+clisp
    28262780                   #.(flet ((probe (probe)
    28272781                              `(let ((foundtrue ,probe))
     
    28292783                                   (truename foundtrue)
    28302784                                   (foundtrue p)))))
    2831                        #+gcl2.6
    2832                        (probe '(or (probe-file p)
    2833                                 (and (directory-pathname-p p)
    2834                                  (ignore-errors
    2835                                   (ensure-directory-pathname
    2836                                    (truename* (subpathname
    2837                                                (ensure-directory-pathname p) ".")))))))
    2838                        #+clisp
    28392785                       (let* ((fs (find-symbol* '#:file-stat :posix nil))
    28402786                              (pp (find-symbol* '#:probe-pathname :ext nil))
     
    28472793                                  ,resolve
    28482794                                  (and (ignore-errors (,fs p)) p))
    2849                              (probe resolve)))))
     2795                             (probe resolve))))
     2796                   #-(or allegro clisp gcl)
     2797                   (if truename
     2798                       (probe-file p)
     2799                       (ignore-errors
     2800                        (let ((pp (physicalize-pathname p)))
     2801                          (and
     2802                           #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
     2803                           #+(and lispworks unix) (system:get-file-stat pp)
     2804                           #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
     2805                           #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
     2806                           p)))))
    28502807                (file-error () nil)))))))
    28512808
     
    29852942          (assert (eq :absolute (first directory)))
    29862943          (loop :while up-components :do
    2987             (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
    2988                                                          :name nil :type nil :version nil :defaults p)))
    2989               (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components)
    2990                                                         :defaults p)
    2991                                         (ensure-directory-pathname parent)))
    2992               (push (pop up-components) down-components))
    2993                 :finally (return p))))))
     2944            (if-let (parent
     2945                     (ignore-errors
     2946                      (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
     2947                                                   :name nil :type nil :version nil :defaults p))))
     2948              (if-let (simplified
     2949                       (ignore-errors
     2950                        (merge-pathnames*
     2951                         (make-pathname* :directory `(:relative ,@down-components)
     2952                                         :defaults p)
     2953                         (ensure-directory-pathname parent))))
     2954                (return simplified)))
     2955            (push (pop up-components) down-components)
     2956            :finally (return p))))))
    29942957
    29952958  (defun resolve-symlinks (path)
     
    30172980      (pathname &key
    30182981                  on-error
    3019                   defaults type dot-dot
     2982                  defaults type dot-dot namestring
    30202983                  want-pathname
    30212984                  want-logical want-physical ensure-physical
     
    30312994If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
    30322995
    3033 If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
    3034 reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
    3035 then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true,
    3036 and the all the checks and transformations are run.
     2996If the argument is a STRING, it is first converted to a pathname via
     2997PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively
     2998depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively,
     2999or else by using CALL-FUNCTION on the NAMESTRING argument;
     3000if :UNIX is specified (or NIL, the default, which specifies the same thing),
     3001then PARSE-UNIX-NAMESTRING it is called with the keywords
     3002DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
     3003the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.
     3004
     3005The pathname passed or resulting from parsing the string
     3006is then subjected to all the checks and transformations below are run.
    30373007
    30383008Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
     
    30933063            ((or null pathname))
    30943064            (string
    3095              (setf p (parse-unix-namestring
    3096                       p :defaults defaults :type type :dot-dot dot-dot
    3097                         :ensure-directory ensure-directory :want-relative want-relative))))
    3098           (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
    3099           (unless (pathnamep p) (return nil))
     3065             (setf p (case namestring
     3066                       ((:unix nil)
     3067                        (parse-unix-namestring
     3068                         p :defaults defaults :type type :dot-dot dot-dot
     3069                           :ensure-directory ensure-directory :want-relative want-relative))
     3070                       ((:native)
     3071                        (parse-native-namestring p))
     3072                       ((:lisp)
     3073                        (parse-namestring p))
     3074                       (t
     3075                        (call-function namestring p))))))
     3076          (etypecase p
     3077            (pathname)
     3078            (null
     3079             (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
     3080             (return nil)))
    31003081          (check want-logical (logical-pathname-p p) "Expected a logical pathname")
    31013082          (check want-physical (physical-pathname-p p) "Expected a physical pathname")
     
    35533534    "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
    35543535Other keys are accepted but discarded."
    3555     #+gcl2.6 (declare (ignore external-format))
    35563536    (with-open-file (s pathname :direction :input
    35573537                                :element-type element-type
    3558                                 #-gcl2.6 :external-format #-gcl2.6 external-format
     3538                                :external-format external-format
    35593539                                :if-does-not-exist if-does-not-exist)
    35603540      (funcall thunk s)))
     
    35743554    "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
    35753555Other keys are accepted but discarded."
    3576     #+gcl2.6 (declare (ignore external-format))
    35773556    (with-open-file (s pathname :direction :output
    35783557                                :element-type element-type
    3579                                 #-gcl2.6 :external-format #-gcl2.6 external-format
     3558                                :external-format external-format
    35803559                                :if-exists if-exists
    35813560                                :if-does-not-exist if-does-not-exist)
     
    35983577      (t (error "No /dev/null on your OS"))))
    35993578  (defun call-with-null-input (fun &rest keys &key element-type external-format if-does-not-exist)
     3579    "Call FUN with an input stream from the null device; pass keyword arguments to OPEN."
    36003580    (declare (ignore element-type external-format if-does-not-exist))
    36013581    (apply 'call-with-input-file (null-device-pathname) fun keys))
     
    36043584                             &body body)
    36053585    (declare (ignore element-type external-format if-does-not-exist))
    3606     "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device."
     3586    "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device.
     3587Pass keyword arguments to OPEN."
    36073588    `(call-with-null-input #'(lambda (,var) ,@body) ,@keys))
    36083589  (defun call-with-null-output (fun
     
    36113592                                  (if-exists :overwrite)
    36123593                                  (if-does-not-exist :error))
     3594    "Call FUN with an output stream to the null device; pass keyword arguments to OPEN."
    36133595    (call-with-output-file
    36143596     (null-device-pathname) fun
     
    36183600                              &key element-type external-format if-does-not-exist if-exists)
    36193601                              &body body)
    3620     "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device."
     3602    "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device.
     3603Pass keyword arguments to OPEN."
    36213604    (declare (ignore element-type external-format if-exists if-does-not-exist))
    36223605    `(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))
     
    38573840    "Configure a default temporary directory to use."
    38583841    (setf *temporary-directory* (default-temporary-directory))
    3859     ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
    3860     #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
     3842    #+gcl (setf system::*tmp-dir* *temporary-directory*))
    38613843
    38623844  (defun call-with-temporary-file
    38633845      (thunk &key
    3864                (want-stream-p t) (want-pathname-p t)
    3865                prefix keep (direction :io)
     3846               (want-stream-p t) (want-pathname-p t) (direction :io) keep after
     3847               directory (type "tmp" typep) prefix (suffix (when typep "-tmp"))
    38663848               (element-type *default-stream-element-type*)
    38673849               (external-format *utf-8-external-format*))
    3868     "Call a THUNK with STREAM and PATHNAME arguments identifying a temporary file.
    3869 The pathname will be based on appending a random suffix to PREFIX.
    3870 This utility will KEEP the file past its extent if and only if explicitly requested.
    3871 The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT."
    3872     #+gcl2.6 (declare (ignorable external-format))
     3850    "Call a THUNK with stream and/or pathname arguments identifying a temporary file.
     3851
     3852The temporary file's pathname will be based on concatenating
     3853PREFIX (defaults to \"uiop\"), a random alphanumeric string,
     3854and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
     3855and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
     3856within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
     3857
     3858The file will be open with specified DIRECTION (defaults to :IO),
     3859ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and
     3860EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*).
     3861If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed
     3862with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T),
     3863and stream with be closed after the THUNK exits (either normally or abnormally).
     3864If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
     3865THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument.
     3866Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument.
     3867If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned.
     3868Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true."
    38733869    (check-type direction (member :output :io))
    38743870    (assert (or want-stream-p want-pathname-p))
    38753871    (loop
    3876       :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory))
     3872      :with prefix = (native-namestring
     3873                      (ensure-absolute-pathname
     3874                       (or prefix "tmp")
     3875                       (or (ensure-pathname directory :namestring :native :ensure-directory t)
     3876                           #'temporary-directory)))
    38773877      :with results = ()
    3878       :for counter :from (random (ash 1 32))
    3879       :for pathname = (pathname (format nil "~A~36R" prefix counter))
     3878      :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
     3879      :for pathname = (parse-native-namestring
     3880                       (format nil "~A~36R~@[~A~]~@[.~A~]" prefix counter suffix type))
    38803881      :for okp = nil :do
    38813882        ;; TODO: on Unix, do something about umask
    38823883        ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
    3883         ;; TODO: on Unix, use CFFI and mkstemp -- but UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
     3884        ;; TODO: on Unix, use CFFI and mkstemp --
     3885        ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
     3886        ;; Can we at least design some hook?
    38843887        (unwind-protect
    38853888             (progn
     
    38873890                                       :direction direction
    38883891                                       :element-type element-type
    3889                                        #-gcl2.6 :external-format #-gcl2.6 external-format
     3892                                       :external-format external-format
    38903893                                       :if-exists nil :if-does-not-exist :create)
    38913894                 (when stream
     
    38983901                                (funcall thunk stream)))))))
    38993902               (when okp
    3900                  (if want-stream-p
    3901                      (return (apply 'values results))
    3902                      (return (funcall thunk pathname)))))
    3903           (when (and okp (not keep))
     3903                 (unless want-stream-p
     3904                   (setf results (multiple-value-list (call-function thunk pathname))))
     3905                 (when after
     3906                   (setf results (multiple-value-list (call-function after pathname))))
     3907                 (return (apply 'values results))))
     3908          (when (and okp (not (call-function keep)))
    39043909            (ignore-errors (delete-file-if-exists okp))))))
    39053910
    39063911  (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
    39073912                                    (pathname (gensym "PATHNAME") pathnamep)
    3908                                     prefix keep direction element-type external-format)
     3913                                    directory prefix suffix type
     3914                                    keep direction element-type external-format)
    39093915                                 &body body)
    39103916    "Evaluate BODY where the symbols specified by keyword arguments
    39113917STREAM and PATHNAME (if respectively specified) are bound corresponding
    39123918to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
    3913 The STREAM will be closed if no binding is specified.
    3914 Unless KEEP is specified, delete the file afterwards."
     3919At least one of STREAM or PATHNAME must be specified.
     3920If the STREAM is not specified, it will be closed before the BODY is evaluated.
     3921If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY,
     3922separates forms run before and after the stream is closed.
     3923The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned.
     3924Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE."
    39153925    (check-type stream symbol)
    39163926    (check-type pathname symbol)
    39173927    (assert (or streamp pathnamep))
    3918     `(flet ((think (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
    3919               ,@body))
    3920        #-gcl (declare (dynamic-extent #'think))
    3921        (call-with-temporary-file
    3922         #'think
    3923         :want-stream-p ,streamp
    3924         :want-pathname-p ,pathnamep
    3925         ,@(when direction `(:direction ,direction))
    3926         ,@(when prefix `(:prefix ,prefix))
    3927         ,@(when keep `(:keep ,keep))
    3928         ,@(when element-type `(:element-type ,element-type))
    3929         ,@(when external-format `(:external-format ,external-format)))))
    3930 
    3931   (defun get-temporary-file (&key prefix)
    3932     (with-temporary-file (:pathname pn :keep t :prefix prefix)
     3928    (let* ((afterp (position :close-stream body))
     3929           (before (if afterp (subseq body 0 (1- afterp)) body))
     3930           (after (when afterp (subseq body (1+ afterp))))
     3931           (beforef (gensym "BEFORE"))
     3932           (afterf (gensym "AFTER")))
     3933      `(flet (,@(when before
     3934                  `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@before)))
     3935              ,@(when after
     3936                  (assert pathnamep)
     3937                  `((,afterf (,pathname) ,@after))))
     3938         #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf))))
     3939         (call-with-temporary-file
     3940          ,(when before `#',beforef)
     3941          :want-stream-p ,streamp
     3942          :want-pathname-p ,pathnamep
     3943          ,@(when direction `(:direction ,direction))
     3944          ,@(when directory `(:directory ,directory))
     3945          ,@(when prefix `(:prefix ,prefix))
     3946          ,@(when suffix `(:suffix ,suffix))
     3947          ,@(when type `(:suffix ,type))
     3948          ,@(when keep `(:keep ,keep))
     3949          ,@(when after `(:after `#',afterf))
     3950          ,@(when element-type `(:element-type ,element-type))
     3951          ,@(when external-format `(:external-format ,external-format))))))
     3952
     3953  (defun get-temporary-file (&key directory prefix suffix type)
     3954    (with-temporary-file (:pathname pn :keep t
     3955                          :directory directory :prefix prefix :suffix suffix :type type)
    39333956      pn))
    39343957
    39353958  ;; Temporary pathnames in simple cases where no contention is assumed
    3936   (defun add-pathname-suffix (pathname suffix)
    3937     "Add a SUFFIX to the name of a PATHNAME, return a new pathname"
    3938     (make-pathname :name (strcat (pathname-name pathname) suffix)
    3939                    :defaults pathname))
     3959  (defun add-pathname-suffix (pathname suffix &rest keys)
     3960    "Add a SUFFIX to the name of a PATHNAME, return a new pathname.
     3961Further KEYS can be passed to MAKE-PATHNAME."
     3962    (apply 'make-pathname :name (strcat (pathname-name pathname) suffix)
     3963                          :defaults pathname keys))
    39403964
    39413965  (defun tmpize-pathname (x)
    39423966    "Return a new pathname modified from X by adding a trivial deterministic suffix"
    3943     (add-pathname-suffix x "-ASDF-TMP"))
     3967    (add-pathname-suffix x "-TMP"))
    39443968
    39453969  (defun call-with-staging-pathname (pathname fun)
    3946     "Calls fun with a staging pathname, and atomically
    3947 renames the staging pathname to the pathname in the end.
    3948 Note: this protects only against failure of the program,
    3949 not against concurrent attempts.
    3950 For the latter case, we ought pick random suffix and atomically open it."
     3970    "Calls FUN with a staging pathname, and atomically
     3971renames the staging pathname to the PATHNAME in the end.
     3972NB: this protects only against failure of the program, not against concurrent attempts.
     3973For the latter case, we ought pick a random suffix and atomically open it."
    39513974    (let* ((pathname (pathname pathname))
    39523975           (staging (tmpize-pathname pathname)))
     
    39583981
    39593982  (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
     3983    "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
    39603984    `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
    39613985
     
    40324056    #+(or cmu scl) (unix:unix-exit code)
    40334057    #+ecl (si:quit code)
    4034     #+gcl (lisp:quit code)
     4058    #+gcl (system:quit code)
    40354059    #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
    40364060    #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
     
    40524076    (quit code))
    40534077
    4054   (defun raw-print-backtrace (&key (stream *debug-io*) count)
     4078  (defun raw-print-backtrace (&key (stream *debug-io*) count condition)
    40554079    "Print a backtrace, directly accessing the implementation"
    4056     (declare (ignorable stream count))
     4080    (declare (ignorable stream count condition))
    40574081    #+abcl
    4058     (let ((*debug-io* stream)) (top-level::backtrace-command count))
     4082    (loop :for i :from 0
     4083    :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
     4084      (safe-format! stream "~&~D: ~A~%" i frame))
    40594085    #+allegro
    40604086    (let ((*terminal-io* stream)
     
    40654091      (tpl:do-command "zoom"
    40664092        :from-read-eval-print-loop nil
    4067         :count t
     4093        :count (or count t)
    40684094        :all t))
    40694095    #+clisp
     
    40774103    (let ((debug:*debug-print-level* *print-level*)
    40784104          (debug:*debug-print-length* *print-length*))
    4079       (debug:backtrace most-positive-fixnum stream))
     4105      (debug:backtrace (or count most-positive-fixnum) stream))
    40804106    #+ecl
    4081     (si::tpl-backtrace)
     4107    (let* ((top (si:ihs-top))
     4108     (repeats (if count (min top count) top))
     4109     (backtrace (loop :for ihs :from 0 :below top
     4110                            :collect (list (si::ihs-fun ihs)
     4111                                           (si::ihs-env ihs)))))
     4112      (loop :for i :from 0 :below repeats
     4113      :for frame :in (nreverse backtrace) :do
     4114        (safe-format! stream "~&~D: ~S~%" i frame)))
     4115    #+gcl
     4116    (let ((*debug-io* stream))
     4117      (ignore-errors
     4118       (with-safe-io-syntax ()
     4119   (if condition
     4120       (conditions::condition-backtrace condition)
     4121       (system::simple-backtrace)))))
    40824122    #+lispworks
    40834123    (let ((dbg::*debugger-stack*
     
    40904130    (sb-debug:backtrace
    40914131     #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
    4092      stream))
    4093 
    4094   (defun print-backtrace (&rest keys &key stream count)
     4132     stream)
     4133    #+xcl
     4134    (loop :for i :from 0 :below (or count most-positive-fixnum)
     4135    :for frame :in (extensions:backtrace-as-list) :do
     4136      (safe-format! stream "~&~D: ~S~%" i frame)))
     4137
     4138  (defun print-backtrace (&rest keys &key stream count condition)
    40954139    "Print a backtrace"
    4096     (declare (ignore stream count))
     4140    (declare (ignore stream count condition))
    40974141    (with-safe-io-syntax (:package :cl)
    40984142      (let ((*print-readably* nil)
     
    41094153    ;; for the sake of who sees the backtrace at a terminal.
    41104154    ;; It is up to the caller to print the condition *before*, with some context.
    4111     (print-backtrace :stream stream :count count)
     4155    (print-backtrace :stream stream :count count :condition condition)
    41124156    (when condition
    41134157      (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
     
    41974241
    41984242  (defun restore-image (&key
    4199                           ((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
    4200                           ((:restore-hook *image-restore-hook*) *image-restore-hook*)
    4201                           ((:prelude *image-prelude*) *image-prelude*)
    4202                           ((:entry-point *image-entry-point*) *image-entry-point*)
     4243                          (lisp-interaction *lisp-interaction*)
     4244                          (restore-hook *image-restore-hook*)
     4245                          (prelude *image-prelude*)
     4246                          (entry-point *image-entry-point*)
    42034247                          (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
    42044248    "From a freshly restarted Lisp image, restore the saved Lisp environment
     
    42064250    (when *image-restored-p*
    42074251      (if if-already-restored
    4208           (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t))
     4252          (call-function if-already-restored "Image already ~:[being ~;~]restored"
     4253                         (eq *image-restored-p* t))
    42094254          (return-from restore-image)))
    42104255    (with-fatal-condition-handler ()
     4256      (setf *lisp-interaction* lisp-interaction)
     4257      (setf *image-restore-hook* restore-hook)
     4258      (setf *image-prelude* prelude)
    42114259      (setf *image-restored-p* :in-progress)
    42124260      (call-image-restore-hook)
    4213       (standard-eval-thunk *image-prelude*)
     4261      (standard-eval-thunk prelude)
    42144262      (setf *image-restored-p* t)
    42154263      (let ((results (multiple-value-list
    4216                       (if *image-entry-point*
    4217                           (call-function *image-entry-point*)
     4264                      (if entry-point
     4265                          (call-function entry-point)
    42184266                          t))))
    4219         (if *lisp-interaction*
     4267        (if lisp-interaction
    42204268            (apply 'values results)
    42214269            (shell-boolean-exit (first results)))))))
     
    42264274(with-upgradability ()
    42274275  (defun dump-image (filename &key output-name executable
    4228                                 ((:postlude *image-postlude*) *image-postlude*)
    4229                                 ((:dump-hook *image-dump-hook*) *image-dump-hook*)
    4230                                 #+clozure prepend-symbols #+clozure (purify t))
     4276                                (postlude *image-postlude*)
     4277                                (dump-hook *image-dump-hook*)
     4278                                #+clozure prepend-symbols #+clozure (purify t)
     4279                                #+(and sbcl windows) application-type)
    42314280    "Dump an image of the current Lisp environment at pathname FILENAME, with various options"
     4281    ;; Note: at least SBCL saves only global values of variables in the heap image,
     4282    ;; so make sure things you want to dump are NOT just local bindings shadowing the global values.
    42324283    (declare (ignorable filename output-name executable))
    42334284    (setf *image-dumped-p* (if executable :executable t))
    42344285    (setf *image-restored-p* :in-regress)
     4286    (setf *image-postlude* postlude)
    42354287    (standard-eval-thunk *image-postlude*)
     4288    (setf *image-dump-hook* dump-hook)
    42364289    (call-image-dump-hook)
    42374290    (setf *image-restored-p* nil)
     
    42694322      (setf ext:*batch-mode* nil)
    42704323      (setf ext::*gc-run-time* 0)
    4271       (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
    4272                                      (when executable '(:init-function restore-image :process-command-line nil))))
     4324      (apply 'ext:save-lisp filename
     4325             #+cmu :executable #+cmu t
     4326             (when executable '(:init-function restore-image :process-command-line nil))))
    42734327    #+gcl
    42744328    (progn
     
    42854339      (apply 'sb-ext:save-lisp-and-die filename
    42864340             :executable t ;--- always include the runtime that goes with the core
    4287              (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
     4341             (when executable (list :toplevel #'restore-image :save-runtime-options t)) ;--- only save runtime-options for standalone executables
     4342             #+(and sbcl windows) ;; passing :application-type :gui will disable the console window.
     4343             ;; the default is :console - only works with SBCL 1.1.15 or later.
     4344             (when application-type (list :application-type application-type))))
    42884345    #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
    42894346    (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
     
    44984555Programmers are encouraged to define their own methods for this generic function."))
    44994556
    4500   #-(or gcl2.6 genera)
     4557  #-genera
    45014558  (defmethod slurp-input-stream ((function function) input-stream &key)
    45024559    (funcall function input-stream))
     
    45054562    (apply (first list) input-stream (rest list)))
    45064563
    4507   #-(or gcl2.6 genera)
     4564  #-genera
    45084565  (defmethod slurp-input-stream ((output-stream stream) input-stream
    45094566                                 &key linewise prefix (element-type 'character) buffer-size)
     
    45654622    (declare (ignorable stream linewise prefix element-type buffer-size))
    45664623    (cond
    4567       #+(or gcl2.6 genera)
     4624      #+genera
    45684625      ((functionp x) (funcall x stream))
    4569       #+(or gcl2.6 genera)
     4626      #+genera
    45704627      ((output-stream-p x)
    45714628       (copy-stream-to-stream
     
    45954652Programmers are encouraged to define their own methods for this generic function."))
    45964653
    4597   #-(or gcl2.6 genera)
     4654  #-genera
    45984655  (defmethod vomit-output-stream ((function function) output-stream &key)
    45994656    (funcall function output-stream))
     
    46024659    (apply (first list) output-stream (rest list)))
    46034660
    4604   #-(or gcl2.6 genera)
     4661  #-genera
    46054662  (defmethod vomit-output-stream ((input-stream stream) output-stream
    46064663                                 &key linewise prefix (element-type 'character) buffer-size)
     
    46444701    (declare (ignorable stream linewise prefix element-type buffer-size))
    46454702    (cond
    4646       #+(or gcl2.6 genera)
     4703      #+genera
    46474704      ((functionp x) (funcall x stream))
    4648       #+(or gcl2.6 genera)
     4705      #+genera
    46494706      ((input-stream-p x)
    46504707       (copy-stream-to-stream
     
    47074764    (etypecase specifier
    47084765      (null (or #+(or allegro lispworks) (null-device-pathname)))
    4709       (string (pathname specifier))
     4766      (string (parse-native-namestring specifier))
    47104767      (pathname specifier)
    47114768      (stream specifier)
     
    48834940        (nreverse process-info-r))))
    48844941
     4942  (defun %process-info-pid (process-info)
     4943    (let ((process (getf process-info :process)))
     4944      (declare (ignorable process))
     4945      #+(or allegro lispworks) process
     4946      #+clozure (ccl::external-process-pid process)
     4947      #+ecl (si:external-process-pid process)
     4948      #+(or cmu scl) (ext:process-pid process)
     4949      #+sbcl (sb-ext:process-pid process)
     4950      #-(or allegro cmu sbcl scl) (error "~S not implemented" '%process-info-pid)))
     4951
    48854952  (defun %wait-process-result (process-info)
    48864953    (or (getf process-info :exit-code)
     
    49995066    ;; helper for RUN-PROGRAM when using %run-program
    50005067    #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
    5001     (error "Not implemented on this platform")
     5068    (progn
     5069      command keys input output error-output ignore-error-status ;; ignore
     5070      (error "Not implemented on this platform"))
    50025071    (assert (not (member :stream (list input output error-output))))
    50035072    (let* ((active-input-p (%active-io-specifier-p input))
     
    50615130                     (typecase spec
    50625131                       (null (null-device-pathname))
    5063                        (string (pathname spec))
     5132                       (string (parse-native-namestring spec))
    50645133                       (pathname spec)
    50655134                       ((eql :output)
    5066                         (assert (equal operator "2>"))
     5135                        (assert (equal operator " 2>"))
    50675136                        (return-from redirect '(" 2>&1"))))))
    50685137               (when pathname
    5069                  (list " " operator " "
     5138                 (list operator " "
    50705139                       (escape-shell-token (native-namestring pathname)))))))
    50715140      (multiple-value-bind (before after)
     
    50765145        (reduce/strcat
    50775146         (append
    5078           before (redirect in "<") (redirect out ">") (redirect err "2>")
    5079           (when (and directory (os-unix-p)) `("cd " (escape-shell-token directory) " ; "))
     5147          before (redirect in " <") (redirect out " >") (redirect err " 2>")
     5148          (when (and directory (os-unix-p))
     5149            `(" ; cd " ,(escape-shell-token (native-namestring directory))))
    50805150          after)))))
    50815151
     
    50935163      #-(and lispworks os-windows)
    50945164      (with-current-directory ((unless (os-unix-p) directory))
    5095         #+(or abcl xcl) (ext:run-shell-command %command)
     5165        #+abcl (ext:run-shell-command %command)
    50965166        #+clisp (clisp-exit-code (ext:shell %command))
    50975167        #+cormanlisp (win32:system %command)
     
    51005170                    (*error-output* *stderr*))
    51015171                (ext:system %command))
    5102         #+gcl (lisp:system %command)
     5172        #+gcl (system:system %command)
    51035173        #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
    51045174        #+mkcl ;; PROBABLY BOGUS -- ask jcb
     
    51065176            (mkcl:run-program #+windows %command #+windows ()
    51075177                              #-windows "/bin/sh" #-windows (list "-c" %command)
    5108                               :input t :output t)))))
     5178                              :input t :output t))
     5179        #+xcl (system:%run-shell-command %command))))
    51095180
    51105181  (defun %use-system (command &rest keys
     
    51455216If OUTPUT is a pathname, a string designating a pathname, or NIL designating the null device,
    51465217the file at that path is used as output.
    5147 If it's :INTERACTIVE, output is inherited from the current process.
     5218If it's :INTERACTIVE, output is inherited from the current process;
     5219beware that this may be different from your *STANDARD-OUTPUT*,
     5220and under SLIME will be on your *inferior-lisp* buffer.
     5221If it's T, output goes to your current *STANDARD-OUTPUT* stream.
    51485222Otherwise, OUTPUT should be a value that is a suitable first argument to
    51495223SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
    5150 In this case, RUN-PROGRAM will create a temporary stream for the program output.
    5151 The program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
     5224In this case, RUN-PROGRAM will create a temporary stream for the program output;
     5225the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
    51525226using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
    5153 T designates the *STANDARD-OUTPUT* to be provided to SLURP-INPUT-STREAM.
    51545227The primary value resulting from that call (or NIL if no call was needed)
    51555228will be the first value returned by RUN-PROGRAM.
    51565229E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
     5230And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
     5231stripped of any ending newline.
    51575232
    51585233ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
    51595234as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
    5160 Also :OUTPUT means redirecting the error output to the output stream, and NIL is returned.
     5235Also :OUTPUT means redirecting the error output to the output stream,
     5236in which case NIL is returned.
    51615237
    51625238INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
    51635239no value is returned, and T designates the *STANDARD-INPUT*.
    51645240
    5165 Use ELEMENT-TYPE and EXTERNAL-FORMAT to specify how streams are created.
     5241Use ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
     5242to your Lisp implementation, when applicable, for creation of the output stream.
    51665243
    51675244One and only one of the stream slurping or vomiting may or may not happen
    5168 in parallel in parallel with the subprocess, depending on options and implementation.
    5169 Other streams are completely produced or consumed before or after the subprocess is spawned,
    5170 using temporary files.
     5245in parallel in parallel with the subprocess,
     5246depending on options and implementation,
     5247and with priority being given to output processing.
     5248Other streams are completely produced or consumed
     5249before or after the subprocess is spawned, using temporary files.
    51715250
    51725251RUN-PROGRAM returns 3 values:
     
    52115290   #:compile-warned-warning #:compile-failed-warning
    52125291   #:check-lisp-compile-results #:check-lisp-compile-warnings
    5213    #:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
     5292   #:*uninteresting-conditions* #:*usual-uninteresting-conditions*
     5293   #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
    52145294   ;; Types
    52155295   #+sbcl #:sb-grovel-unknown-constant-condition
     
    52255305   #:current-lisp-file-pathname #:load-pathname
    52265306   #:lispize-pathname #:compile-file-type #:call-around-hook
    5227    #:compile-file* #:compile-file-pathname*
     5307   #:compile-file* #:compile-file-pathname* #:*compile-check*
    52285308   #:load* #:load-from-string #:combine-fasls)
    52295309  (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
     
    56975777
    56985778  (defun check-deferred-warnings (files &optional context-format context-arguments)
    5699     "Given a list of FILES in which deferred warnings were saved by CALL-WITH-DEFERRED-WARNINGS,
     5779    "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS,
    57005780re-intern and raise any warnings that are still meaningful."
    57015781    (let ((file-errors nil)
     
    57385818  |#
    57395819
    5740   (defun call-with-saved-deferred-warnings (thunk warnings-file)
     5820  (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring)
    57415821    "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
    57425822and save those warnings to the given file for latter use,
    57435823possibly in a different process. Otherwise just call THUNK."
     5824    (declare (ignorable source-namestring))
    57445825    (if warnings-file
    5745         (with-compilation-unit (:override t)
     5826        (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring)
    57465827          (unwind-protect
    57475828               (let (#+sbcl (sb-c::*undefined-warnings* nil))
     
    57525833        (funcall thunk)))
    57535834
    5754   (defmacro with-saved-deferred-warnings ((warnings-file) &body body)
     5835  (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body)
    57555836    "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
    5756     `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file)))
     5837    `(call-with-saved-deferred-warnings
     5838      #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring)))
    57575839
    57585840
     
    57655847  (defun load-pathname ()
    57665848    "Portably return the LOAD-PATHNAME of the current source file or fasl"
    5767     *load-pathname*) ;; see magic for GCL in uiop/common-lisp
     5849    *load-pathname*) ;; magic no longer needed for GCL.
    57685850
    57695851  (defun lispize-pathname (input-file)
     
    57845866    "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
    57855867    (let* ((keys
    5786              (remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format
     5868             (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format
    57875869                                    ,@(unless output-file '(:output-file))) keys)))
    57885870      (if (absolute-pathname-p output-file)
     
    57955877                   (apply 'compile-file-pathname input-file keys)))))
    57965878
     5879  (defvar *compile-check* nil
     5880    "A hook for user-defined compile-time invariants")
     5881
    57975882  (defun* (compile-file*) (input-file &rest keys
    5798                                       &key compile-check output-file warnings-file
     5883                                      &key (compile-check *compile-check*) output-file warnings-file
    57995884                                      #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl
    58005885                                      &allow-other-keys)
     
    58235908    (let* ((keywords (remove-plist-keys
    58245909                      `(:output-file :compile-check :warnings-file
    5825                                      #+clisp :lib-file #+(or ecl mkcl) :object-file
    5826                                      #+gcl2.6 ,@'(:external-format :print :verbose)) keys))
     5910                                     #+clisp :lib-file #+(or ecl mkcl) :object-file) keys))
    58275911           (output-file
    58285912             (or output-file
     
    58495933           (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
    58505934      (multiple-value-bind (output-truename warnings-p failure-p)
    5851           (with-saved-deferred-warnings (warnings-file)
    5852             (with-muffled-compiler-conditions ()
    5853               (with-enough-pathname (input-file :defaults *base-build-directory*)
     5935          (with-enough-pathname (input-file :defaults *base-build-directory*)
     5936            (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
     5937              (with-muffled-compiler-conditions ()
    58545938                (or #-(or ecl mkcl)
    58555939                    (apply 'compile-file input-file :output-file tmp-file
     
    58935977  (defun load* (x &rest keys &key &allow-other-keys)
    58945978    "Portable wrapper around LOAD that properly handles loading from a stream."
    5895     (etypecase x
    5896       ((or pathname string #-(or allegro clozure gcl2.6 genera) stream)
    5897        (apply 'load x
    5898               #-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys)))
    5899       ;; GCL 2.6, Genera can't load from a string-input-stream
    5900       ;; ClozureCL 1.6 can only load from file input stream
    5901       ;; Allegro 5, I don't remember but it must have been broken when I tested.
    5902       #+(or allegro clozure gcl2.6 genera)
    5903       (stream ;; make do this way
    5904        (let ((*package* *package*)
    5905              (*readtable* *readtable*)
    5906              (*load-pathname* nil)
    5907              (*load-truename* nil))
    5908          (eval-input x)))))
     5979    (with-muffled-loader-conditions ()
     5980      (etypecase x
     5981        ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream)
     5982         (apply 'load x keys))
     5983        ;; Genera can't load from a string-input-stream
     5984        ;; ClozureCL 1.6 can only load from file input stream
     5985        ;; Allegro 5, I don't remember but it must have been broken when I tested.
     5986        #+(or allegro clozure genera)
     5987        (stream ;; make do this way
     5988         (let ((*package* *package*)
     5989               (*readtable* *readtable*)
     5990               (*load-pathname* nil)
     5991               (*load-truename* nil))
     5992           (eval-input x))))))
    59095993
    59105994  (defun load-from-string (string)
     
    60726156             (unless (= inherit 1)
    60736157               (report-invalid-form invalid-form-reporter
    6074                                     :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
    6075                                                      :inherit-configuration :ignore-inherited-configuration)))
     6158                                    :form form :location location
     6159                                    ;; we throw away the form and location arguments, hence the ~2*
     6160                                    ;; this is necessary because of the report in INVALID-CONFIGURATION
     6161                                    :format (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~
     6162                                                        One and only one of ~S or ~S is required.~@:>")
     6163                                    :arguments '(:inherit-configuration :ignore-inherited-configuration)))
    60766164             (return (nreverse x))))
    60776165
     
    63036391(uiop/package:define-package :uiop/driver
    63046392  (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils)
    6305   (:use :uiop/common-lisp :uiop/package :uiop/utility
    6306    :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
    6307    :uiop/run-program :uiop/lisp-build
    6308    :uiop/configuration :uiop/backward-driver)
    6309   (:reexport
    6310    ;; NB: excluding uiop/common-lisp
     6393  (:use :uiop/common-lisp)
     6394   ;; NB: not reexporting uiop/common-lisp
    63116395   ;; which include all of CL with compatibility modifications on select platforms,
    63126396   ;; that could cause potential conflicts for packages that would :use (cl uiop)
    63136397   ;; or :use (closer-common-lisp uiop), etc.
     6398  (:use-reexport
    63146399   :uiop/package :uiop/utility
    63156400   :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
     
    63266411   #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
    63276412   #:asdf-message #:*verbose-out*
    6328    #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error
     6413   #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error #:defparameter*
    63296414   #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
    63306415   ;; There will be no symbol left behind!
     
    63476432              (cons (format nil "~{~D~^.~}" rev))
    63486433              (null "1.0"))))))
     6434  ;; Important: define *p-a-v* /before/ *a-v* so that it initializes correctly.
     6435  (defvar *previous-asdf-versions* (if-let (previous (asdf-version)) (list previous)))
    63496436  (defvar *asdf-version* nil)
    6350   (defvar *previous-asdf-versions* nil)
     6437  ;; We need to clear systems from versions yet older than the below:
     6438  (defparameter *oldest-forward-compatible-asdf-version* "2.27")
     6439  (defmacro defparameter* (var value &optional docstring)
     6440    (let* ((name (string-trim "*" var))
     6441           (valfun (intern (format nil "%~A-~A-~A" :compute name :value)))
     6442           (clearfun (intern (format nil "%~A-~A" :clear name))))
     6443      `(progn
     6444         (defun ,valfun () ,value)
     6445         (defvar ,var (,valfun) ,@(ensure-list docstring))
     6446         (defun ,clearfun () (setf ,var (,valfun)))
     6447         (register-hook-function '*post-upgrade-cleanup-hook* ',clearfun))))
    63516448  (defvar *verbose-out* nil)
    63526449  (defun asdf-message (format-string &rest format-args)
     
    63646461         ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8
    63656462         ;; can help you do these changes in synch (look at the source for documentation).
    6366          ;; Relying on its automation, the version is now redundantly present on top of this file.
     6463         ;; Relying on its automation, the version is now redundantly present on top of asdf.lisp.
    63676464         ;; "3.4" would be the general branch for major version 3, minor version 4.
    63686465         ;; "3.4.5" would be an official release in the 3.4 branch.
    6369          ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
     6466         ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5.
    63706467         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    63716468         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    6372          (asdf-version "3.0.3.0.1")
     6469         (asdf-version "3.1.0.36")
    63736470         (existing-version (asdf-version)))
    63746471    (setf *asdf-version* asdf-version)
     
    64446541              (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
    64456542                            old-version new-version))
    6446           (call-functions (reverse *post-upgrade-cleanup-hook*))
     6543          ;; In case the previous version was too old to be forward-compatible, clear systems.
     6544          ;; TODO: if needed, we may have to define a separate hook to run
     6545          ;; in case of forward-compatible upgrade.
     6546          ;; Or to move the tests forward-compatibility test inside each hook function?
     6547          (unless (version<= *oldest-forward-compatible-asdf-version* old-version)
     6548            (call-functions (reverse *post-upgrade-cleanup-hook*)))
    64476549          t))))
    64486550
     
    67456847(with-upgradability ()
    67466848  (defmethod version-satisfies ((c component) version)
    6747     (unless (and version (slot-boundp c 'version))
     6849    (unless (and version (slot-boundp c 'version) (component-version c))
    67486850      (when version
    6749         (warn "Requested version ~S but component ~S has no version" version c))
     6851        (warn "Requested version ~S but ~S has no version" version c))
    67506852      (return-from version-satisfies t))
    67516853    (version-satisfies (component-version c) version))
     
    67926894(with-upgradability ()
    67936895  (defgeneric* (find-system) (system &optional error-p))
    6794   (defgeneric* (system-source-file) (system)
     6896  (defgeneric* (system-source-file :supersede #-clisp t #+clisp nil) (system)
    67956897    (:documentation "Return the source file in which system is defined."))
    67966898  (defgeneric component-build-pathname (component))
     
    69397041
    69407042  (defun get-file-stamp (file)
    6941     (let ((namestring (normalize-namestring file)))
    6942       (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))
     7043    (when file
     7044      (let ((namestring (normalize-namestring file)))
     7045        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
    69437046
    69447047;;;; -------------------------------------------------------------------------
     
    70817184
    70827185  (defun search-for-system-definition (system)
    7083     (block ()
    7084       (let ((name (coerce-name system)))
    7085         (flet ((try (f) (if-let ((x (funcall f name))) (return x))))
    7086           (try 'find-system-if-being-defined)
    7087           (map () #'try *system-definition-search-functions*)
    7088           (try 'sysdef-preloaded-system-search)))))
     7186    (let ((name (coerce-name system)))
     7187      (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x))))
     7188        (try 'find-system-if-being-defined)
     7189        (map () #'try *system-definition-search-functions*)
     7190        (try 'sysdef-preloaded-system-search))))
    70897191
    70907192  (defvar *central-registry* nil
     
    71217223                   :type "lnk")))
    71227224            (when (probe-file* shortcut)
    7123               (let ((target (parse-windows-shortcut shortcut)))
    7124                 (when target
    7125                   (return (pathname target))))))))))
     7225              (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))
    71267226
    71277227  (defun sysdef-central-registry-search (system)
     
    71887288    (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
    71897289
    7190   (register-preloaded-system "asdf" :version *asdf-version*)
    7191   (register-preloaded-system "uiop" :version *asdf-version*)
    7192   (register-preloaded-system "asdf-driver" :version *asdf-version*)
    7193   (register-preloaded-system "asdf-defsystem" :version *asdf-version*)
     7290  (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
     7291    ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
     7292    (register-preloaded-system s :version *asdf-version*))
    71947293
    71957294  (defmethod find-system ((name null) &optional (error-p t))
     
    72467345            (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
    72477346                          name pathname)
    7248             (with-muffled-loader-conditions ()
    7249               (load* pathname :external-format external-format)))))))
     7347            (load* pathname :external-format external-format))))))
    72507348
    72517349  (defvar *old-asdf-systems* (make-hash-table :test 'equal))
     
    75347632
    75357633(with-upgradability ()
    7536   (defparameter *operations* (make-hash-table :test 'equal))
     7634  (defparameter* *operations* (make-hash-table :test 'equal))
     7635
    75377636  (defun make-operation (operation-class &rest initargs)
    75387637    (ensure-gethash (cons operation-class initargs) *operations*
     
    79758074            (call-with-around-compile-hook
    79768075             c #'(lambda (&rest flags)
    7977                    (with-muffled-compiler-conditions ()
    7978                      (apply 'compile-file* input-file
    7979                             :output-file output-file
    7980                             :external-format (component-external-format c)
    7981                             :warnings-file warnings-file
    7982                             (append
    7983                              #+clisp (list :lib-file lib-file)
    7984                              #+(or ecl mkcl) (list :object-file object-file)
    7985                              flags (compile-op-flags o)))))))
     8076                   (apply 'compile-file* input-file
     8077                          :output-file output-file
     8078                          :external-format (component-external-format c)
     8079                          :warnings-file warnings-file
     8080                          (append
     8081                           #+clisp (list :lib-file lib-file)
     8082                           #+(or ecl mkcl) (list :object-file object-file)
     8083                           flags (compile-op-flags o))))))
    79868084        (check-lisp-compile-results output warnings-p failure-p
    79878085                                    "~/asdf-action::format-action/" (list (cons o c))))))
     
    80648162  (defun perform-lisp-load-fasl (o c)
    80658163    (if-let (fasl (first (input-files o c)))
    8066       (with-muffled-loader-conditions () (load* fasl))))
     8164      (load* fasl)))
    80678165  (defmethod perform ((o load-op) (c cl-source-file))
    80688166    (perform-lisp-load-fasl o c))
     
    81008198    (call-with-around-compile-hook
    81018199     c #'(lambda ()
    8102            (with-muffled-loader-conditions ()
    8103              (load* (first (input-files o c))
    8104                     :external-format (component-external-format c))))))
     8200           (load* (first (input-files o c))
     8201                  :external-format (component-external-format c)))))
    81058202
    81068203  (defmethod perform ((o load-source-op) (c cl-source-file))
     
    87908887
    87918888
     8889;;;; ---------------------------------------------------------------------------
     8890;;;; asdf-output-translations
     8891
     8892(asdf/package:define-package :asdf/output-translations
     8893  (:recycle :asdf/output-translations :asdf)
     8894  (:use :uiop/common-lisp :uiop :asdf/upgrade)
     8895  (:export
     8896   #:*output-translations* #:*output-translations-parameter*
     8897   #:invalid-output-translation
     8898   #:output-translations #:output-translations-initialized-p
     8899   #:initialize-output-translations #:clear-output-translations
     8900   #:disable-output-translations #:ensure-output-translations
     8901   #:apply-output-translations
     8902   #:validate-output-translations-directive #:validate-output-translations-form
     8903   #:validate-output-translations-file #:validate-output-translations-directory
     8904   #:parse-output-translations-string #:wrapping-output-translations
     8905   #:user-output-translations-pathname #:system-output-translations-pathname
     8906   #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
     8907   #:environment-output-translations #:process-output-translations
     8908   #:compute-output-translations
     8909   #+abcl #:translate-jar-pathname
     8910   ))
     8911(in-package :asdf/output-translations)
     8912
     8913(when-upgrading () (undefine-function '(setf output-translations)))
     8914
     8915(with-upgradability ()
     8916  (define-condition invalid-output-translation (invalid-configuration warning)
     8917    ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
     8918
     8919  (defvar *output-translations* ()
     8920    "Either NIL (for uninitialized), or a list of one element,
     8921said element itself being a sorted list of mappings.
     8922Each mapping is a pair of a source pathname and destination pathname,
     8923and the order is by decreasing length of namestring of the source pathname.")
     8924
     8925  (defun output-translations ()
     8926    (car *output-translations*))
     8927
     8928  (defun set-output-translations (new-value)
     8929    (setf *output-translations*
     8930          (list
     8931           (stable-sort (copy-list new-value) #'>
     8932                        :key #'(lambda (x)
     8933                                 (etypecase (car x)
     8934                                   ((eql t) -1)
     8935                                   (pathname
     8936                                    (let ((directory (pathname-directory (car x))))
     8937                                      (if (listp directory) (length directory) 0))))))))
     8938    new-value)
     8939  (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
     8940
     8941  (defun output-translations-initialized-p ()
     8942    (and *output-translations* t))
     8943
     8944  (defun clear-output-translations ()
     8945    "Undoes any initialization of the output translations."
     8946    (setf *output-translations* '())
     8947    (values))
     8948  (register-clear-configuration-hook 'clear-output-translations)
     8949
     8950  (defun validate-output-translations-directive (directive)
     8951    (or (member directive '(:enable-user-cache :disable-cache nil))
     8952        (and (consp directive)
     8953             (or (and (length=n-p directive 2)
     8954                      (or (and (eq (first directive) :include)
     8955                               (typep (second directive) '(or string pathname null)))
     8956                          (and (location-designator-p (first directive))
     8957                               (or (location-designator-p (second directive))
     8958                                   (location-function-p (second directive))))))
     8959                 (and (length=n-p directive 1)
     8960                      (location-designator-p (first directive)))))))
     8961
     8962  (defun validate-output-translations-form (form &key location)
     8963    (validate-configuration-form
     8964     form
     8965     :output-translations
     8966     'validate-output-translations-directive
     8967     :location location :invalid-form-reporter 'invalid-output-translation))
     8968
     8969  (defun validate-output-translations-file (file)
     8970    (validate-configuration-file
     8971     file 'validate-output-translations-form :description "output translations"))
     8972
     8973  (defun validate-output-translations-directory (directory)
     8974    (validate-configuration-directory
     8975     directory :output-translations 'validate-output-translations-directive
     8976               :invalid-form-reporter 'invalid-output-translation))
     8977
     8978  (defun parse-output-translations-string (string &key location)
     8979    (cond
     8980      ((or (null string) (equal string ""))
     8981       '(:output-translations :inherit-configuration))
     8982      ((not (stringp string))
     8983       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     8984      ((eql (char string 0) #\")
     8985       (parse-output-translations-string (read-from-string string) :location location))
     8986      ((eql (char string 0) #\()
     8987       (validate-output-translations-form (read-from-string string) :location location))
     8988      (t
     8989       (loop
     8990         :with inherit = nil
     8991         :with directives = ()
     8992         :with start = 0
     8993         :with end = (length string)
     8994         :with source = nil
     8995         :with separator = (inter-directory-separator)
     8996         :for i = (or (position separator string :start start) end) :do
     8997           (let ((s (subseq string start i)))
     8998             (cond
     8999               (source
     9000                (push (list source (if (equal "" s) nil s)) directives)
     9001                (setf source nil))
     9002               ((equal "" s)
     9003                (when inherit
     9004                  (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     9005                         string))
     9006                (setf inherit t)
     9007                (push :inherit-configuration directives))
     9008               (t
     9009                (setf source s)))
     9010             (setf start (1+ i))
     9011             (when (> start end)
     9012               (when source
     9013                 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
     9014                        string))
     9015               (unless inherit
     9016                 (push :ignore-inherited-configuration directives))
     9017               (return `(:output-translations ,@(nreverse directives)))))))))
     9018
     9019  (defparameter* *default-output-translations*
     9020    '(environment-output-translations
     9021      user-output-translations-pathname
     9022      user-output-translations-directory-pathname
     9023      system-output-translations-pathname
     9024      system-output-translations-directory-pathname))
     9025
     9026  (defun wrapping-output-translations ()
     9027    `(:output-translations
     9028    ;; Some implementations have precompiled ASDF systems,
     9029    ;; so we must disable translations for implementation paths.
     9030      #+(or #|clozure|# ecl mkcl sbcl)
     9031      ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
     9032          (when h `(((,h ,*wild-path*) ()))))
     9033      #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
     9034      ;; All-import, here is where we want user stuff to be:
     9035      :inherit-configuration
     9036      ;; These are for convenience, and can be overridden by the user:
     9037      #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
     9038      #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
     9039      ;; We enable the user cache by default, and here is the place we do:
     9040      :enable-user-cache))
     9041
     9042  (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
     9043  (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
     9044
     9045  (defun user-output-translations-pathname (&key (direction :input))
     9046    (in-user-configuration-directory *output-translations-file* :direction direction))
     9047  (defun system-output-translations-pathname (&key (direction :input))
     9048    (in-system-configuration-directory *output-translations-file* :direction direction))
     9049  (defun user-output-translations-directory-pathname (&key (direction :input))
     9050    (in-user-configuration-directory *output-translations-directory* :direction direction))
     9051  (defun system-output-translations-directory-pathname (&key (direction :input))
     9052    (in-system-configuration-directory *output-translations-directory* :direction direction))
     9053  (defun environment-output-translations ()
     9054    (getenv "ASDF_OUTPUT_TRANSLATIONS"))
     9055
     9056  (defgeneric process-output-translations (spec &key inherit collect))
     9057
     9058  (defun inherit-output-translations (inherit &key collect)
     9059    (when inherit
     9060      (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
     9061
     9062  (defun* (process-output-translations-directive) (directive &key inherit collect)
     9063    (if (atom directive)
     9064        (ecase directive
     9065          ((:enable-user-cache)
     9066           (process-output-translations-directive '(t :user-cache) :collect collect))
     9067          ((:disable-cache)
     9068           (process-output-translations-directive '(t t) :collect collect))
     9069          ((:inherit-configuration)
     9070           (inherit-output-translations inherit :collect collect))
     9071          ((:ignore-inherited-configuration :ignore-invalid-entries nil)
     9072           nil))
     9073        (let ((src (first directive))
     9074              (dst (second directive)))
     9075          (if (eq src :include)
     9076              (when dst
     9077                (process-output-translations (pathname dst) :inherit nil :collect collect))
     9078              (when src
     9079                (let ((trusrc (or (eql src t)
     9080                                  (let ((loc (resolve-location src :ensure-directory t :wilden t)))
     9081                                    (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
     9082                  (cond
     9083                    ((location-function-p dst)
     9084                     (funcall collect
     9085                              (list trusrc (ensure-function (second dst)))))
     9086                    ((eq dst t)
     9087                     (funcall collect (list trusrc t)))
     9088                    (t
     9089                     (let* ((trudst (if dst
     9090                                        (resolve-location dst :ensure-directory t :wilden t)
     9091                                        trusrc)))
     9092                       (funcall collect (list trudst t))
     9093                       (funcall collect (list trusrc trudst)))))))))))
     9094
     9095  (defmethod process-output-translations ((x symbol) &key
     9096                                                       (inherit *default-output-translations*)
     9097                                                       collect)
     9098    (process-output-translations (funcall x) :inherit inherit :collect collect))
     9099  (defmethod process-output-translations ((pathname pathname) &key inherit collect)
     9100    (cond
     9101      ((directory-pathname-p pathname)
     9102       (process-output-translations (validate-output-translations-directory pathname)
     9103                                    :inherit inherit :collect collect))
     9104      ((probe-file* pathname :truename *resolve-symlinks*)
     9105       (process-output-translations (validate-output-translations-file pathname)
     9106                                    :inherit inherit :collect collect))
     9107      (t
     9108       (inherit-output-translations inherit :collect collect))))
     9109  (defmethod process-output-translations ((string string) &key inherit collect)
     9110    (process-output-translations (parse-output-translations-string string)
     9111                                 :inherit inherit :collect collect))
     9112  (defmethod process-output-translations ((x null) &key inherit collect)
     9113    (declare (ignorable x))
     9114    (inherit-output-translations inherit :collect collect))
     9115  (defmethod process-output-translations ((form cons) &key inherit collect)
     9116    (dolist (directive (cdr (validate-output-translations-form form)))
     9117      (process-output-translations-directive directive :inherit inherit :collect collect)))
     9118
     9119  (defun compute-output-translations (&optional parameter)
     9120    "read the configuration, return it"
     9121    (remove-duplicates
     9122     (while-collecting (c)
     9123       (inherit-output-translations
     9124        `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
     9125     :test 'equal :from-end t))
     9126
     9127  (defvar *output-translations-parameter* nil)
     9128
     9129  (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
     9130    "read the configuration, initialize the internal configuration variable,
     9131return the configuration"
     9132    (setf *output-translations-parameter* parameter
     9133          (output-translations) (compute-output-translations parameter)))
     9134
     9135  (defun disable-output-translations ()
     9136    "Initialize output translations in a way that maps every file to itself,
     9137effectively disabling the output translation facility."
     9138    (initialize-output-translations
     9139     '(:output-translations :disable-cache :ignore-inherited-configuration)))
     9140
     9141  ;; checks an initial variable to see whether the state is initialized
     9142  ;; or cleared. In the former case, return current configuration; in
     9143  ;; the latter, initialize.  ASDF will call this function at the start
     9144  ;; of (asdf:find-system).
     9145  (defun ensure-output-translations ()
     9146    (if (output-translations-initialized-p)
     9147        (output-translations)
     9148        (initialize-output-translations)))
     9149
     9150  (defun* (apply-output-translations) (path)
     9151    (etypecase path
     9152      (logical-pathname
     9153       path)
     9154      ((or pathname string)
     9155       (ensure-output-translations)
     9156       (loop* :with p = (resolve-symlinks* path)
     9157              :for (source destination) :in (car *output-translations*)
     9158              :for root = (when (or (eq source t)
     9159                                    (and (pathnamep source)
     9160                                         (not (absolute-pathname-p source))))
     9161                            (pathname-root p))
     9162              :for absolute-source = (cond
     9163                                       ((eq source t) (wilden root))
     9164                                       (root (merge-pathnames* source root))
     9165                                       (t source))
     9166              :when (or (eq source t) (pathname-match-p p absolute-source))
     9167              :return (translate-pathname* p absolute-source destination root source)
     9168              :finally (return p)))))
     9169
     9170  ;; Hook into uiop's output-translation mechanism
     9171  #-cormanlisp
     9172  (setf *output-translation-function* 'apply-output-translations)
     9173
     9174  #+abcl
     9175  (defun translate-jar-pathname (source wildcard)
     9176    (declare (ignore wildcard))
     9177    (flet ((normalize-device (pathname)
     9178             (if (find :windows *features*)
     9179                 pathname
     9180                 (make-pathname :defaults pathname :device :unspecific))))
     9181      (let* ((jar
     9182               (pathname (first (pathname-device source))))
     9183             (target-root-directory-namestring
     9184               (format nil "/___jar___file___root___/~@[~A/~]"
     9185                       (and (find :windows *features*)
     9186                            (pathname-device jar))))
     9187             (relative-source
     9188               (relativize-pathname-directory source))
     9189             (relative-jar
     9190               (relativize-pathname-directory (ensure-directory-pathname jar)))
     9191             (target-root-directory
     9192               (normalize-device
     9193                (pathname-directory-pathname
     9194                 (parse-namestring target-root-directory-namestring))))
     9195             (target-root
     9196               (merge-pathnames* relative-jar target-root-directory))
     9197             (target
     9198               (merge-pathnames* relative-source target-root)))
     9199        (normalize-device (apply-output-translations target))))))
     9200
     9201;;;; -----------------------------------------------------------------
     9202;;;; Source Registry Configuration, by Francois-Rene Rideau
     9203;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
     9204
     9205(asdf/package:define-package :asdf/source-registry
     9206  (:recycle :asdf/source-registry :asdf)
     9207  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
     9208  (:export
     9209   #:*source-registry-parameter* #:*default-source-registries*
     9210   #:invalid-source-registry
     9211   #:source-registry-initialized-p
     9212   #:initialize-source-registry #:clear-source-registry #:*source-registry*
     9213   #:ensure-source-registry #:*source-registry-parameter*
     9214   #:*default-source-registry-exclusions* #:*source-registry-exclusions*
     9215   #:*wild-asd* #:directory-asd-files #:register-asd-directory
     9216   #:collect-asds-in-directory #:collect-sub*directories-asd-files
     9217   #:validate-source-registry-directive #:validate-source-registry-form
     9218   #:validate-source-registry-file #:validate-source-registry-directory
     9219   #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
     9220   #:user-source-registry #:system-source-registry
     9221   #:user-source-registry-directory #:system-source-registry-directory
     9222   #:environment-source-registry #:process-source-registry
     9223   #:compute-source-registry #:flatten-source-registry
     9224   #:sysdef-source-registry-search))
     9225(in-package :asdf/source-registry)
     9226
     9227(with-upgradability ()
     9228  (define-condition invalid-source-registry (invalid-configuration warning)
     9229    ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
     9230
     9231  ;; Using ack 1.2 exclusions
     9232  (defvar *default-source-registry-exclusions*
     9233    '(".bzr" ".cdv"
     9234      ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
     9235      ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
     9236      "_sgbak" "autom4te.cache" "cover_db" "_build"
     9237      "debian")) ;; debian often builds stuff under the debian directory... BAD.
     9238
     9239  (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
     9240
     9241  (defvar *source-registry* nil
     9242    "Either NIL (for uninitialized), or an equal hash-table, mapping
     9243system names to pathnames of .asd files")
     9244
     9245  (defun source-registry-initialized-p ()
     9246    (typep *source-registry* 'hash-table))
     9247
     9248  (defun clear-source-registry ()
     9249    "Undoes any initialization of the source registry."
     9250    (setf *source-registry* nil)
     9251    (values))
     9252  (register-clear-configuration-hook 'clear-source-registry)
     9253
     9254  (defparameter *wild-asd*
     9255    (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
     9256
     9257  (defun directory-asd-files (directory)
     9258    (directory-files directory *wild-asd*))
     9259
     9260  (defun collect-asds-in-directory (directory collect)
     9261    (map () collect (directory-asd-files directory)))
     9262
     9263  (defun collect-sub*directories-asd-files
     9264      (directory &key (exclude *default-source-registry-exclusions*) collect)
     9265    (collect-sub*directories
     9266     directory
     9267     (constantly t)
     9268     #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
     9269     #'(lambda (dir) (collect-asds-in-directory dir collect))))
     9270
     9271  (defun validate-source-registry-directive (directive)
     9272    (or (member directive '(:default-registry))
     9273        (and (consp directive)
     9274             (let ((rest (rest directive)))
     9275               (case (first directive)
     9276                 ((:include :directory :tree)
     9277                  (and (length=n-p rest 1)
     9278                       (location-designator-p (first rest))))
     9279                 ((:exclude :also-exclude)
     9280                  (every #'stringp rest))
     9281                 ((:default-registry)
     9282                  (null rest)))))))
     9283
     9284  (defun validate-source-registry-form (form &key location)
     9285    (validate-configuration-form
     9286     form :source-registry 'validate-source-registry-directive
     9287          :location location :invalid-form-reporter 'invalid-source-registry))
     9288
     9289  (defun validate-source-registry-file (file)
     9290    (validate-configuration-file
     9291     file 'validate-source-registry-form :description "a source registry"))
     9292
     9293  (defun validate-source-registry-directory (directory)
     9294    (validate-configuration-directory
     9295     directory :source-registry 'validate-source-registry-directive
     9296               :invalid-form-reporter 'invalid-source-registry))
     9297
     9298  (defun parse-source-registry-string (string &key location)
     9299    (cond
     9300      ((or (null string) (equal string ""))
     9301       '(:source-registry :inherit-configuration))
     9302      ((not (stringp string))
     9303       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     9304      ((find (char string 0) "\"(")
     9305       (validate-source-registry-form (read-from-string string) :location location))
     9306      (t
     9307       (loop
     9308         :with inherit = nil
     9309         :with directives = ()
     9310         :with start = 0
     9311         :with end = (length string)
     9312         :with separator = (inter-directory-separator)
     9313         :for pos = (position separator string :start start) :do
     9314           (let ((s (subseq string start (or pos end))))
     9315             (flet ((check (dir)
     9316                      (unless (absolute-pathname-p dir)
     9317                        (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
     9318                      dir))
     9319               (cond
     9320                 ((equal "" s) ; empty element: inherit
     9321                  (when inherit
     9322                    (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     9323                           string))
     9324                  (setf inherit t)
     9325                  (push ':inherit-configuration directives))
     9326                 ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
     9327                  (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
     9328                 (t
     9329                  (push `(:directory ,(check s)) directives))))
     9330             (cond
     9331               (pos
     9332                (setf start (1+ pos)))
     9333               (t
     9334                (unless inherit
     9335                  (push '(:ignore-inherited-configuration) directives))
     9336                (return `(:source-registry ,@(nreverse directives))))))))))
     9337
     9338  (defun register-asd-directory (directory &key recurse exclude collect)
     9339    (if (not recurse)
     9340        (collect-asds-in-directory directory collect)
     9341        (collect-sub*directories-asd-files
     9342         directory :exclude exclude :collect collect)))
     9343
     9344  (defparameter* *default-source-registries*
     9345    '(environment-source-registry
     9346      user-source-registry
     9347      user-source-registry-directory
     9348      system-source-registry
     9349      system-source-registry-directory
     9350      default-source-registry))
     9351
     9352  (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
     9353  (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
     9354
     9355  (defun wrapping-source-registry ()
     9356    `(:source-registry
     9357      #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
     9358      #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
     9359      :inherit-configuration
     9360      #+cmu (:tree #p"modules:")
     9361      #+scl (:tree #p"file://modules/")))
     9362  (defun default-source-registry ()
     9363    `(:source-registry
     9364      #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
     9365      ,@(loop :for dir :in
     9366              `(,@(when (os-unix-p)
     9367                    `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
     9368                           (subpathname (user-homedir-pathname) ".local/share/"))
     9369                      ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
     9370                            '("/usr/local/share" "/usr/share"))))
     9371                ,@(when (os-windows-p)
     9372                    (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
     9373              :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
     9374              :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
     9375      :inherit-configuration))
     9376  (defun user-source-registry (&key (direction :input))
     9377    (in-user-configuration-directory *source-registry-file* :direction direction))
     9378  (defun system-source-registry (&key (direction :input))
     9379    (in-system-configuration-directory *source-registry-file* :direction direction))
     9380  (defun user-source-registry-directory (&key (direction :input))
     9381    (in-user-configuration-directory *source-registry-directory* :direction direction))
     9382  (defun system-source-registry-directory (&key (direction :input))
     9383    (in-system-configuration-directory *source-registry-directory* :direction direction))
     9384  (defun environment-source-registry ()
     9385    (getenv "CL_SOURCE_REGISTRY"))
     9386
     9387  (defgeneric* (process-source-registry) (spec &key inherit register))
     9388
     9389  (defun* (inherit-source-registry) (inherit &key register)
     9390    (when inherit
     9391      (process-source-registry (first inherit) :register register :inherit (rest inherit))))
     9392
     9393  (defun* (process-source-registry-directive) (directive &key inherit register)
     9394    (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
     9395      (ecase kw
     9396        ((:include)
     9397         (destructuring-bind (pathname) rest
     9398           (process-source-registry (resolve-location pathname) :inherit nil :register register)))
     9399        ((:directory)
     9400         (destructuring-bind (pathname) rest
     9401           (when pathname
     9402             (funcall register (resolve-location pathname :ensure-directory t)))))
     9403        ((:tree)
     9404         (destructuring-bind (pathname) rest
     9405           (when pathname
     9406             (funcall register (resolve-location pathname :ensure-directory t)
     9407                      :recurse t :exclude *source-registry-exclusions*))))
     9408        ((:exclude)
     9409         (setf *source-registry-exclusions* rest))
     9410        ((:also-exclude)
     9411         (appendf *source-registry-exclusions* rest))
     9412        ((:default-registry)
     9413         (inherit-source-registry '(default-source-registry) :register register))
     9414        ((:inherit-configuration)
     9415         (inherit-source-registry inherit :register register))
     9416        ((:ignore-inherited-configuration)
     9417         nil)))
     9418    nil)
     9419
     9420  (defmethod process-source-registry ((x symbol) &key inherit register)
     9421    (process-source-registry (funcall x) :inherit inherit :register register))
     9422  (defmethod process-source-registry ((pathname pathname) &key inherit register)
     9423    (cond
     9424      ((directory-pathname-p pathname)
     9425       (let ((*here-directory* (resolve-symlinks* pathname)))
     9426         (process-source-registry (validate-source-registry-directory pathname)
     9427                                  :inherit inherit :register register)))
     9428      ((probe-file* pathname :truename *resolve-symlinks*)
     9429       (let ((*here-directory* (pathname-directory-pathname pathname)))
     9430         (process-source-registry (validate-source-registry-file pathname)
     9431                                  :inherit inherit :register register)))
     9432      (t
     9433       (inherit-source-registry inherit :register register))))
     9434  (defmethod process-source-registry ((string string) &key inherit register)
     9435    (process-source-registry (parse-source-registry-string string)
     9436                             :inherit inherit :register register))
     9437  (defmethod process-source-registry ((x null) &key inherit register)
     9438    (declare (ignorable x))
     9439    (inherit-source-registry inherit :register register))
     9440  (defmethod process-source-registry ((form cons) &key inherit register)
     9441    (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
     9442      (dolist (directive (cdr (validate-source-registry-form form)))
     9443        (process-source-registry-directive directive :inherit inherit :register register))))
     9444
     9445  (defun flatten-source-registry (&optional parameter)
     9446    (remove-duplicates
     9447     (while-collecting (collect)
     9448       (with-pathname-defaults () ;; be location-independent
     9449         (inherit-source-registry
     9450          `(wrapping-source-registry
     9451            ,parameter
     9452            ,@*default-source-registries*)
     9453          :register #'(lambda (directory &key recurse exclude)
     9454                        (collect (list directory :recurse recurse :exclude exclude))))))
     9455     :test 'equal :from-end t))
     9456
     9457  ;; Will read the configuration and initialize all internal variables.
     9458  (defun compute-source-registry (&optional parameter (registry *source-registry*))
     9459    (dolist (entry (flatten-source-registry parameter))
     9460      (destructuring-bind (directory &key recurse exclude) entry
     9461        (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
     9462          (register-asd-directory
     9463           directory :recurse recurse :exclude exclude :collect
     9464           #'(lambda (asd)
     9465               (let* ((name (pathname-name asd))
     9466                      (name (if (typep asd 'logical-pathname)
     9467                                ;; logical pathnames are upper-case,
     9468                                ;; at least in the CLHS and on SBCL,
     9469                                ;; yet (coerce-name :foo) is lower-case.
     9470                                ;; won't work well with (load-system "Foo")
     9471                                ;; instead of (load-system 'foo)
     9472                                (string-downcase name)
     9473                                name)))
     9474                 (cond
     9475                   ((gethash name registry) ; already shadowed by something else
     9476                    nil)
     9477                   ((gethash name h) ; conflict at current level
     9478                    (when *verbose-out*
     9479                      (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
     9480                                found several entries for ~A - picking ~S over ~S~:>")
     9481                            directory recurse name (gethash name h) asd)))
     9482                   (t
     9483                    (setf (gethash name registry) asd)
     9484                    (setf (gethash name h) asd))))))
     9485          h)))
     9486    (values))
     9487
     9488  (defvar *source-registry-parameter* nil)
     9489
     9490  (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
     9491    ;; Record the parameter used to configure the registry
     9492    (setf *source-registry-parameter* parameter)
     9493    ;; Clear the previous registry database:
     9494    (setf *source-registry* (make-hash-table :test 'equal))
     9495    ;; Do it!
     9496    (compute-source-registry parameter))
     9497
     9498  ;; Checks an initial variable to see whether the state is initialized
     9499  ;; or cleared. In the former case, return current configuration; in
     9500  ;; the latter, initialize.  ASDF will call this function at the start
     9501  ;; of (asdf:find-system) to make sure the source registry is initialized.
     9502  ;; However, it will do so *without* a parameter, at which point it
     9503  ;; will be too late to provide a parameter to this function, though
     9504  ;; you may override the configuration explicitly by calling
     9505  ;; initialize-source-registry directly with your parameter.
     9506  (defun ensure-source-registry (&optional parameter)
     9507    (unless (source-registry-initialized-p)
     9508      (initialize-source-registry parameter))
     9509    (values))
     9510
     9511  (defun sysdef-source-registry-search (system)
     9512    (ensure-source-registry)
     9513    (values (gethash (primary-system-name system) *source-registry*))))
     9514
     9515
    87929516;;;; -------------------------------------------------------------------------
    87939517;;; Internal hacks for backward-compatibility
     
    88089532;;;; Backward compatibility with "inline methods"
    88099533(with-upgradability ()
    8810   (defparameter +asdf-methods+
     9534  (defparameter* +asdf-methods+
    88119535    '(perform-with-restarts perform explain output-files operation-done-p))
    88129536
     
    88839607;;;; Defsystem
    88849608
    8885 (asdf/package:define-package :asdf/defsystem
    8886   (:recycle :asdf/defsystem :asdf)
    8887   (:use :uiop/common-lisp :uiop :asdf/upgrade
     9609(asdf/package:define-package :asdf/parse-defsystem
     9610  (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
     9611  (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
     9612  (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
    88889613   :asdf/component :asdf/system :asdf/cache
    88899614   :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
     
    88959620   #:non-toplevel-system #:non-system-system
    88969621   #:sysdef-error-component #:check-component-input))
    8897 (in-package :asdf/defsystem)
     9622(in-package :asdf/parse-defsystem)
    88989623
    88999624;;; Pathname
     
    937910104           (move-here-path (if (and move-here
    938010105                                    (typep move-here '(or pathname string)))
    9381                                (pathname move-here)
     10106                               (ensure-pathname move-here :namestring :lisp :ensure-directory t)
    938210107                               (system-relative-pathname system "asdf-output/")))
    938310108           (operation (apply #'operate operation-name
     
    953110256      (when input-files
    953210257        (when non-fasl-files
    9533           (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
     10258          (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
    953410259                 (implementation-type) non-fasl-files))
    953510260        (when (and (typep o 'monolithic-bundle-op)
     
    961910344  (:use :uiop/common-lisp :uiop :asdf/upgrade
    962010345   :asdf/component :asdf/operation
    9621    :asdf/system :asdf/find-system :asdf/defsystem
     10346   :asdf/system :asdf/find-system
    962210347   :asdf/action :asdf/lisp-action :asdf/bundle)
    962310348  (:export
     
    970110426    (perform-lisp-load-fasl o s)))
    970210427
    9703 ;;;; ---------------------------------------------------------------------------
    9704 ;;;; asdf-output-translations
    9705 
    9706 (asdf/package:define-package :asdf/output-translations
    9707   (:recycle :asdf/output-translations :asdf)
    9708   (:use :uiop/common-lisp :uiop :asdf/upgrade)
    9709   (:export
    9710    #:*output-translations* #:*output-translations-parameter*
    9711    #:invalid-output-translation
    9712    #:output-translations #:output-translations-initialized-p
    9713    #:initialize-output-translations #:clear-output-translations
    9714    #:disable-output-translations #:ensure-output-translations
    9715    #:apply-output-translations
    9716    #:validate-output-translations-directive #:validate-output-translations-form
    9717    #:validate-output-translations-file #:validate-output-translations-directory
    9718    #:parse-output-translations-string #:wrapping-output-translations
    9719    #:user-output-translations-pathname #:system-output-translations-pathname
    9720    #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
    9721    #:environment-output-translations #:process-output-translations
    9722    #:compute-output-translations
    9723    #+abcl #:translate-jar-pathname
    9724    ))
    9725 (in-package :asdf/output-translations)
    9726 
    9727 (when-upgrading () (undefine-function '(setf output-translations)))
    9728 
    9729 (with-upgradability ()
    9730   (define-condition invalid-output-translation (invalid-configuration warning)
    9731     ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    9732 
    9733   (defvar *output-translations* ()
    9734     "Either NIL (for uninitialized), or a list of one element,
    9735 said element itself being a sorted list of mappings.
    9736 Each mapping is a pair of a source pathname and destination pathname,
    9737 and the order is by decreasing length of namestring of the source pathname.")
    9738 
    9739   (defun output-translations ()
    9740     (car *output-translations*))
    9741 
    9742   (defun set-output-translations (new-value)
    9743     (setf *output-translations*
    9744           (list
    9745            (stable-sort (copy-list new-value) #'>
    9746                         :key #'(lambda (x)
    9747                                  (etypecase (car x)
    9748                                    ((eql t) -1)
    9749                                    (pathname
    9750                                     (let ((directory (pathname-directory (car x))))
    9751                                       (if (listp directory) (length directory) 0))))))))
    9752     new-value)
    9753   #-gcl2.6
    9754   (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
    9755   #+gcl2.6
    9756   (defsetf output-translations set-output-translations)
    9757 
    9758   (defun output-translations-initialized-p ()
    9759     (and *output-translations* t))
    9760 
    9761   (defun clear-output-translations ()
    9762     "Undoes any initialization of the output translations."
    9763     (setf *output-translations* '())
    9764     (values))
    9765   (register-clear-configuration-hook 'clear-output-translations)
    9766 
    9767   (defun validate-output-translations-directive (directive)
    9768     (or (member directive '(:enable-user-cache :disable-cache nil))
    9769         (and (consp directive)
    9770              (or (and (length=n-p directive 2)
    9771                       (or (and (eq (first directive) :include)
    9772                                (typep (second directive) '(or string pathname null)))
    9773                           (and (location-designator-p (first directive))
    9774                                (or (location-designator-p (second directive))
    9775                                    (location-function-p (second directive))))))
    9776                  (and (length=n-p directive 1)
    9777                       (location-designator-p (first directive)))))))
    9778 
    9779   (defun validate-output-translations-form (form &key location)
    9780     (validate-configuration-form
    9781      form
    9782      :output-translations
    9783      'validate-output-translations-directive
    9784      :location location :invalid-form-reporter 'invalid-output-translation))
    9785 
    9786   (defun validate-output-translations-file (file)
    9787     (validate-configuration-file
    9788      file 'validate-output-translations-form :description "output translations"))
    9789 
    9790   (defun validate-output-translations-directory (directory)
    9791     (validate-configuration-directory
    9792      directory :output-translations 'validate-output-translations-directive
    9793                :invalid-form-reporter 'invalid-output-translation))
    9794 
    9795   (defun parse-output-translations-string (string &key location)
    9796     (cond
    9797       ((or (null string) (equal string ""))
    9798        '(:output-translations :inherit-configuration))
    9799       ((not (stringp string))
    9800        (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
    9801       ((eql (char string 0) #\")
    9802        (parse-output-translations-string (read-from-string string) :location location))
    9803       ((eql (char string 0) #\()
    9804        (validate-output-translations-form (read-from-string string) :location location))
    9805       (t
    9806        (loop
    9807          :with inherit = nil
    9808          :with directives = ()
    9809          :with start = 0
    9810          :with end = (length string)
    9811          :with source = nil
    9812          :with separator = (inter-directory-separator)
    9813          :for i = (or (position separator string :start start) end) :do
    9814            (let ((s (subseq string start i)))
    9815              (cond
    9816                (source
    9817                 (push (list source (if (equal "" s) nil s)) directives)
    9818                 (setf source nil))
    9819                ((equal "" s)
    9820                 (when inherit
    9821                   (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    9822                          string))
    9823                 (setf inherit t)
    9824                 (push :inherit-configuration directives))
    9825                (t
    9826                 (setf source s)))
    9827              (setf start (1+ i))
    9828              (when (> start end)
    9829                (when source
    9830                  (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
    9831                         string))
    9832                (unless inherit
    9833                  (push :ignore-inherited-configuration directives))
    9834                (return `(:output-translations ,@(nreverse directives)))))))))
    9835 
    9836   (defparameter *default-output-translations*
    9837     '(environment-output-translations
    9838       user-output-translations-pathname
    9839       user-output-translations-directory-pathname
    9840       system-output-translations-pathname
    9841       system-output-translations-directory-pathname))
    9842 
    9843   (defun wrapping-output-translations ()
    9844     `(:output-translations
    9845     ;; Some implementations have precompiled ASDF systems,
    9846     ;; so we must disable translations for implementation paths.
    9847       #+(or #|clozure|# ecl mkcl sbcl)
    9848       ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
    9849           (when h `(((,h ,*wild-path*) ()))))
    9850       #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
    9851       ;; All-import, here is where we want user stuff to be:
    9852       :inherit-configuration
    9853       ;; These are for convenience, and can be overridden by the user:
    9854       #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
    9855       #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    9856       ;; We enable the user cache by default, and here is the place we do:
    9857       :enable-user-cache))
    9858 
    9859   (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
    9860   (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
    9861 
    9862   (defun user-output-translations-pathname (&key (direction :input))
    9863     (in-user-configuration-directory *output-translations-file* :direction direction))
    9864   (defun system-output-translations-pathname (&key (direction :input))
    9865     (in-system-configuration-directory *output-translations-file* :direction direction))
    9866   (defun user-output-translations-directory-pathname (&key (direction :input))
    9867     (in-user-configuration-directory *output-translations-directory* :direction direction))
    9868   (defun system-output-translations-directory-pathname (&key (direction :input))
    9869     (in-system-configuration-directory *output-translations-directory* :direction direction))
    9870   (defun environment-output-translations ()
    9871     (getenv "ASDF_OUTPUT_TRANSLATIONS"))
    9872 
    9873   (defgeneric process-output-translations (spec &key inherit collect))
    9874 
    9875   (defun inherit-output-translations (inherit &key collect)
    9876     (when inherit
    9877       (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
    9878 
    9879   (defun* (process-output-translations-directive) (directive &key inherit collect)
    9880     (if (atom directive)
    9881         (ecase directive
    9882           ((:enable-user-cache)
    9883            (process-output-translations-directive '(t :user-cache) :collect collect))
    9884           ((:disable-cache)
    9885            (process-output-translations-directive '(t t) :collect collect))
    9886           ((:inherit-configuration)
    9887            (inherit-output-translations inherit :collect collect))
    9888           ((:ignore-inherited-configuration :ignore-invalid-entries nil)
    9889            nil))
    9890         (let ((src (first directive))
    9891               (dst (second directive)))
    9892           (if (eq src :include)
    9893               (when dst
    9894                 (process-output-translations (pathname dst) :inherit nil :collect collect))
    9895               (when src
    9896                 (let ((trusrc (or (eql src t)
    9897                                   (let ((loc (resolve-location src :ensure-directory t :wilden t)))
    9898                                     (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
    9899                   (cond
    9900                     ((location-function-p dst)
    9901                      (funcall collect
    9902                               (list trusrc (ensure-function (second dst)))))
    9903                     ((eq dst t)
    9904                      (funcall collect (list trusrc t)))
    9905                     (t
    9906                      (let* ((trudst (if dst
    9907                                         (resolve-location dst :ensure-directory t :wilden t)
    9908                                         trusrc)))
    9909                        (funcall collect (list trudst t))
    9910                        (funcall collect (list trusrc trudst)))))))))))
    9911 
    9912   (defmethod process-output-translations ((x symbol) &key
    9913                                                        (inherit *default-output-translations*)
    9914                                                        collect)
    9915     (process-output-translations (funcall x) :inherit inherit :collect collect))
    9916   (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
    9917     (cond
    9918       ((directory-pathname-p pathname)
    9919        (process-output-translations (validate-output-translations-directory pathname)
    9920                                     :inherit inherit :collect collect))
    9921       ((probe-file* pathname :truename *resolve-symlinks*)
    9922        (process-output-translations (validate-output-translations-file pathname)
    9923                                     :inherit inherit :collect collect))
    9924       (t
    9925        (inherit-output-translations inherit :collect collect))))
    9926   (defmethod process-output-translations ((string string) &key inherit collect)
    9927     (process-output-translations (parse-output-translations-string string)
    9928                                  :inherit inherit :collect collect))
    9929   (defmethod process-output-translations ((x null) &key inherit collect)
    9930     (declare (ignorable x))
    9931     (inherit-output-translations inherit :collect collect))
    9932   (defmethod process-output-translations ((form cons) &key inherit collect)
    9933     (dolist (directive (cdr (validate-output-translations-form form)))
    9934       (process-output-translations-directive directive :inherit inherit :collect collect)))
    9935 
    9936   (defun compute-output-translations (&optional parameter)
    9937     "read the configuration, return it"
    9938     (remove-duplicates
    9939      (while-collecting (c)
    9940        (inherit-output-translations
    9941         `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
    9942      :test 'equal :from-end t))
    9943 
    9944   (defvar *output-translations-parameter* nil)
    9945 
    9946   (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
    9947     "read the configuration, initialize the internal configuration variable,
    9948 return the configuration"
    9949     (setf *output-translations-parameter* parameter
    9950           (output-translations) (compute-output-translations parameter)))
    9951 
    9952   (defun disable-output-translations ()
    9953     "Initialize output translations in a way that maps every file to itself,
    9954 effectively disabling the output translation facility."
    9955     (initialize-output-translations
    9956      '(:output-translations :disable-cache :ignore-inherited-configuration)))
    9957 
    9958   ;; checks an initial variable to see whether the state is initialized
    9959   ;; or cleared. In the former case, return current configuration; in
    9960   ;; the latter, initialize.  ASDF will call this function at the start
    9961   ;; of (asdf:find-system).
    9962   (defun ensure-output-translations ()
    9963     (if (output-translations-initialized-p)
    9964         (output-translations)
    9965         (initialize-output-translations)))
    9966 
    9967   (defun* (apply-output-translations) (path)
    9968     (etypecase path
    9969       (logical-pathname
    9970        path)
    9971       ((or pathname string)
    9972        (ensure-output-translations)
    9973        (loop* :with p = (resolve-symlinks* path)
    9974               :for (source destination) :in (car *output-translations*)
    9975               :for root = (when (or (eq source t)
    9976                                     (and (pathnamep source)
    9977                                          (not (absolute-pathname-p source))))
    9978                             (pathname-root p))
    9979               :for absolute-source = (cond
    9980                                        ((eq source t) (wilden root))
    9981                                        (root (merge-pathnames* source root))
    9982                                        (t source))
    9983               :when (or (eq source t) (pathname-match-p p absolute-source))
    9984               :return (translate-pathname* p absolute-source destination root source)
    9985               :finally (return p)))))
    9986 
    9987   ;; Hook into uiop's output-translation mechanism
    9988   #-cormanlisp
    9989   (setf *output-translation-function* 'apply-output-translations)
    9990 
    9991   #+abcl
    9992   (defun translate-jar-pathname (source wildcard)
    9993     (declare (ignore wildcard))
    9994     (flet ((normalize-device (pathname)
    9995              (if (find :windows *features*)
    9996                  pathname
    9997                  (make-pathname :defaults pathname :device :unspecific))))
    9998       (let* ((jar
    9999                (pathname (first (pathname-device source))))
    10000              (target-root-directory-namestring
    10001                (format nil "/___jar___file___root___/~@[~A/~]"
    10002                        (and (find :windows *features*)
    10003                             (pathname-device jar))))
    10004              (relative-source
    10005                (relativize-pathname-directory source))
    10006              (relative-jar
    10007                (relativize-pathname-directory (ensure-directory-pathname jar)))
    10008              (target-root-directory
    10009                (normalize-device
    10010                 (pathname-directory-pathname
    10011                  (parse-namestring target-root-directory-namestring))))
    10012              (target-root
    10013                (merge-pathnames* relative-jar target-root-directory))
    10014              (target
    10015                (merge-pathnames* relative-source target-root)))
    10016         (normalize-device (apply-output-translations target))))))
    10017 
    1001810428;;;; -------------------------------------------------------------------------
    1001910429;;; Backward-compatible interfaces
     
    1005810468  (defgeneric operation-on-warnings (operation))
    1005910469  (defgeneric operation-on-failure (operation))
    10060   #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
    10061   #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
     10470  (defgeneric (setf operation-on-warnings) (x operation))
     10471  (defgeneric (setf operation-on-failure) (x operation))
    1006210472  (defmethod operation-on-warnings ((o operation))
    1006310473    (declare (ignorable o)) *compile-file-warnings-behaviour*)
     
    1018910599                (acons property new-value (slot-value c 'properties)))))
    1019010600    new-value))
    10191 ;;;; -----------------------------------------------------------------
    10192 ;;;; Source Registry Configuration, by Francois-Rene Rideau
    10193 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
    10194 
    10195 (asdf/package:define-package :asdf/source-registry
    10196   (:recycle :asdf/source-registry :asdf)
    10197   (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
     10601;;;; -------------------------------------------------------------------------
     10602;;;; Package systems in the style of quick-build or faslpath
     10603
     10604(uiop:define-package :asdf/package-system
     10605  (:recycle :asdf/package-system :asdf)
     10606  (:use :uiop/common-lisp :uiop
     10607        :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
     10608        :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
    1019810609  (:export
    10199    #:*source-registry-parameter* #:*default-source-registries*
    10200    #:invalid-source-registry
    10201    #:source-registry-initialized-p
    10202    #:initialize-source-registry #:clear-source-registry #:*source-registry*
    10203    #:ensure-source-registry #:*source-registry-parameter*
    10204    #:*default-source-registry-exclusions* #:*source-registry-exclusions*
    10205    #:*wild-asd* #:directory-asd-files #:register-asd-directory
    10206    #:collect-asds-in-directory #:collect-sub*directories-asd-files
    10207    #:validate-source-registry-directive #:validate-source-registry-form
    10208    #:validate-source-registry-file #:validate-source-registry-directory
    10209    #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
    10210    #:user-source-registry #:system-source-registry
    10211    #:user-source-registry-directory #:system-source-registry-directory
    10212    #:environment-source-registry #:process-source-registry
    10213    #:compute-source-registry #:flatten-source-registry
    10214    #:sysdef-source-registry-search))
    10215 (in-package :asdf/source-registry)
    10216 
    10217 (with-upgradability ()
    10218   (define-condition invalid-source-registry (invalid-configuration warning)
    10219     ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    10220 
    10221   ;; Using ack 1.2 exclusions
    10222   (defvar *default-source-registry-exclusions*
    10223     '(".bzr" ".cdv"
    10224       ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
    10225       ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    10226       "_sgbak" "autom4te.cache" "cover_db" "_build"
    10227       "debian")) ;; debian often builds stuff under the debian directory... BAD.
    10228 
    10229   (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    10230 
    10231   (defvar *source-registry* nil
    10232     "Either NIL (for uninitialized), or an equal hash-table, mapping
    10233 system names to pathnames of .asd files")
    10234 
    10235   (defun source-registry-initialized-p ()
    10236     (typep *source-registry* 'hash-table))
    10237 
    10238   (defun clear-source-registry ()
    10239     "Undoes any initialization of the source registry."
    10240     (setf *source-registry* nil)
    10241     (values))
    10242   (register-clear-configuration-hook 'clear-source-registry)
    10243 
    10244   (defparameter *wild-asd*
    10245     (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
    10246 
    10247   (defun directory-asd-files (directory)
    10248     (directory-files directory *wild-asd*))
    10249 
    10250   (defun collect-asds-in-directory (directory collect)
    10251     (map () collect (directory-asd-files directory)))
    10252 
    10253   (defun collect-sub*directories-asd-files
    10254       (directory &key (exclude *default-source-registry-exclusions*) collect)
    10255     (collect-sub*directories
    10256      directory
    10257      (constantly t)
    10258      #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
    10259      #'(lambda (dir) (collect-asds-in-directory dir collect))))
    10260 
    10261   (defun validate-source-registry-directive (directive)
    10262     (or (member directive '(:default-registry))
    10263         (and (consp directive)
    10264              (let ((rest (rest directive)))
    10265                (case (first directive)
    10266                  ((:include :directory :tree)
    10267                   (and (length=n-p rest 1)
    10268                        (location-designator-p (first rest))))
    10269                  ((:exclude :also-exclude)
    10270                   (every #'stringp rest))
    10271                  ((:default-registry)
    10272                   (null rest)))))))
    10273 
    10274   (defun validate-source-registry-form (form &key location)
    10275     (validate-configuration-form
    10276      form :source-registry 'validate-source-registry-directive
    10277           :location location :invalid-form-reporter 'invalid-source-registry))
    10278 
    10279   (defun validate-source-registry-file (file)
    10280     (validate-configuration-file
    10281      file 'validate-source-registry-form :description "a source registry"))
    10282 
    10283   (defun validate-source-registry-directory (directory)
    10284     (validate-configuration-directory
    10285      directory :source-registry 'validate-source-registry-directive
    10286                :invalid-form-reporter 'invalid-source-registry))
    10287 
    10288   (defun parse-source-registry-string (string &key location)
    10289     (cond
    10290       ((or (null string) (equal string ""))
    10291        '(:source-registry :inherit-configuration))
    10292       ((not (stringp string))
    10293        (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
    10294       ((find (char string 0) "\"(")
    10295        (validate-source-registry-form (read-from-string string) :location location))
    10296       (t
    10297        (loop
    10298          :with inherit = nil
    10299          :with directives = ()
    10300          :with start = 0
    10301          :with end = (length string)
    10302          :with separator = (inter-directory-separator)
    10303          :for pos = (position separator string :start start) :do
    10304            (let ((s (subseq string start (or pos end))))
    10305              (flet ((check (dir)
    10306                       (unless (absolute-pathname-p dir)
    10307                         (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
    10308                       dir))
    10309                (cond
    10310                  ((equal "" s) ; empty element: inherit
    10311                   (when inherit
    10312                     (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    10313                            string))
    10314                   (setf inherit t)
    10315                   (push ':inherit-configuration directives))
    10316                  ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
    10317                   (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
    10318                  (t
    10319                   (push `(:directory ,(check s)) directives))))
    10320              (cond
    10321                (pos
    10322                 (setf start (1+ pos)))
    10323                (t
    10324                 (unless inherit
    10325                   (push '(:ignore-inherited-configuration) directives))
    10326                 (return `(:source-registry ,@(nreverse directives))))))))))
    10327 
    10328   (defun register-asd-directory (directory &key recurse exclude collect)
    10329     (if (not recurse)
    10330         (collect-asds-in-directory directory collect)
    10331         (collect-sub*directories-asd-files
    10332          directory :exclude exclude :collect collect)))
    10333 
    10334   (defparameter *default-source-registries*
    10335     '(environment-source-registry
    10336       user-source-registry
    10337       user-source-registry-directory
    10338       system-source-registry
    10339       system-source-registry-directory
    10340       default-source-registry))
    10341 
    10342   (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
    10343   (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
    10344 
    10345   (defun wrapping-source-registry ()
    10346     `(:source-registry
    10347       #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
    10348       #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
    10349       :inherit-configuration
    10350       #+cmu (:tree #p"modules:")
    10351       #+scl (:tree #p"file://modules/")))
    10352   (defun default-source-registry ()
    10353     `(:source-registry
    10354       #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
    10355       ,@(loop :for dir :in
    10356               `(,@(when (os-unix-p)
    10357                     `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
    10358                            (subpathname (user-homedir-pathname) ".local/share/"))
    10359                       ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
    10360                             '("/usr/local/share" "/usr/share"))))
    10361                 ,@(when (os-windows-p)
    10362                     (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
    10363               :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
    10364               :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
    10365       :inherit-configuration))
    10366   (defun user-source-registry (&key (direction :input))
    10367     (in-user-configuration-directory *source-registry-file* :direction direction))
    10368   (defun system-source-registry (&key (direction :input))
    10369     (in-system-configuration-directory *source-registry-file* :direction direction))
    10370   (defun user-source-registry-directory (&key (direction :input))
    10371     (in-user-configuration-directory *source-registry-directory* :direction direction))
    10372   (defun system-source-registry-directory (&key (direction :input))
    10373     (in-system-configuration-directory *source-registry-directory* :direction direction))
    10374   (defun environment-source-registry ()
    10375     (getenv "CL_SOURCE_REGISTRY"))
    10376 
    10377   (defgeneric* (process-source-registry) (spec &key inherit register))
    10378 
    10379   (defun* (inherit-source-registry) (inherit &key register)
    10380     (when inherit
    10381       (process-source-registry (first inherit) :register register :inherit (rest inherit))))
    10382 
    10383   (defun* (process-source-registry-directive) (directive &key inherit register)
    10384     (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
    10385       (ecase kw
    10386         ((:include)
    10387          (destructuring-bind (pathname) rest
    10388            (process-source-registry (resolve-location pathname) :inherit nil :register register)))
    10389         ((:directory)
    10390          (destructuring-bind (pathname) rest
    10391            (when pathname
    10392              (funcall register (resolve-location pathname :ensure-directory t)))))
    10393         ((:tree)
    10394          (destructuring-bind (pathname) rest
    10395            (when pathname
    10396              (funcall register (resolve-location pathname :ensure-directory t)
    10397                       :recurse t :exclude *source-registry-exclusions*))))
    10398         ((:exclude)
    10399          (setf *source-registry-exclusions* rest))
    10400         ((:also-exclude)
    10401          (appendf *source-registry-exclusions* rest))
    10402         ((:default-registry)
    10403          (inherit-source-registry '(default-source-registry) :register register))
    10404         ((:inherit-configuration)
    10405          (inherit-source-registry inherit :register register))
    10406         ((:ignore-inherited-configuration)
    10407          nil)))
    10408     nil)
    10409 
    10410   (defmethod process-source-registry ((x symbol) &key inherit register)
    10411     (process-source-registry (funcall x) :inherit inherit :register register))
    10412   (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
    10413     (cond
    10414       ((directory-pathname-p pathname)
    10415        (let ((*here-directory* (resolve-symlinks* pathname)))
    10416          (process-source-registry (validate-source-registry-directory pathname)
    10417                                   :inherit inherit :register register)))
    10418       ((probe-file* pathname :truename *resolve-symlinks*)
    10419        (let ((*here-directory* (pathname-directory-pathname pathname)))
    10420          (process-source-registry (validate-source-registry-file pathname)
    10421                                   :inherit inherit :register register)))
    10422       (t
    10423        (inherit-source-registry inherit :register register))))
    10424   (defmethod process-source-registry ((string string) &key inherit register)
    10425     (process-source-registry (parse-source-registry-string string)
    10426                              :inherit inherit :register register))
    10427   (defmethod process-source-registry ((x null) &key inherit register)
    10428     (declare (ignorable x))
    10429     (inherit-source-registry inherit :register register))
    10430   (defmethod process-source-registry ((form cons) &key inherit register)
    10431     (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
    10432       (dolist (directive (cdr (validate-source-registry-form form)))
    10433         (process-source-registry-directive directive :inherit inherit :register register))))
    10434 
    10435   (defun flatten-source-registry (&optional parameter)
     10610   #:package-system #:register-system-packages #:sysdef-package-system-search
     10611   #:*defpackage-forms* #:*package-systems* #:package-system-missing-package-error))
     10612(in-package :asdf/package-system)
     10613
     10614(with-upgradability ()
     10615  (defparameter *defpackage-forms* '(cl:defpackage uiop:define-package))
     10616
     10617  (defun initial-package-systems-table ()
     10618    (let ((h (make-hash-table :test 'equal)))
     10619      (dolist (p (list-all-packages))
     10620        (dolist (n (package-names p))
     10621          (setf (gethash n h) t)))
     10622      h))
     10623
     10624  (defvar *package-systems* (initial-package-systems-table))
     10625
     10626  (defclass package-system (system)
     10627    ())
     10628
     10629  (defun defpackage-form-p (form)
     10630    (and (consp form)
     10631         (member (car form) *defpackage-forms*)))
     10632
     10633  (defun stream-defpackage-form (stream)
     10634    (loop :for form = (read stream nil nil) :while form
     10635          :when (defpackage-form-p form) :return form))
     10636
     10637  (defun file-defpackage-form (file)
     10638    (with-input-file (f file)
     10639      (stream-defpackage-form f)))
     10640
     10641  (define-condition package-system-missing-package-error (system-definition-error)
     10642    ((system :initarg :system :reader error-system)
     10643     (pathname :initarg :pathname :reader error-pathname))
     10644    (:report (lambda (c s)
     10645               (format s (compatfmt "~@<No package form found while ~
     10646                                     trying to define package-system ~A from file ~A~>")
     10647                       (error-system c) (error-pathname c)))))
     10648
     10649  (defun package-dependencies (defpackage-form)
     10650    (assert (defpackage-form-p defpackage-form))
    1043610651    (remove-duplicates
    10437      (while-collecting (collect)
    10438        (with-pathname-defaults () ;; be location-independent
    10439          (inherit-source-registry
    10440           `(wrapping-source-registry
    10441             ,parameter
    10442             ,@*default-source-registries*)
    10443           :register #'(lambda (directory &key recurse exclude)
    10444                         (collect (list directory :recurse recurse :exclude exclude))))))
    10445      :test 'equal :from-end t))
    10446 
    10447   ;; Will read the configuration and initialize all internal variables.
    10448   (defun compute-source-registry (&optional parameter (registry *source-registry*))
    10449     (dolist (entry (flatten-source-registry parameter))
    10450       (destructuring-bind (directory &key recurse exclude) entry
    10451         (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
    10452           (register-asd-directory
    10453            directory :recurse recurse :exclude exclude :collect
    10454            #'(lambda (asd)
    10455                (let* ((name (pathname-name asd))
    10456                       (name (if (typep asd 'logical-pathname)
    10457                                 ;; logical pathnames are upper-case,
    10458                                 ;; at least in the CLHS and on SBCL,
    10459                                 ;; yet (coerce-name :foo) is lower-case.
    10460                                 ;; won't work well with (load-system "Foo")
    10461                                 ;; instead of (load-system 'foo)
    10462                                 (string-downcase name)
    10463                                 name)))
    10464                  (cond
    10465                    ((gethash name registry) ; already shadowed by something else
    10466                     nil)
    10467                    ((gethash name h) ; conflict at current level
    10468                     (when *verbose-out*
    10469                       (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
    10470                                 found several entries for ~A - picking ~S over ~S~:>")
    10471                             directory recurse name (gethash name h) asd)))
    10472                    (t
    10473                     (setf (gethash name registry) asd)
    10474                     (setf (gethash name h) asd))))))
    10475           h)))
    10476     (values))
    10477 
    10478   (defvar *source-registry-parameter* nil)
    10479 
    10480   (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
    10481     ;; Record the parameter used to configure the registry
    10482     (setf *source-registry-parameter* parameter)
    10483     ;; Clear the previous registry database:
    10484     (setf *source-registry* (make-hash-table :test 'equal))
    10485     ;; Do it!
    10486     (compute-source-registry parameter))
    10487 
    10488   ;; Checks an initial variable to see whether the state is initialized
    10489   ;; or cleared. In the former case, return current configuration; in
    10490   ;; the latter, initialize.  ASDF will call this function at the start
    10491   ;; of (asdf:find-system) to make sure the source registry is initialized.
    10492   ;; However, it will do so *without* a parameter, at which point it
    10493   ;; will be too late to provide a parameter to this function, though
    10494   ;; you may override the configuration explicitly by calling
    10495   ;; initialize-source-registry directly with your parameter.
    10496   (defun ensure-source-registry (&optional parameter)
    10497     (unless (source-registry-initialized-p)
    10498       (initialize-source-registry parameter))
    10499     (values))
    10500 
    10501   (defun sysdef-source-registry-search (system)
    10502     (ensure-source-registry)
    10503     (values (gethash (primary-system-name system) *source-registry*))))
    10504 
    10505 
     10652     (while-collecting (dep)
     10653       (loop* :for (option . arguments) :in (cddr defpackage-form) :do
     10654              (ecase option
     10655                ((:use :mix :reexport :use-reexport :mix-reexport)
     10656                 (dolist (p arguments) (dep (string p))))
     10657                ((:import-from :shadowing-import-from)
     10658                 (dep (string (first arguments))))
     10659                ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
     10660     :from-end t :test 'equal))
     10661
     10662  (defun package-designator-name (package)
     10663    (etypecase package
     10664      (package (package-name package))
     10665      (string package)
     10666      (symbol (string package))))
     10667
     10668  (defun register-system-packages (system packages)
     10669    (let ((name (or (eq system t) (coerce-name system))))
     10670      (dolist (p (ensure-list packages))
     10671        (setf (gethash (package-designator-name p) *package-systems*) name))))
     10672
     10673  (defun package-name-system (package-name)
     10674    (check-type package-name string)
     10675    (if-let ((system-name (gethash package-name *package-systems*)))
     10676      system-name
     10677      (string-downcase package-name)))
     10678
     10679  (defun package-system-file-dependencies (file &optional system)
     10680    (if-let (defpackage-form (file-defpackage-form file))
     10681      (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
     10682      (error 'package-system-missing-package-error :system system :pathname file)))
     10683
     10684  (defun same-package-system-p (system name directory subpath dependencies)
     10685    (and (eq (type-of system) 'package-system)
     10686         (equal (component-name system) name)
     10687         (pathname-equal directory (component-pathname system))
     10688         (equal dependencies (component-sideway-dependencies system))
     10689         (let ((children (component-children system)))
     10690           (and (length=n-p children 1)
     10691                (let ((child (first children)))
     10692                  (and (eq (type-of child) 'cl-source-file)
     10693                       (equal (component-name child) "lisp")
     10694                       (and (slot-boundp child 'relative-pathname)
     10695                            (equal (slot-value child 'relative-pathname) subpath))))))))
     10696
     10697  (defun sysdef-package-system-search (system)
     10698    (let ((primary (primary-system-name system)))
     10699      (unless (equal primary system)
     10700        (let ((top (find-system primary nil)))
     10701          (when (typep top 'package-system)
     10702            (if-let (dir (system-source-directory top))
     10703              (let* ((sub (subseq system (1+ (length primary))))
     10704                     (f (probe-file* (subpathname dir sub :type "lisp")
     10705                                     :truename *resolve-symlinks*)))
     10706                (when (file-pathname-p f)
     10707                  (let ((dependencies (package-system-file-dependencies f system))
     10708                        (previous (cdr (system-registered-p system))))
     10709                    (if (same-package-system-p previous system dir sub dependencies)
     10710                        previous
     10711                        (eval `(defsystem ,system
     10712                                 :class package-system
     10713                                 :source-file nil
     10714                                 :pathname ,dir
     10715                                 :depends-on ,dependencies
     10716                                 :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))
     10717
     10718(with-upgradability ()
     10719  (pushnew 'sysdef-package-system-search *system-definition-search-functions*))
    1050610720;;;; ---------------------------------------------------------------------------
    1050710721;;;; Handle ASDF package upgrade, including implementation-dependent magic.
     
    1052010734   :asdf/operation :asdf/action :asdf/lisp-action
    1052110735   :asdf/output-translations :asdf/source-registry
    10522    :asdf/plan :asdf/operate :asdf/defsystem :asdf/bundle :asdf/concatenate-source
    10523    :asdf/backward-internals :asdf/backward-interface)
     10736   :asdf/plan :asdf/operate :asdf/parse-defsystem :asdf/bundle :asdf/concatenate-source
     10737   :asdf/backward-internals :asdf/backward-interface :asdf/package-system)
    1052410738  ;; TODO: automatically generate interface with reexport?
    1052510739  (:export
     
    1056310777   #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
    1056410778   #:static-file #:doc-file #:html-file
    10565    #:file-type
    10566    #:source-file-type
     10779   #:file-type #:source-file-type
     10780
     10781   #:package-system #:register-system-packages
    1056710782
    1056810783   #:component-children          ; component accessors
     
    1062410839   #:circular-dependency        ; errors
    1062510840   #:duplicate-names #:non-toplevel-system #:non-system-system
     10841   #:package-system-missing-package-error
    1062610842
    1062710843   #:try-recompiling
     
    1067810894(asdf/package:define-package :asdf/footer
    1067910895  (:recycle :asdf/footer :asdf)
    10680   (:use :uiop/common-lisp :uiop :asdf/upgrade
    10681    :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action
    10682    :asdf/operate :asdf/bundle :asdf/concatenate-source
    10683    :asdf/output-translations :asdf/source-registry
    10684    :asdf/backward-internals :asdf/defsystem :asdf/backward-interface))
     10896  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/operate :asdf/bundle))
    1068510897(in-package :asdf/footer)
    1068610898
     
    1072910941    (setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl-warn-save*))
    1073010942
    10731   (dolist (f '(:asdf :asdf2 :asdf3)) (pushnew f *features*))
    10732 
    10733   (provide :asdf)
     10943  (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf-package-system)) (pushnew f *features*))
     10944
     10945  (provide "asdf") (provide "ASDF") ;; do it both ways to satisfy more people.
    1073410946
    1073510947  (cleanup-upgraded-asdf))
     
    1073810950  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
    1073910951
    10740 
Note: See TracChangeset for help on using the changeset viewer.