Changeset 13253

03/20/11 15:18:25 (12 years ago)
Mark Evenson

Upgrade to asdf-2.013.

2 edited


  • trunk/abcl/doc/asdf/asdf.texinfo

    r13125 r13253  
    38 ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
    40 This manual Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
    42 This manual revised @copyright{} 2009-2010 Robert P. Goldman and Francois-Rene Rideau.
     38ASDF Copyright @copyright{} 2001-2011 Daniel Barlow and contributors.
     40This manual Copyright @copyright{} 2001-2011 Daniel Barlow and contributors.
     42This manual revised @copyright{} 2009-2011 Robert P. Goldman and Francois-Rene Rideau.
    4444Permission is hereby granted, free of charge, to any person obtaining
    669669(defsystem "hello-lisp"
    670670  :description "hello-lisp: a sample Lisp system."
    671   :version "0.2"
     671  :version "0.2.1"
    672672  :author "Joe User <>"
    673673  :licence "Public Domain"
    725725without having to edit the system definition.
     727@c FIXME: Should have cross-reference to "Version specifiers" in the
     728@c defsystem grammar, but the cross-referencing is so broken by
     729@c insufficient node breakdown that I have not put one in.
     731Make sure you know how the @code{:version} numbers will be parsed!  They
     732are parsed as period-separated lists of integers.  I.e., in the example,
     733@code{0.2.1} is to be interpreted, roughly speaking, as @code{(0 2 1)}.
     734In particular, version @code{0.2.1} is interpreted the same as
     735@code{0.0002.1} and is strictly version-less-than version @code{0.20.1},
     736even though the two are the same when interpreted as decimal fractions.
     737@cindex version specifiers
     738@cindex :version
    727740@end itemize
    737750(defsystem "foo"
    738   :version "1.0"
     751  :version "1.0.0"
    739752  :components ((:module "mod"
    740753                            :components ((:file "bar")
    852865component-dep-fail-option := :fail | :try-next | :ignore
    853866@end example
    954966on the other hand, you can circumvent the file type that would otherwise
    955967be forced upon you if you were specifying a string.
     969@subsection Version specifiers
     970@cindex version specifiers
     971@cindex :version
     973Version specifiers are parsed as period-separated lists of integers.  I.e., in the example,
     974@code{0.2.1} is to be interpreted, roughly speaking, as @code{(0 2 1)}.
     975In particular, version @code{0.2.1} is interpreted the same as
     976@code{0.0002.1} and is strictly version-less-than version @code{0.20.1},
     977even though the two are the same when interpreted as decimal fractions.
     979System definers are encouraged to use version identifiers of the form
     980@var{x}.@var{y}.@var{z} for major version, minor version (compatible
     981API) and patch level.
     983@xref{Common attributes of components}.
    13941422@subsubsection Version identifier
    1396 This optional attribute is used by the @code{test-system-version} operation.
    1397 @xref{Predefined operations of ASDF}.
    1398 For the default method of @code{test-system-version},
     1423@findex version-satisfies
     1424@cindex :version
     1426This optional attribute is used by the generic function
     1427@code{version-satisfies}, which tests to see if @code{:version}
     1428dependencies are satisfied.
    13991429the version should be a string of integers separated by dots,
    14001430for example @samp{1.0.11}.
    1402 @emph{Nota Bene}:
    1403 This operation, planned for ASDF 1,
    1404 is still not implement yet as of ASDF 2.
    1405 Don't hold your breath.
     1431For more information on the semantics of version specifiers, see @ref{The defsystem grammar}.
     1433@c This optional attribute is intended to be used by the @code{test-system-version} operation.
     1434@c @xref{Predefined operations of ASDF}.
     1435@c @emph{Nota Bene}:
     1436@c This operation, planned for ASDF 1,
     1437@c is still not implemented yet as of ASDF 2.
     1438@c Don't hold your breath.
    15091543I'm sure they'd welcome your fixes.
    15101544@c Doesn't CLISP now support LIST method combination?
     1546See the discussion of the semantics of @code{:version} in the defsystem
     1549@c FIXME: Should have cross-reference to "Version specifiers" in the
     1550@c defsystem grammar, but the cross-referencing is so broken by
     1551@c insufficient node breakdown that I have not put one in.
    15121554@subsubsection pathname
    23532395    STRING | ;; namestring, directory is assumed. If the last component, /**/*.* is added
    2354     PATHNAME | ;; pathname unless last component, directory is assumed.
     2396    PATHNAME | ;; pathname; unless last component, directory is assumed.
    23552397    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
    23562398    :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
    26612703useful for system definition and development. These include:
     2705@defun coerce-pathname name @&key type defaults
     2707This function takes an argument, and portably interprets it as a pathname.
     2708If the argument @var{name} is a pathname or @code{nil}, it is passed through;
     2709if it's a symbol, it's interpreted as a string by downcasing it;
     2710if it's a string, it is first separated using @code{/} into substrings;
     2711the leading substrings denote subdirectories of a relative pathname.
     2712If @var{type} is @code{:directory} or the string ends with @code{/},
     2713the last substring is also a subdirectory;
     2714if @var{type} is a string, it is used as the type of the pathname, and
     2715the last substring is the name component of the pathname;
     2716if @var{type} is @code{nil}, the last substring specifies both name and type components
     2717of the pathname, with the last @code{.} separating them, or only the name component
     2718if there's no last @code{.} or if there is only one dot and it's the first character.
     2719The host, device and version components come from @var{defaults}, which defaults to
     2720@var{*default-pathname-defaults*}; but that shouldn't matter if you use @code{merge-pathnames*}.
     2722@end defun
     2724@defun merge-pathnames* @&key specified defaults
     2726This function is a replacement for @code{merge-pathnames} that uses the host and device
     2727from the @var{defaults} rather than the @var{specified} pathname when the latter
     2728is a relative pathname. This allows ASDF and its users to create and use relative pathnames
     2729without having to know beforehand what are the host and device
     2730of the absolute pathnames they are relative to.
     2732@end defun
    26632734@defun system-relative-pathname system name @&key type
    26652736It's often handy to locate a file relative to some system.
    26662737The @code{system-relative-pathname} function meets this need.
    2667 It takes two arguments: the name of a system and a relative pathname.
    2668 It returns a pathname built from the location of the system's source file
    2669 and the relative pathname. For example
     2739It takes two mandatory arguments @var{system} and @var{name}
     2740and a keyword argument @var{type}:
     2741@var{system} is name of a system, whereas @var{name} and optionally @var{type}
     2742specify a relative pathname, interpreted like a component pathname specifier
     2743by @code{coerce-pathname}. @xref{The defsystem grammar,,Pathname specifiers}.
     2745It returns a pathname built from the location of the system's
     2746source directory and the relative pathname. For example:
    2672 > (asdf:system-relative-pathname 'cl-ppcre #p"")
     2749> (asdf:system-relative-pathname 'cl-ppcre "")
    26742751@end lisp
    2676 Instead of a pathname, you can provide a symbol or a string,
    2677 and optionally a keyword argument @code{type}.
    2678 The arguments will then be interpreted in the same way
    2679 as pathname specifiers for components.
    2680 @xref{The defsystem grammar,,Pathname specifiers}.
    26812753@end defun
    28002872Naming files within a system definition becomes easy and portable again.
    28012873@xref{Miscellaneous additional functionality,asdf:system-relative-pathname},
    2802 @code{asdf-utilities:merge-pathnames*},
    2803 @code{asdf::merge-component-name-type}.
    28052877On the other hand, there are places where systems used to accept namestrings
    30523124  (declare (ignorable component system)) "cl")}.
    30533125Now, the pathname for a component is eagerly computed when defining the system,
    3054 and instead you will @code{(defclass my-cl-source-file (cl-source-file) ((type :iniform "cl")))}
     3126and instead you will @code{(defclass my-cl-source-file (cl-source-file) ((type :initform "cl")))}
    30553127and use @code{:default-component-class my-cl-source-file} as argument to @code{defsystem},
    30563128as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below.
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r13125 r13253  
    1 ;;; -*- mode: common-lisp; package: asdf; -*-
    2 ;;; This is ASDF: Another System Definition Facility.
     1;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
     2;;; This is ASDF 2.013: Another System Definition Facility.
    44;;; Feedback, bug reports, and patches are all welcome:
    1111;;; location above for a more recent version (and for documentation
    1212;;; and test files, if your copy came without them) before reporting
    13 ;;; bugs.  There are usually two "supported" revisions - the git HEAD
    14 ;;; is the latest development version, whereas the revision tagged
    15 ;;; RELEASE may be slightly older but is considered `stable'
     13;;; bugs.  There are usually two "supported" revisions - the git master
     14;;; branch is the latest development version, whereas the git release
     15;;; branch may be slightly older but is considered `stable'
    1717;;; -- LICENSE START
    4848#+xcvb (module ())
    50 (cl:in-package :cl-user)
     50(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
    5252#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
    5656  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
    5757  (unless (find-package :asdf)
    58     (make-package :asdf :use '(:cl)))
     58    (make-package :asdf :use '(:common-lisp)))
    5959  ;;; Implementation-dependent tweaks
    6060  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
    6363        (remove "asdf" excl::*autoload-package-name-alist*
    6464                :test 'equalp :key 'car))
    65   #+ecl (require :cmp))
     65  #+(and ecl (not ecl-bytecmp)) (require :cmp)
     66  #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
     67  #+(or unix cygwin) (pushnew :asdf-unix *features*))
    6769(in-package :asdf)
    7779         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
    7880         ;; can help you do these changes in synch (look at the source for documentation).
     81         ;; Relying on its automation, the version is now redundantly present on top of this file.
    7982         ;; "2.345" would be an official release
    8083         ;; "2.345.6" would be a development version in the official upstream
    8184         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    8285         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    83          (asdf-version "2.012")
     86         (asdf-version "2.013")
    8487         (existing-asdf (fboundp 'find-system))
    8588         (existing-version *asdf-version*)
    8891      (when existing-asdf
    8992        (format *trace-output*
    90          "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%"
     93         "~&; Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
    9194         existing-version asdf-version))
    9295      (labels
    93           ((unlink-package (package)
     96          ((present-symbol-p (symbol package)
     97             (member (nth-value 1 (find-symbol symbol package)) '(:internal :external)))
     98           (present-symbols (package)
     99             ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
     100             (let (l)
     101               (do-symbols (s package)
     102                 (when (present-symbol-p s package) (push s l)))
     103               (reverse l)))
     104           (unlink-package (package)
    94105             (let ((u (find-package package)))
    95106               (when u
    96                  (ensure-unintern u
    97                    (loop :for s :being :each :present-symbol :in u :collect s))
     107                 (ensure-unintern u (present-symbols u))
    98108                 (loop :for p :in (package-used-by-list u) :do
    99109                   (unuse-package u p))
    149159                   (bothly-exported-symbols nil)
    150160                   (newly-exported-symbols nil))
    151                (loop :for sym :being :each :external-symbol :in package :do
     161               (do-external-symbols (sym package)
    152162                 (if (member sym export :test 'string-equal)
    153163                     (push sym bothly-exported-symbols)
    187197            #:perform-with-restarts #:component-relative-pathname
    188198            #:system-source-file #:operate #:find-component #:find-system
    189             #:apply-output-translations #:translate-pathname* #:resolve-location)
     199            #:apply-output-translations #:translate-pathname* #:resolve-location
     200            #:compile-file*)
    190201           :unintern
    191202           (#:*asdf-revision* #:around #:asdf-method-combination
    280291            #:clear-configuration
     292            #:*output-translations-parameter*
    281293            #:initialize-output-translations
    282294            #:disable-output-translations
    288300            #:enable-asdf-binary-locations-compatibility
    289301            #:*default-source-registries*
     302            #:*source-registry-parameter*
    290303            #:initialize-source-registry
    291304            #:compute-source-registry
    309322            ;; #:find-symbol*
    310323            #:merge-pathnames*
     324            #:coerce-pathname
    311325            #:pathname-directory-pathname
    312326            #:read-file-forms
    320334            #:truenamize
    321335            #:while-collecting)))
     336  #+genera (import 'scl:boolean :asdf)
    322337        (setf *asdf-version* asdf-version
    323338              *upgraded-p* (if existing-version
    331346  "Exported interface to the version of ASDF currently installed. A string.
    332347You can compare this string with e.g.:
    334349  *asdf-version*)
    406421    (make-pathname :name nil :type nil :version nil :defaults pathname)))
     423(defun* normalize-pathname-directory-component (directory)
     424  (cond
     425    #-(or sbcl cmu)
     426    ((stringp directory) `(:absolute ,directory) directory)
     427    #+gcl
     428    ((and (consp directory) (stringp (first directory)))
     429     `(:absolute ,@directory))
     430    ((or (null directory)
     431         (and (consp directory) (member (first directory) '(:absolute :relative))))
     432     directory)
     433    (t
     434     (error "Unrecognized pathname directory component ~S" directory))))
     436(defun* merge-pathname-directory-components (specified defaults)
     437  (let ((directory (normalize-pathname-directory-component specified)))
     438    (ecase (first directory)
     439      ((nil) defaults)
     440      (:absolute specified)
     441      (:relative
     442       (let ((defdir (normalize-pathname-directory-component defaults))
     443             (reldir (cdr directory)))
     444         (cond
     445           ((null defdir)
     446            directory)
     447           ((not (eq :back (first reldir)))
     448            (append defdir reldir))
     449           (t
     450            (loop :with defabs = (first defdir)
     451              :with defrev = (reverse (rest defdir))
     452              :while (and (eq :back (car reldir))
     453                          (or (and (eq :absolute defabs) (null defrev))
     454                              (stringp (car defrev))))
     455              :do (pop reldir) (pop defrev)
     456              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
    408458(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    409459  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
    414464  (let* ((specified (pathname specified))
    415465         (defaults (pathname defaults))
    416          (directory (pathname-directory specified))
    417          (directory
    418           (cond
    419             #-(or sbcl cmu scl)
    420             ((stringp directory) `(:absolute ,directory) directory)
    421             #+gcl
    422             ((and (consp directory) (not (member (first directory) '(:absolute :relative))))
    423              `(:relative ,@directory))
    424             ((or (null directory)
    425                  (and (consp directory) (member (first directory) '(:absolute :relative))))
    426              directory)
    427             (t
    428              (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
     466         (directory (normalize-pathname-directory-component (pathname-directory specified)))
    429467         (name (or (pathname-name specified) (pathname-name defaults)))
    430468         (type (or (pathname-type specified) (pathname-type defaults)))
    436474      (multiple-value-bind (host device directory unspecific-handler)
    437475          (ecase (first directory)
    438             ((nil)
    439              (values (pathname-host defaults)
    440                      (pathname-device defaults)
    441                      (pathname-directory defaults)
    442                      (unspecific-handler defaults)))
    443476            ((:absolute)
    444477             (values (pathname-host specified)
    446479                     directory
    447480                     (unspecific-handler specified)))
    448             ((:relative)
     481            ((nil :relative)
    449482             (values (pathname-host defaults)
    450483                     (pathname-device defaults)
    451                      (if (pathname-directory defaults)
    452                          (append (pathname-directory defaults) (cdr directory))
    453                          directory)
     484                     (merge-pathname-directory-components directory (pathname-directory defaults))
    454485                     (unspecific-handler defaults))))
    455486        (make-pathname :host host :device device :directory directory
    458489                       :version (funcall unspecific-handler version))))))
     491(defun* pathname-parent-directory-pathname (pathname)
     492  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
     493and NIL NAME, TYPE and VERSION components"
     494  (when pathname
     495    (make-pathname :name nil :type nil :version nil
     496                   :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
     497                   :defaults pathname)))
    460500(define-modify-macro appendf (&rest args)
    461501  append "Append onto list") ;; only to be used on short lists.
    470510  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
     512(defun* errfmt (out format-string &rest format-args)
     513  (declare (dynamic-extent format-args))
     514  (apply #'format out
     515         #-genera (format nil "~~@<~A~~:>" format-string) #+genera format-string
     516         format-args))
    472518(defun* asdf-message (format-string &rest format-args)
    473519  (declare (dynamic-extent format-args))
    474   (apply #'format *verbose-out* format-string format-args))
     520  (apply #'errfmt *verbose-out* format-string format-args))
    476522(defun* split-string (string &key max (separator '(#\Space #\Tab)))
    499545         ;; See CLHS make-pathname and
    500546         ;; We only use it on implementations that support it.
    501          (or #+(or ccl gcl lispworks sbcl) :unspecific)))
     547         (or #+(or clozure gcl lispworks sbcl) :unspecific)))
    502548    (destructuring-bind (name &optional (type unspecific))
    503549        (split-string filename :max 2 :separator ".")
    536582                (values :relative nil))
    537583          (values :relative components))
    538       (setf components (remove "" components :test #'equal))
     584      (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
     585      (setf components (substitute :back ".." components :test #'equal))
    539586      (cond
    540587        ((equal last-comp "")
    556603    :append (list k v)))
     606(eval-when (:compile-toplevel :load-toplevel :execute)
     607  (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))
    558609(defun* getenv (x)
    559   (#+(or abcl clisp) ext:getenv
    560    #+allegro sys:getenv
    561    #+clozure ccl:getenv
    562    #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
    563    #+ecl si:getenv
    564    #+gcl system:getenv
    565    #+lispworks lispworks:environment-variable
    566    #+sbcl sb-ext:posix-getenv
    567    x))
     610  (declare (ignorable x))
     611  #+(or abcl clisp) (ext:getenv x)
     612  #+allegro (sys:getenv x)
     613  #+clozure (ccl:getenv x)
     614  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
     615  #+ecl (si:getenv x)
     616  #+gcl (system:getenv x)
     617  #+genera nil
     618  #+lispworks (lispworks:environment-variable x)
     619  #+mcl (ccl:with-cstrs ((name x))
     620          (let ((value (_getenv name)))
     621            (unless (ccl:%null-ptr-p value)
     622              (ccl:%get-cstring value))))
     623  #+sbcl (sb-ext:posix-getenv x)
     624  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl)
     625  (error "getenv not available on your implementation"))
    569627(defun* directory-pathname-p (pathname)
    603661                   :defaults pathspec))))
     664(unless (fboundp 'ensure-directories-exist)
     665  (defun ensure-directories-exist (path)
     666    (fs:create-directories-recursively (pathname path))))
    605668(defun* absolute-pathname-p (pathspec)
    606669  (and (typep pathspec '(or pathname string))
    630693     :collect form)))
    632 #-(and (or win32 windows mswindows mingw32) (not cygwin))
    634697  #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
    670733   (pathname (unless (wild-pathname-p p)
    671734               #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
    672                #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
    673                '(ignore-errors (truename p)))))))
     735                     #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
     736                     '(ignore-errors (truename p)))))))
    675738(defun* truenamize (p)
    676739  "Resolve as much of a pathname as possible"
    677740  (block nil
    678     (when (typep p 'logical-pathname) (return p))
     741    (when (typep p '(or null logical-pathname)) (return p))
    679742    (let* ((p (merge-pathnames* p))
    680743           (directory (pathname-directory p)))
    708771(defun* resolve-symlinks (path)
    709772  #-allegro (truenamize path)
    710   #+allegro (excl:pathname-resolve-symbolic-links path))
     773  #+allegro (if (typep path 'logical-pathname)
     774                path
     775                (excl:pathname-resolve-symbolic-links path)))
    712777(defun* default-directory ()
    728793  (merge-pathnames* *wild-path* path))
     795(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
     796  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
     797    (last-char (namestring foo))))
    730799(defun* directorize-pathname-host-device (pathname)
    731800  (let* ((root (pathname-root pathname))
    732801         (wild-root (wilden root))
    733802         (absolute-pathname (merge-pathnames* pathname root))
    734          (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
    735          (separator (last-char (namestring foo)))
     803         (separator (directory-separator-for-host root))
    736804         (root-namestring (namestring root))
    737805         (root-string
    738806          (substitute-if #\/
    739                          (lambda (x) (or (eql x #\:)
    740                                          (eql x separator)))
     807                         #'(lambda (x) (or (eql x #\:)
     808                                           (eql x separator)))
    741809                         root-namestring)))
    742810    (multiple-value-bind (relative path filename)
    857925;;; Methods in case of hot-upgrade. See
    858926(when *upgraded-p*
    859    #+ecl
    860    (when (find-class 'compile-op nil)
    861      (defmethod update-instance-for-redefined-class :after
    862          ((c compile-op) added deleted plist &key)
    863        (declare (ignore added deleted))
    864        (let ((system-p (getf plist 'system-p)))
    865          (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
    866927   (when (find-class 'module nil)
    867928     (eval
    870931         (declare (ignorable deleted plist))
    871932         (when (or *asdf-verbose* *load-verbose*)
    872            (asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version)))
     933           (asdf-message "~&; Updating ~A for ASDF ~A~%" m ,(asdf-version)))
    873934         (when (member 'components-by-name added)
    874935           (compute-module-components-by-name m))
    898959                error-component error-operation
    899960                module-components module-components-by-name
    900                 circular-dependency-components)
     961                circular-dependency-components
     962                condition-arguments condition-form
     963                condition-format condition-location
     964                coerce-name)
    901965         (ftype (function (t t) t) (setf module-components-by-name)))
    906970   (format-arguments :initarg :format-arguments :reader format-arguments))
    907971  (:report (lambda (c s)
    908              (apply #'format s (format-control c) (format-arguments c)))))
     972               (apply #'errfmt s (format-control c) (format-arguments c)))))
    910974(define-condition load-system-definition-error (system-definition-error)
    913977   (condition :initarg :condition :reader error-condition))
    914978  (:report (lambda (c s)
    915              (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>"
    916                      (error-name c) (error-pathname c) (error-condition c)))))
     979       (errfmt s "Error while trying to load definition for system ~A from pathname ~A: ~A"
     980         (error-name c) (error-pathname c) (error-condition c)))))
    918982(define-condition circular-dependency (system-definition-error)
    919983  ((components :initarg :components :reader circular-dependency-components))
    920984  (:report (lambda (c s)
    921              (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
     985       (errfmt s "Circular dependency: ~S" (circular-dependency-components c)))))
    923987(define-condition duplicate-names (system-definition-error)
    924988  ((name :initarg :name :reader duplicate-names-name))
    925989  (:report (lambda (c s)
    926              (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
    927                      (duplicate-names-name c)))))
     990       (errfmt s "Error while defining system: multiple components are given same name ~A"
     991         (duplicate-names-name c)))))
    929993(define-condition missing-component (system-definition-error)
    9451009   (operation :reader error-operation :initarg :operation))
    9461010  (:report (lambda (c s)
    947              (format s "~@<erred while invoking ~A on ~A~@:>"
    948                      (error-operation c) (error-component c)))))
     1011               (errfmt s "erred while invoking ~A on ~A"
     1012                       (error-operation c) (error-component c)))))
    9491013(define-condition compile-error (operation-error) ())
    9501014(define-condition compile-failed (compile-error) ())
    9571021   (arguments :reader condition-arguments :initarg :arguments :initform nil))
    9581022  (:report (lambda (c s)
    959              (format s "~@<~? (will be skipped)~@:>"
    960                      (condition-format c)
    961                      (list* (condition-form c) (condition-location c)
    962                             (condition-arguments c))))))
     1023               (errfmt s "~? (will be skipped)"
     1024                       (condition-format c)
     1025                       (list* (condition-form c) (condition-location c)
     1026                              (condition-arguments c))))))
    9631027(define-condition invalid-source-registry (invalid-configuration warning)
    964   ((format :initform "~@<invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~>")))
     1028  ((format :initform "invalid source registry ~S~@[ in ~S~]~@{ ~@?~}")))
    9651029(define-condition invalid-output-translation (invalid-configuration warning)
    966   ((format :initform "~@<invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~>")))
     1030  ((format :initform "invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}")))
    9681032(defclass component ()
    9701034         "Component name: designator for a string composed of portable pathname characters")
    9711035   (version :accessor component-version :initarg :version)
    972    ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
    973    ;; POIU is a parallel (multi-process build) extension of ASDF.  See
    974    ;;
     1036   (description :accessor component-description :initarg :description)
     1037   (long-description :accessor component-long-description :initarg :long-description)
     1038   ;; This one below is used by POIU -
     1039   ;; a parallelizing extension of ASDF that compiles in multiple parallel
     1040   ;; slave processes (forked on demand) and loads in the master process.
     1041   ;; Maybe in the future ASDF may use it internally instead of in-order-to.
    9751042   (load-dependencies :accessor component-load-dependencies :initform nil)
    9761043   ;; In the ASDF object model, dependencies exist between *actions*
    9911058   ;; hasn't yet been loaded in the current image (do-first).
    9921059   ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
     1060   ;; See our ASDF 2 paper for more complete explanations.
    9931061   (in-order-to :initform nil :initarg :in-order-to
    9941062                :accessor component-in-order-to)
    10181086(defmethod print-object ((c component) stream)
    10191087  (print-unreadable-object (c stream :type t :identity nil)
    1020     (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
     1088    (format stream "~{~S~^ ~}" (component-find-path c))))
    10251093(defmethod print-object ((c missing-dependency) s)
    1026   (format s "~@<~A, required by ~A~@:>"
     1094  (format s "~A, required by ~A"
    10271095          (call-next-method c nil) (missing-required-by c)))
    10351103(defmethod print-object ((c missing-component) s)
    1036   (format s "~@<component ~S not found~@[ in ~A~]~@:>"
     1104  (format s "component ~S not found~@[ in ~A~]"
    10371105          (missing-requires c)
    10381106          (when (missing-parent c)
    10411109(defmethod print-object ((c missing-component-of-version) s)
    1042   (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
     1110  (format s "component ~S does not match version ~A~@[ in ~A~]"
    10431111          (missing-requires c)
    10441112          (missing-version c)
    11181186(defclass system (module)
    1119   ((description :accessor system-description :initarg :description)
    1120    (long-description
    1121     :accessor system-long-description :initarg :long-description)
     1187  (;; description and long-description are now available for all component's,
     1188   ;; but now also inherited from component, but we add the legacy accessor
     1189   (description :accessor system-description :initarg :description)
     1190   (long-description :accessor system-long-description :initarg :long-description)
    11221191   (author :accessor system-author :initarg :author)
    11231192   (maintainer :accessor system-maintainer :initarg :maintainer)
    11681237    (symbol (string-downcase (symbol-name name)))
    11691238    (string name)
    1170     (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
     1239    (t (sysdef-error "invalid component designator ~A" name))))
    11721241(defun* system-registered-p (name)
    11861255FN should be a function of one argument. It will be
    11871256called with an object of type asdf:system."
    1188   (maphash (lambda (_ datum)
    1189              (declare (ignore _))
    1190              (destructuring-bind (_ . def) datum
     1257  (maphash #'(lambda (_ datum)
    11911258               (declare (ignore _))
    1192                (funcall fn def)))
     1259               (destructuring-bind (_ . def) datum
     1260                 (declare (ignore _))
     1261                 (funcall fn def)))
    11931262           *defined-systems*))
    12021271  (let ((system-name (coerce-name system)))
    12031272    (or
    1204      (some (lambda (x) (funcall x system-name))
     1273     (some #'(lambda (x) (funcall x system-name))
    12051274           *system-definition-search-functions*)
    12061275     (let ((system-pair (system-registered-p system-name)))
    12311300              :name name
    12321301              :type "asd")))
    1233         (when (probe-file file)
     1302        (when (probe-file* file)
    12341303          (return file)))
    1235       #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     1304      #+(and asdf-windows (not clisp))
    12361305      (let ((shortcut
    12371306             (make-pathname
    12391308              :name (concatenate 'string name ".asd")
    12401309              :type "lnk")))
    1241         (when (probe-file shortcut)
     1310        (when (probe-file* shortcut)
    12421311          (let ((target (parse-windows-shortcut shortcut)))
    12431312            (when target
    12611330                            (let* ((*print-circle* nil)
    12621331                                   (message
    1263                                     (format nil
    1264                                             "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
     1332                                    (errfmt nil
     1333                                            "While searching for system ~S: ~S evaluated to ~S which is not a directory."
    12651334                                            system dir defaults)))
    12661335                              (error message))
    12701339                          (coerce-entry-to-directory ()
    12711340                            :report (lambda (s)
    1272                                       (format s "Coerce entry to ~a, replace ~a and continue."
    1273                                               (ensure-directory-pathname defaults) dir))
     1341              (errfmt s "Coerce entry to ~a, replace ~a and continue."
     1342                (ensure-directory-pathname defaults) dir))
    12741343                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
    12751344        ;; cleanup
    13031372  ;; as if the file were very old.
    13041373  ;; (or should we treat the case in a different, special way?)
    1305   (or (and pathname (probe-file pathname) (file-write-date pathname))
     1374  (or (and pathname (probe-file* pathname) (file-write-date pathname))
    13061375      (progn
    13071376        (when (and pathname *asdf-verbose*)
    13181387    (unwind-protect
    13191388         (handler-bind
    1320              ((error (lambda (condition)
    1321                        (error 'load-system-definition-error
    1322                               :name name :pathname pathname
    1323                               :condition condition))))
     1389             ((error #'(lambda (condition)
     1390                         (error 'load-system-definition-error
     1391                                :name name :pathname pathname
     1392                                :condition condition))))
    13241393           (let ((*package* package))
    13251394             (asdf-message
    1326               "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
     1395              "~&; Loading system definition from ~A into ~A~%"
    13271396              pathname package)
    13281397             (load pathname)))
    13511420(defun* register-system (name system)
    1352   (asdf-message "~&~@<; ~@;Registering ~A as ~A~@:>~%" system name)
     1421  (asdf-message "~&; Registering ~A as ~A~%" system name)
    13531422  (setf (gethash (coerce-name name) *defined-systems*)
    13541423        (cons (get-universal-time) system)))
    14301499(defun* merge-component-name-type (name &key type defaults)
     1500  ;; For backwards compatibility only, for people using internals.
     1501  ;; Will be removed in a future release, e.g. 2.014.
     1502  (coerce-pathname name :type type :defaults defaults))
     1504(defun* coerce-pathname (name &key type defaults)
     1505  "coerce NAME into a PATHNAME.
     1506When given a string, portably decompose it into a relative pathname:
     1507#\\/ separates subdirectories. The last #\\/-separated string is as follows:
     1508if TYPE is NIL, its last #\\. if any separates name and type from from type;
     1509if TYPE is a string, it is the type, and the whole string is the name;
     1510if TYPE is :DIRECTORY, the string is a directory component;
     1511if the string is empty, it's a directory.
     1512Any directory named .. is read as :BACK.
     1513Host, device and version components are taken from DEFAULTS."
    14311514  ;; The defaults are required notably because they provide the default host
    14321515  ;; to the below make-pathname, which may crucially matter to people using
    14371520  ;; ASDF:MERGE-PATHNAMES*
    14381521  (etypecase name
    1439     (pathname
     1522    ((or null pathname)
    14401523     name)
    14411524    (symbol
    1442      (merge-component-name-type (string-downcase name) :type type :defaults defaults))
     1525     (coerce-pathname (string-downcase name) :type type :defaults defaults))
    14431526    (string
    14441527     (multiple-value-bind (relative path filename)
    14621545(defmethod component-relative-pathname ((component component))
    1463   (merge-component-name-type
     1546  (coerce-pathname
    14641547   (or (slot-value component 'relative-pathname)
    14651548       (component-name component))
    15691652(defmethod component-self-dependencies ((o operation) (c component))
    15701653  (let ((all-deps (component-depends-on o c)))
    1571     (remove-if-not (lambda (x)
    1572                      (member (component-name c) (cdr x) :test #'string=))
     1654    (remove-if-not #'(lambda (x)
     1655                       (member (component-name c) (cdr x) :test #'string=))
    15731656                   all-deps)))
    15771660        (self-deps (component-self-dependencies operation c)))
    15781661    (if self-deps
    1579         (mapcan (lambda (dep)
    1580                   (destructuring-bind (op name) dep
    1581                     (output-files (make-instance op)
    1582                                   (find-component parent name))))
     1662        (mapcan #'(lambda (dep)
     1663                    (destructuring-bind (op name) dep
     1664                      (output-files (make-instance op)
     1665                                    (find-component parent name))))
    15831666                self-deps)
    15841667        ;; no previous operations needed?  I guess we work with the
    16341717         ;; second). So that's cool.
    16351718         (and
    1636           (every #'probe-file in-files)
    1637           (every #'probe-file out-files)
     1719          (every #'probe-file* in-files)
     1720          (every #'probe-file* out-files)
    16381721          (>= (earliest-out) (latest-in))))))))
    16821765      (retry ()
    16831766        :report (lambda (s)
    1684                   (format s "~@<Retry loading component ~S.~@:>" required-c))
     1767      (errfmt s "Retry loading component ~S." required-c))
    16851768        :test
    16861769        (lambda (c)
    1687           (or (null c)
    1688               (and (typep c 'missing-dependency)
    1689                    (equalp (missing-requires c)
    1690                            required-c))))))))
     1770    (or (null c)
     1771        (and (typep c 'missing-dependency)
     1772       (equalp (missing-requires c)
     1773         required-c))))))))
    16921775(defun* do-dep (operation c collect op dep)
    18511934(defmethod perform ((operation operation) (c source-file))
    18521935  (sysdef-error
    1853    "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
     1936   "required method PERFORM not implemented for operation ~A, component ~A"
    18541937   (class-of operation) (class-of c)))
    18741957               :initform *compile-file-failure-behaviour*)
    18751958   (flags :initarg :flags :accessor compile-op-flags
    1876           :initform #-ecl nil #+ecl '(:system-p t))))
     1959          :initform nil)))
    18781961(defun output-file (operation component)
    18841967(defmethod perform :before ((operation compile-op) (c source-file))
    1885   (map nil #'ensure-directories-exist (output-files operation c)))
    1887 #+ecl
    1888 (defmethod perform :after ((o compile-op) (c cl-source-file))
    1889   ;; Note how we use OUTPUT-FILES to find the binary locations
    1890   ;; This allows the user to override the names.
    1891   (let* ((files (output-files o c))
    1892          (object (first files))
    1893          (fasl (second files)))
    1894     (c:build-fasl fasl :lisp-files (list object))))
     1968   (loop :for file :in (asdf:output-files operation c)
     1969     :for pathname = (if (typep file 'logical-pathname)
     1970                         (translate-logical-pathname file)
     1971                         file)
     1972     :do (ensure-directories-exist pathname)))
    18961974(defmethod perform :after ((operation operation) (c component))
    18981976        (get-universal-time)))
    1900 (declaim (ftype (function ((or pathname string)
    1901                            &rest t &key (:output-file t) &allow-other-keys)
    1902                           (values t t t))
    1903                 compile-file*))
     1978(defvar *compile-op-compile-file-function* 'compile-file*
     1979  "Function used to compile lisp files.")
    19051981;;; perform is required to check output-files to find out where to put
    19141990        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    19151991    (multiple-value-bind (output warnings-p failure-p)
    1916         (apply #'compile-file* source-file :output-file output-file
     1992        (apply *compile-op-compile-file-function* source-file :output-file output-file
    19171993               (compile-op-flags operation))
    19181994      (when warnings-p
    19191995        (case (operation-on-warnings operation)
    19201996          (:warn (warn
    1921                   "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
     1997                  "COMPILE-FILE warned while performing ~A on ~A."
    19221998                  operation c))
    19231999          (:error (error 'compile-warned :component c :operation operation))
    19262002        (case (operation-on-failure operation)
    19272003          (:warn (warn
    1928                   "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
     2004                  "COMPILE-FILE failed while performing ~A on ~A."
    19292005                  operation c))
    19302006          (:error (error 'compile-failed :component c :operation operation))
    19362012  (declare (ignorable operation))
    19372013  (let ((p (lispize-pathname (component-pathname c))))
    1938     #-:broken-fasl-loader
    1939     (list (compile-file-pathname p #+ecl :type #+ecl :object)
    1940           #+ecl (compile-file-pathname p :type :fasl))
    1941     #+:broken-fasl-loader (list p)))
     2014    #-broken-fasl-loader (list (compile-file-pathname p))
     2015    #+broken-fasl-loader (list p)))
    19432017(defmethod perform ((operation compile-op) (c static-file))
    19662040(defmethod perform ((o load-op) (c cl-source-file))
    1967   (map () #'load
    1968        #-ecl (input-files o c)
    1969        #+ecl (loop :for i :in (input-files o c)
    1970                :unless (string= (pathname-type i) "fas")
    1971                :collect (compile-file-pathname (lispize-pathname i)))))
     2041  (map () #'load (input-files o c)))
    19732043(defmethod perform-with-restarts (operation component)
    20622132  (let ((what-would-load-op-do (cdr (assoc 'load-op
    20632133                                           (component-in-order-to c)))))
    2064     (mapcar (lambda (dep)
    2065               (if (eq (car dep) 'load-op)
    2066                   (cons 'load-source-op (cdr dep))
    2067                   dep))
     2134    (mapcar #'(lambda (dep)
     2135                (if (eq (car dep) 'load-op)
     2136                    (cons 'load-source-op (cdr dep))
     2137                    dep))
    20682138            what-would-load-op-do)))
    21282198                :report
    21292199                (lambda (s)
    2130                   (format s "~@<Retry ~A.~@:>" (operation-description op component))))
     2200      (errfmt s "Retry ~A." (operation-description op component))))
    21312201              (accept ()
    21322202                :report
    21332203                (lambda (s)
    2134                   (format s "~@<Continue, treating ~A as having been successful.~@:>"
    2135                           (operation-description op component)))
     2204      (errfmt s "Continue, treating ~A as having been successful."
     2205        (operation-description op component)))
    21362206                (setf (gethash (type-of op)
    21372207                               (component-operation-times component))
    22112281  (let* ((file-pathname (load-pathname))
    22122282         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
    2213     (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
     2283    (or (and pathname-supplied-p
     2284             (merge-pathnames* (coerce-pathname pathname :type :directory)
     2285                               directory-pathname))
    22142286        directory-pathname
    22152287        (default-directory))))
    22542326           (or (module-default-component-class parent)
    22552327               (find-class *default-component-class*)))
    2256       (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
     2328      (sysdef-error "don't recognize component type ~A" type)))
    22582330(defun* maybe-add-tree (tree op1 op2 c)
    23112383         ;; methods will not be for this particular gf
    23122384         ;; But this is hardly performance-critical
    2313          (lambda (m)
    2314            (remove-method (symbol-function name) m))
     2385         #'(lambda (m)
     2386             (remove-method (symbol-function name) m))
    23152387         (component-inline-methods component)))
    23162388  ;; clear methods, then add the new ones
    25132585(defun* system-relative-pathname (system name &key type)
    25142586  (merge-pathnames*
    2515    (merge-component-name-type name :type type)
     2587   (coerce-pathname name :type type)
    25162588   (system-source-directory system)))
    25252597(defparameter *implementation-features*
    2526   '((:acl :allegro)
    2527     (:lw :lispworks)
    2528     (:digitool) ; before clozure, so it won't get preempted by ccl
     2598  '((:abcl :armedbear)
     2599    (:acl :allegro)
     2600    (:mcl :digitool) ; before clozure, so it won't get preempted by ccl
    25292601    (:ccl :clozure)
    25302602    (:corman :cormanlisp)
    2531     (:abcl :armedbear)
    2532     :sbcl :cmu :clisp :gcl :ecl :scl))
     2603    (:lw :lispworks)
     2604    :clisp :cmu :ecl :gcl :sbcl :scl :symbolics))
    25342606(defparameter *os-features*
    25382610    (:macosx :darwin :darwin-target :apple)
    25392611    :freebsd :netbsd :openbsd :bsd
    2540     :unix))
     2612    :unix
     2613    :genera))
    25422615(defparameter *architecture-features*
    25502623    (:sparc32 :sparc)
    25512624    (:arm :arm-target)
    2552     (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
     2625    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
     2626    :imach))
    25542628(defun* lisp-version-string ()
    25682642                      (if (member :64bit *features*) "-64bit" ""))
    25692643    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    2570     #+clisp (subseq s 0 (position #\space s))
     2644    #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
    25712645    #+clozure (format nil "~d.~d-f~d" ; shorten for windows
    25722646                      ccl::*openmcl-major-version*
    25742648                      (logand ccl::fasl-version #xFF))
    25752649    #+cmu (substitute #\- #\/ s)
    2576     #+digitool (subseq s 8)
    25772650    #+ecl (format nil "~A~@[-~A~]" s
    25782651                  (let ((vcs-id (ext:lisp-implementation-vcs-id)))
    25802653                      (subseq vcs-id 0 8))))
    25812654    #+gcl (subseq s (1+ (position #\space s)))
     2655    #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
     2656               (format nil "~D.~D" major minor))
    25822657    #+lispworks (format nil "~A~@[~A~]" s
    25832658                        (when (member :lispworks-64bit *features*) "-64bit"))
    25842659    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
    2585     #+(or cormanlisp mcl sbcl scl) s
    2586     #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
    2587           ecl gcl lispworks mcl sbcl scl) s))
     2660    #+mcl (subseq s 8) ; strip the leading "Version "
     2661    #+(or cormanlisp sbcl scl) s
     2662    #-(or allegro armedbear clisp clozure cmu cormanlisp
     2663          ecl gcl genera lispworks mcl sbcl scl) s))
    25892665(defun* first-feature (features)
    26172693          (os   (maybe-warn (first-feature *os-features*)
    26182694                            "No os feature found in ~a." *os-features*))
    2619           (arch #+clisp "" #-clisp
    2620                 (maybe-warn (first-feature *architecture-features*)
    2621                             "No architecture feature found in ~a."
    2622                             *architecture-features*))
     2695          (arch (or #-clisp
     2696                    (maybe-warn (first-feature *architecture-features*)
     2697                                "No architecture feature found in ~a."
     2698                                *architecture-features*)))
    26232699          (version (maybe-warn (lisp-version-string)
    26242700                               "Don't know how to get Lisp implementation version.")))
    26252701      (substitute-if
    2626        #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
    2627        (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
     2702       #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))
     2703       (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))
    26332709(defparameter *inter-directory-separator*
    2634   #+(or unix cygwin) #\:
    2635   #-(or unix cygwin) #\;)
     2710  #+asdf-unix #\:
     2711  #-asdf-unix #\;)
    26372713(defun* user-homedir ()
    2638   (truename (user-homedir-pathname)))
     2714  (truenamize (pathname-directory-pathname (user-homedir-pathname))))
    26402716(defun* try-directory-subpath (x sub &key type)
    26412717  (let* ((p (and x (ensure-directory-pathname x)))
    26422718         (tp (and p (probe-file* p)))
    2643          (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
     2719         (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))
    26442720         (ts (and sp (probe-file* sp))))
    26452721    (and ts (values sp ts))))
    26522728           :for dir :in (split-string dirs :separator ":")
    26532729           :collect (try dir "common-lisp/"))
    2654        #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2730       #+asdf-windows
    26552731        ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
    26562732            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    26612737   #'null
    26622738   (append
    2663     #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2739    #+asdf-windows
    26642740    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    26652741      `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
    26662742           ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    26672743        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
     2744    #+asdf-unix
    26682745    (list #p"/etc/common-lisp/"))))
    26692746(defun* in-first-directory (dirs x)
    27342811  (apply 'directory pathname-spec
    27352812         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
    2736                              #+ccl '(:follow-links nil)
     2813                             #+clozure '(:follow-links nil)
    27372814                             #+clisp '(:circle t :if-does-not-exist :ignore)
    27382815                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
    27822859    (or
    27832860     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
    2784      #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2861     #+asdf-windows
    27852862     (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
    27862863     '(:home ".cache" "common-lisp" :implementation))))
    27972874        (list
    27982875         (stable-sort (copy-list new-value) #'>
    2799                       :key (lambda (x)
    2800                              (etypecase (car x)
    2801                                ((eql t) -1)
    2802                                (pathname
    2803                                 (let ((directory (pathname-directory (car x))))
    2804                                   (if (listp directory) (length directory) 0))))))))
     2876                      :key #'(lambda (x)
     2877                               (etypecase (car x)
     2878                                 ((eql t) -1)
     2879                                 (pathname
     2880                                  (let ((directory (pathname-directory (car x))))
     2881                                    (if (listp directory) (length directory) 0))))))))
    28052882  new-value)
    28412918              ((eql :implementation) (implementation-identifier))
    28422919              ((eql :implementation-type) (string-downcase (implementation-type)))
    2843               #-(and (or win32 windows mswindows mingw32) (not cygwin))
     2920              #+asdf-unix
    28442921              ((eql :uid) (princ-to-string (get-uid)))))
    28452922         (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
    29122989                      (member :default-directory :*/ :**/ :*.*.*
    29132990                        :implementation :implementation-type
    2914                         #-(and (or win32 windows mswindows mingw32) (not cygwin)) :uid)))))
     2991                        #+asdf-unix :uid)))))
    29152992    (or (typep x 'boolean)
    29162993        (absolute-component-p x)
    30043081    ;; Some implementations have precompiled ASDF systems,
    30053082    ;; so we must disable translations for implementation paths.
    3006     #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
     3083    #+sbcl ,(let ((h (getenv "SBCL_HOME")))
     3084                 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
    30073085    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
    30083086    #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
    30153093    :enable-user-cache))
    3017 (defparameter *output-translations-file* #p"asdf-output-translations.conf")
    3018 (defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
     3095(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
     3096(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
    30203098(defun* user-output-translations-pathname ()
    30443122     (process-output-translations (validate-output-translations-directory pathname)
    30453123                                  :inherit inherit :collect collect))
    3046     ((probe-file pathname)
     3124    ((probe-file* pathname)
    30473125     (process-output-translations (validate-output-translations-file pathname)
    30483126                                  :inherit inherit :collect collect))
    31073185   :test 'equal :from-end t))
    3109 (defun* initialize-output-translations (&optional parameter)
     3187(defvar *output-translations-parameter* nil)
     3189(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
    31103190  "read the configuration, initialize the internal configuration variable,
    31113191return the configuration"
    3112   (setf (output-translations) (compute-output-translations parameter)))
     3192  (setf *output-translations-parameter* parameter
     3193        (output-translations) (compute-output-translations parameter)))
    31143195(defun* disable-output-translations ()
    31873268(defun* delete-file-if-exists (x)
    3188   (when (and x (probe-file x))
     3269  (when (and x (probe-file* x))
    31893270    (delete-file x)))
    3281 #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     3362#+(and asdf-windows (not clisp))
    32833364(defparameter *link-initial-dword* 76)
    33893470(defun directory-has-asd-files-p (directory)
    33903471  (ignore-errors
    3391     (directory* (merge-pathnames* *wild-asd* directory))
    3392     t))
     3472    (and (directory* (merge-pathnames* *wild-asd* directory)) t)))
    33943474(defun subdirectories (directory)
    33953475  (let* ((directory (ensure-directory-pathname directory))
    3396          #-cormanlisp
     3476         #-(or cormanlisp genera)
    33973477         (wild (merge-pathnames*
    33983478                #-(or abcl allegro lispworks scl)
    34013481                directory))
    34023482         (dirs
    3403           #-cormanlisp
     3483          #-(or cormanlisp genera)
    34043484          (ignore-errors
    3405             (directory* wild . #.(or #+ccl '(:directories t :files nil)
    3406                                      #+digitool '(:directories t))))
    3407           #+cormanlisp (cl::directory-subdirs directory))
    3408          #+(or abcl allegro lispworks scl)
     3485            (directory* wild . #.(or #+clozure '(:directories t :files nil)
     3486                                     #+mcl '(:directories t))))
     3487          #+cormanlisp (cl::directory-subdirs directory)
     3488          #+genera (fs:directory-list directory))
     3489         #+(or abcl allegro genera lispworks scl)
    34093490         (dirs (remove-if-not #+abcl #'extensions:probe-directory
    34103491                              #+allegro #'excl:probe-directory
    34113492                              #+lispworks #'lw:file-directory-p
    3412                               #-(or abcl allegro lispworks) #'directory-pathname-p
    3413                               dirs)))
     3493                              #+genera #'(lambda (x) (getf (cdr x) :directory))
     3494                              #-(or abcl allegro genera lispworks) #'directory-pathname-p
     3495                              dirs))
     3496         #+genera
     3497         (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs)))
    34143498    dirs))
    35063590    default-source-registry))
    3508 (defparameter *source-registry-file* #p"source-registry.conf")
    3509 (defparameter *source-registry-directory* #p"source-registry.conf.d/")
     3592(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
     3593(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
    35113595(defun* wrapping-source-registry ()
    35123596  `(:source-registry
    3513     #+sbcl (:tree ,(getenv "SBCL_HOME"))
     3597    #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
    35143598    :inherit-configuration
    35153599    #+cmu (:tree #p"modules:")))
    35183602    `(:source-registry
    35193603      #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
    3520       (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
     3604      (:directory ,(default-directory))
    35213605      ,@(let*
    3522          #+(or unix cygwin)
     3606         #+asdf-unix
    35233607         ((datahome
    35243608           (or (getenv "XDG_DATA_HOME")
    35273611           (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
    35283612          (dirs (cons datahome (split-string datadirs :separator ":"))))
    3529          #+(and (or win32 windows mswindows mingw32) (not cygwin))
     3613         #+asdf-windows
    35303614         ((datahome (getenv "APPDATA"))
    35313615          (datadir
    35343618                            "Application Data"))
    35353619          (dirs (list datahome datadir)))
    3536          #-(or unix win32 windows mswindows mingw32 cygwin)
     3620         #-(or asdf-unix asdf-windows)
    35373621         ((dirs ()))
    35383622         (loop :for dir :in dirs
    35653649       (process-source-registry (validate-source-registry-directory pathname)
    35663650                                :inherit inherit :register register)))
    3567     ((probe-file pathname)
     3651    ((probe-file* pathname)
    35683652     (let ((*here-directory* (pathname-directory-pathname pathname)))
    35693653       (process-source-registry (validate-source-registry-file pathname)
    36213705          ,parameter
    36223706          ,@*default-source-registries*)
    3623         :register (lambda (directory &key recurse exclude)
    3624                     (collect (list directory :recurse recurse :exclude exclude)))))
     3707        :register #'(lambda (directory &key recurse exclude)
     3708                      (collect (list directory :recurse recurse :exclude exclude)))))
    36253709     :test 'equal :from-end t)))
    36353719         :recurse recurse :exclude exclude :collect #'collect)))))
    3637 (defun* initialize-source-registry (&optional parameter)
    3638   (setf (source-registry) (compute-source-registry parameter)))
     3721(defvar *source-registry-parameter* nil)
     3723(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
     3724  (setf *source-registry-parameter* parameter
     3725        (source-registry) (compute-source-registry parameter)))
    36403727;; Checks an initial variable to see whether the state is initialized
    36693756      ((style-warning #'muffle-warning)
    36703757       (missing-component (constantly nil))
    3671        (error (lambda (e)
    3672                 (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
    3673                         name e))))
     3758       (error #'(lambda (e)
     3759                  (errfmt *error-output* "ASDF could not load ~(~A~) because ~A.~%"
     3760                          name e))))
    36743761    (let* ((*verbose-out* (make-broadcast-stream))
    36753762           (system (find-system (string-downcase name) nil)))
    36953782;;;; See
    3697 ;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
    3698 (eval-when (:compile-toplevel :load-toplevel :execute)
    3699   #+ecl ;; Support upgrade from before ECL went to 1.369
    3700   (when (fboundp 'compile-op-system-p)
    3701     (defmethod compile-op-system-p ((op compile-op))
    3702       (getf :system-p (compile-op-flags op)))
    3703     (defmethod initialize-instance :after ((op compile-op)
    3704                                            &rest initargs
    3705                                            &key system-p &allow-other-keys)
    3706       (declare (ignorable initargs))
    3707       (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
    37093785;;; If a previous version of ASDF failed to read some configuration, try again.
Note: See TracChangeset for help on using the changeset viewer.