Changeset 13253


Ignore:
Timestamp:
03/20/11 15:18:25 (11 years ago)
Author:
Mark Evenson
Message:

Upgrade to asdf-2.013.

Location:
trunk/abcl
Files:
2 edited

Legend:

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

    r13125 r13253  
    3636@url{http://common-lisp.net/project/asdf/asdf.html}.
    3737
    38 ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
    39 
    40 This manual Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
    41 
    42 This manual revised @copyright{} 2009-2010 Robert P. Goldman and Francois-Rene Rideau.
     38ASDF Copyright @copyright{} 2001-2011 Daniel Barlow and contributors.
     39
     40This manual Copyright @copyright{} 2001-2011 Daniel Barlow and contributors.
     41
     42This manual revised @copyright{} 2009-2011 Robert P. Goldman and Francois-Rene Rideau.
    4343
    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 <joe@@example.com>"
    673673  :licence "Public Domain"
     
    725725without having to edit the system definition.
    726726
     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.
     730@item
     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
     739
    727740@end itemize
    728741
     
    736749@lisp
    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
    854 
    855867
    856868
     
    954966on the other hand, you can circumvent the file type that would otherwise
    955967be forced upon you if you were specifying a string.
     968
     969@subsection Version specifiers
     970@cindex version specifiers
     971@cindex :version
     972
     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.
     978
     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.
     982
     983@xref{Common attributes of components}.
    956984
    957985
     
    13931421
    13941422@subsubsection Version identifier
    1395 
    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
     1425
     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}.
    1401 
    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}.
     1432
     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.
     1439
    14061440
    14071441
     
    15091543I'm sure they'd welcome your fixes.
    15101544@c Doesn't CLISP now support LIST method combination?
     1545
     1546See the discussion of the semantics of @code{:version} in the defsystem
     1547grammar.
     1548
     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.
     1552
    15111553
    15121554@subsubsection pathname
     
    23522394RELATIVE-COMPONENT-DESIGNATOR :=
    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:
    26622704
     2705@defun coerce-pathname name @&key type defaults
     2706
     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*}.
     2721
     2722@end defun
     2723
     2724@defun merge-pathnames* @&key specified defaults
     2725
     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.
     2731
     2732@end defun
     2733
    26632734@defun system-relative-pathname system name @&key type
    26642735
    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
     2738
     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}.
     2744
     2745It returns a pathname built from the location of the system's
     2746source directory and the relative pathname. For example:
    26702747
    26712748@lisp
    2672 > (asdf:system-relative-pathname 'cl-ppcre #p"regex.data")
     2749> (asdf:system-relative-pathname 'cl-ppcre "regex.data")
    26732750#P"/repository/other/cl-ppcre/regex.data"
    26742751@end lisp
    26752752
    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
    26822754
     
    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}.
     2874@code{merge-pathnames*},
     2875@code{coerce-pathname}.
    28042876
    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.
    33;;;
    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'
    1616
    1717;;; -- LICENSE START
     
    4848#+xcvb (module ())
    4949
    50 (cl:in-package :cl-user)
     50(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
    5151
    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*))
    6668
    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
     
    279290
    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.:
    333 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
     348(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.013\")."
    334349  *asdf-version*)
    335350
     
    406421    (make-pathname :name nil :type nil :version nil :defaults pathname)))
    407422
     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))))
     435
     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)))))))))))
     457
    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))))))
    459490
     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)))
     498
     499
    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)))))
    471511
     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))
     517
    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))
    475521
    476522(defun* split-string (string &key max (separator '(#\Space #\Tab)))
     
    499545         ;; See CLHS make-pathname and 19.2.2.2.3.
    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)))
    557604
     605#+mcl
     606(eval-when (:compile-toplevel :load-toplevel :execute)
     607  (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))
     608
    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"))
    568626
    569627(defun* directory-pathname-p (pathname)
     
    603661                   :defaults pathspec))))
    604662
     663#+genera
     664(unless (fboundp 'ensure-directories-exist)
     665  (defun ensure-directories-exist (path)
     666    (fs:create-directories-recursively (pathname path))))
     667
    605668(defun* absolute-pathname-p (pathspec)
    606669  (and (typep pathspec '(or pathname string))
     
    630693     :collect form)))
    631694
    632 #-(and (or win32 windows mswindows mingw32) (not cygwin))
     695#+asdf-unix
    633696(progn
    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)))))))
    674737
    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)))
    711776
    712777(defun* default-directory ()
     
    728793  (merge-pathnames* *wild-path* path))
    729794
     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))))
     798
    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 https://bugs.launchpad.net/asdf/+bug/485687
    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)))
    902966
     
    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)))))
    909973
    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)))))
    917981
    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)))))
    922986
    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)))))
    928992
    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~]~@{ ~@?~}")))
    9671031
    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    ;; http://www.cliki.net/poiu
     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 - http://www.cliki.net/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))))
    10211089
    10221090
     
    10241092
    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)))
    10281096
     
    10341102
    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)
     
    10401108
    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)
     
    11171185
    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))))
    11711240
    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*))
    11941263
     
    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)))
     
    13501419
    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)))
     
    14291498
    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))
     1503
     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)
     
    14611544
    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)))
    15741657
     
    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))))))))
    16391722
     
    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))))))))
    16911774
    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)))
    18551938
     
    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)))
    18771960
    18781961(defun output-file (operation component)
     
    18831966
    18841967(defmethod perform :before ((operation compile-op) (c source-file))
    1885   (map nil #'ensure-directories-exist (output-files operation c)))
    1886 
    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)))
    18951973
    18961974(defmethod perform :after ((operation operation) (c component))
     
    18981976        (get-universal-time)))
    18991977
    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.")
    19041980
    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)))
    19422016
    19432017(defmethod perform ((operation compile-op) (c static-file))
     
    19652039
    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)))
    19722042
    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)))
    20692139
     
    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)))
    22572329
    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)))
    25172589
     
    25242596
    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))
    25332605
    25342606(defparameter *os-features*
     
    25382610    (:macosx :darwin :darwin-target :apple)
    25392611    :freebsd :netbsd :openbsd :bsd
    2540     :unix))
     2612    :unix
     2613    :genera))
    25412614
    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))
    25532627
    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))
    25882664
    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)))))
    26282704
    26292705
     
    26322708
    26332709(defparameter *inter-directory-separator*
    2634   #+(or unix cygwin) #\:
    2635   #-(or unix cygwin) #\;)
     2710  #+asdf-unix #\:
     2711  #-asdf-unix #\;)
    26362712
    26372713(defun* user-homedir ()
    2638   (truename (user-homedir-pathname)))
     2714  (truenamize (pathname-directory-pathname (user-homedir-pathname))))
    26392715
    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)
    28062883
     
    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))
    30163094
    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/"))
    30193097
    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))
    31083186
    3109 (defun* initialize-output-translations (&optional parameter)
     3187(defvar *output-translations-parameter* nil)
     3188
     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)))
    31133194
    31143195(defun* disable-output-translations ()
     
    31863267
    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)))
    31903271
     
    32793360;;;; http://www.wotsit.org/list.asp?fc=13
    32803361
    3281 #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     3362#+(and asdf-windows (not clisp))
    32823363(progn
    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)))
    33933473
    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))
    34153499
     
    35063590    default-source-registry))
    35073591
    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/"))
    35103594
    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)))
    36263710
     
    36353719         :recurse recurse :exclude exclude :collect #'collect)))))
    36363720
    3637 (defun* initialize-source-registry (&optional parameter)
    3638   (setf (source-registry) (compute-source-registry parameter)))
     3721(defvar *source-registry-parameter* nil)
     3722
     3723(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
     3724  (setf *source-registry-parameter* parameter
     3725        (source-registry) (compute-source-registry parameter)))
    36393726
    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 https://bugs.launchpad.net/asdf/+bug/485687
    36963783;;;;
    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))))))
    37083784
    37093785;;; If a previous version of ASDF failed to read some configuration, try again.
Note: See TracChangeset for help on using the changeset viewer.