Changeset 14706


Ignore:
Timestamp:
Apr 8, 2011, 11:38:24 AM (14 years ago)
Author:
R. Matthew Emerson
Message:

ASDF 2.014 from upstream.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/source/tools/asdf.lisp

    r14688 r14706  
    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.014: 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)
     70
     71;;; Strip out formating that is not supported on Genera.
     72(defmacro compatfmt (format)
     73  #-genera format
     74  #+genera
     75  (let ((r '(("~@<" . "")
     76             ("; ~@;" . "; ")
     77             ("~3i~_" . "")
     78             ("~@:>" . "")
     79             ("~:>" . ""))))
     80    (dolist (i r)
     81      (loop :for found = (search (car i) format) :while found :do
     82        (setf format (concatenate 'simple-string (subseq format 0 found)
     83                                  (cdr i)
     84                                  (subseq format (+ found (length (car i))))))))
     85    format))
    6886
    6987;;;; Create packages in a way that is compatible with hot-upgrade.
    … …  
    7795         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
    7896         ;; can help you do these changes in synch (look at the source for documentation).
     97         ;; Relying on its automation, the version is now redundantly present on top of this file.
    7998         ;; "2.345" would be an official release
    8099         ;; "2.345.6" would be a development version in the official upstream
    81100         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    82101         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    83          (asdf-version "2.012")
     102         (asdf-version "2.014")
    84103         (existing-asdf (fboundp 'find-system))
    85104         (existing-version *asdf-version*)
    … …  
    88107      (when existing-asdf
    89108        (format *trace-output*
    90          "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%"
    91          existing-version asdf-version))
     109                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
     110                existing-version asdf-version))
    92111      (labels
    93           ((unlink-package (package)
     112          ((present-symbol-p (symbol package)
     113             (member (nth-value 1 (find-sym symbol package)) '(:internal :external)))
     114           (present-symbols (package)
     115             ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
     116             (let (l)
     117               (do-symbols (s package)
     118                 (when (present-symbol-p s package) (push s l)))
     119               (reverse l)))
     120           (unlink-package (package)
    94121             (let ((u (find-package package)))
    95122               (when u
    96                  (ensure-unintern u
    97                    (loop :for s :being :each :present-symbol :in u :collect s))
     123                 (ensure-unintern u (present-symbols u))
    98124                 (loop :for p :in (package-used-by-list u) :do
    99125                   (unuse-package u p))
    … …  
    149175                   (bothly-exported-symbols nil)
    150176                   (newly-exported-symbols nil))
    151                (loop :for sym :being :each :external-symbol :in package :do
     177               (do-external-symbols (sym package)
    152178                 (if (member sym export :test 'string-equal)
    153179                     (push sym bothly-exported-symbols)
    … …  
    187213            #:perform-with-restarts #:component-relative-pathname
    188214            #:system-source-file #:operate #:find-component #:find-system
    189             #:apply-output-translations #:translate-pathname* #:resolve-location)
     215            #:apply-output-translations #:translate-pathname* #:resolve-location
     216            #:compile-file*)
    190217           :unintern
    191218           (#:*asdf-revision* #:around #:asdf-method-combination
    … …  
    279306
    280307            #:clear-configuration
     308            #:*output-translations-parameter*
    281309            #:initialize-output-translations
    282310            #:disable-output-translations
    … …  
    288316            #:enable-asdf-binary-locations-compatibility
    289317            #:*default-source-registries*
     318            #:*source-registry-parameter*
    290319            #:initialize-source-registry
    291320            #:compute-source-registry
    … …  
    309338            ;; #:find-symbol*
    310339            #:merge-pathnames*
     340            #:coerce-pathname
    311341            #:pathname-directory-pathname
    312342            #:read-file-forms
    … …  
    320350            #:truenamize
    321351            #:while-collecting)))
     352        #+genera (import 'scl:boolean :asdf)
    322353        (setf *asdf-version* asdf-version
    323354              *upgraded-p* (if existing-version
    … …  
    331362  "Exported interface to the version of ASDF currently installed. A string.
    332363You can compare this string with e.g.:
    333 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
     364(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.013\")."
    334365  *asdf-version*)
    335366
    … …  
    406437    (make-pathname :name nil :type nil :version nil :defaults pathname)))
    407438
     439(defun* normalize-pathname-directory-component (directory)
     440  (cond
     441    #-(or cmu sbcl scl)
     442    ((stringp directory) `(:absolute ,directory) directory)
     443    #+gcl
     444    ((and (consp directory) (stringp (first directory)))
     445     `(:absolute ,@directory))
     446    ((or (null directory)
     447         (and (consp directory) (member (first directory) '(:absolute :relative))))
     448     directory)
     449    (t
     450     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
     451
     452(defun* merge-pathname-directory-components (specified defaults)
     453  (let ((directory (normalize-pathname-directory-component specified)))
     454    (ecase (first directory)
     455      ((nil) defaults)
     456      (:absolute specified)
     457      (:relative
     458       (let ((defdir (normalize-pathname-directory-component defaults))
     459             (reldir (cdr directory)))
     460         (cond
     461           ((null defdir)
     462            directory)
     463           ((not (eq :back (first reldir)))
     464            (append defdir reldir))
     465           (t
     466            (loop :with defabs = (first defdir)
     467              :with defrev = (reverse (rest defdir))
     468              :while (and (eq :back (car reldir))
     469                          (or (and (eq :absolute defabs) (null defrev))
     470                              (stringp (car defrev))))
     471              :do (pop reldir) (pop defrev)
     472              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
     473
    408474(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    409475  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
    … …  
    412478  (when (null specified) (return-from merge-pathnames* defaults))
    413479  (when (null defaults) (return-from merge-pathnames* specified))
     480  #+scl
     481  (ext:resolve-pathname specified defaults)
     482  #-scl
    414483  (let* ((specified (pathname specified))
    415484         (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))))
     485         (directory (normalize-pathname-directory-component (pathname-directory specified)))
    429486         (name (or (pathname-name specified) (pathname-name defaults)))
    430487         (type (or (pathname-type specified) (pathname-type defaults)))
    … …  
    436493      (multiple-value-bind (host device directory unspecific-handler)
    437494          (ecase (first directory)
    438             ((nil)
    439              (values (pathname-host defaults)
    440                      (pathname-device defaults)
    441                      (pathname-directory defaults)
    442                      (unspecific-handler defaults)))
    443495            ((:absolute)
    444496             (values (pathname-host specified)
    … …  
    446498                     directory
    447499                     (unspecific-handler specified)))
    448             ((:relative)
     500            ((nil :relative)
    449501             (values (pathname-host defaults)
    450502                     (pathname-device defaults)
    451                      (if (pathname-directory defaults)
    452                          (append (pathname-directory defaults) (cdr directory))
    453                          directory)
     503                     (merge-pathname-directory-components directory (pathname-directory defaults))
    454504                     (unspecific-handler defaults))))
    455505        (make-pathname :host host :device device :directory directory
    … …  
    458508                       :version (funcall unspecific-handler version))))))
    459509
     510(defun* pathname-parent-directory-pathname (pathname)
     511  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
     512and NIL NAME, TYPE and VERSION components"
     513  (when pathname
     514    (make-pathname :name nil :type nil :version nil
     515                   :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
     516                   :defaults pathname)))
     517
     518
    460519(define-modify-macro appendf (&rest args)
    461520  append "Append onto list") ;; only to be used on short lists.
    … …  
    470529  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    471530
     531         
    472532(defun* asdf-message (format-string &rest format-args)
    473533  (declare (dynamic-extent format-args))
    … …  
    499559         ;; See CLHS make-pathname and 19.2.2.2.3.
    500560         ;; We only use it on implementations that support it.
    501          (or #+(or ccl gcl lispworks sbcl) :unspecific)))
     561         (or #+(or clozure gcl lispworks sbcl) :unspecific)))
    502562    (destructuring-bind (name &optional (type unspecific))
    503563        (split-string filename :max 2 :separator ".")
    … …  
    524584  (check-type s string)
    525585  (when (find #\: s)
    526     (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
     586    (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
    527587  (let* ((components (split-string s :separator "/"))
    528588         (last-comp (car (last components))))
    … …  
    532592                (progn
    533593                  (when force-relative
    534                     (error "absolute pathname designator not allowed: ~S" s))
     594                    (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
    535595                  (values :absolute (cdr components)))
    536596                (values :relative nil))
    537597          (values :relative components))
    538       (setf components (remove "" components :test #'equal))
     598      (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
     599      (setf components (substitute :back ".." components :test #'equal))
    539600      (cond
    540601        ((equal last-comp "")
    … …  
    556617    :append (list k v)))
    557618
     619#+mcl
     620(eval-when (:compile-toplevel :load-toplevel :execute)
     621  (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))
     622
    558623(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))
     624  (declare (ignorable x))
     625  #+(or abcl clisp) (ext:getenv x)
     626  #+allegro (sys:getenv x)
     627  #+clozure (ccl:getenv x)
     628  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
     629  #+ecl (si:getenv x)
     630  #+gcl (system:getenv x)
     631  #+genera nil
     632  #+lispworks (lispworks:environment-variable x)
     633  #+mcl (ccl:with-cstrs ((name x))
     634          (let ((value (_getenv name)))
     635            (unless (ccl:%null-ptr-p value)
     636              (ccl:%get-cstring value))))
     637  #+sbcl (sb-ext:posix-getenv x)
     638  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl)
     639  (error "getenv not available on your implementation"))
    568640
    569641(defun* directory-pathname-p (pathname)
    … …  
    591663    (ensure-directory-pathname (pathname pathspec)))
    592664   ((not (pathnamep pathspec))
    593     (error "Invalid pathname designator ~S" pathspec))
     665    (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
    594666   ((wild-pathname-p pathspec)
    595     (error "Can't reliably convert wild pathname ~S" pathspec))
     667    (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
    596668   ((directory-pathname-p pathspec)
    597669    pathspec)
    … …  
    603675                   :defaults pathspec))))
    604676
     677#+genera
     678(unless (fboundp 'ensure-directories-exist)
     679  (defun ensure-directories-exist (path)
     680    (fs:create-directories-recursively (pathname path))))
     681
    605682(defun* absolute-pathname-p (pathspec)
    606683  (and (typep pathspec '(or pathname string))
    … …  
    630707     :collect form)))
    631708
    632 #-(and (or win32 windows mswindows mingw32) (not cygwin))
     709#+asdf-unix
    633710(progn
    634711  #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
    … …  
    654731
    655732(defun* pathname-root (pathname)
    656   (make-pathname :host (pathname-host pathname)
    657                  :device (pathname-device pathname)
    658                  :directory '(:absolute)
    659                  :name nil :type nil :version nil))
     733  (make-pathname :directory '(:absolute)
     734                 :name nil :type nil :version nil
     735                 :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password
     736                 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
    660737
    661738(defun* find-symbol* (s p)
    … …  
    670747   (pathname (unless (wild-pathname-p p)
    671748               #.(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)))))))
     749                     #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
     750                     '(ignore-errors (truename p)))))))
    674751
    675752(defun* truenamize (p)
    676753  "Resolve as much of a pathname as possible"
    677754  (block nil
    678     (when (typep p 'logical-pathname) (return p))
     755    (when (typep p '(or null logical-pathname)) (return p))
    679756    (let* ((p (merge-pathnames* p))
    680757           (directory (pathname-directory p)))
    … …  
    682759      (let ((found (probe-file* p)))
    683760        (when found (return found)))
    684       #-(or sbcl cmu) (when (stringp directory) (return p))
     761      #-(or cmu sbcl scl) (when (stringp directory) (return p))
    685762      (when (not (eq :absolute (car directory))) (return p))
    686763      (let ((sofar (probe-file* (pathname-root p))))
    … …  
    708785(defun* resolve-symlinks (path)
    709786  #-allegro (truenamize path)
    710   #+allegro (excl:pathname-resolve-symbolic-links path))
     787  #+allegro (if (typep path 'logical-pathname)
     788                path
     789                (excl:pathname-resolve-symbolic-links path)))
    711790
    712791(defun* default-directory ()
    … …  
    728807  (merge-pathnames* *wild-path* path))
    729808
     809#-scl
     810(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
     811  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
     812    (last-char (namestring foo))))
     813
     814#-scl
    730815(defun* directorize-pathname-host-device (pathname)
    731816  (let* ((root (pathname-root pathname))
    732817         (wild-root (wilden root))
    733818         (absolute-pathname (merge-pathnames* pathname root))
    734          (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
    735          (separator (last-char (namestring foo)))
     819         (separator (directory-separator-for-host root))
    736820         (root-namestring (namestring root))
    737821         (root-string
    738822          (substitute-if #\/
    739                          (lambda (x) (or (eql x #\:)
    740                                          (eql x separator)))
     823                         #'(lambda (x) (or (eql x #\:)
     824                                           (eql x separator)))
    741825                         root-namestring)))
    742826    (multiple-value-bind (relative path filename)
    … …  
    747831                            :directory `(:absolute ,@path))))
    748832        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
     833
     834#+scl
     835(defun* directorize-pathname-host-device (pathname)
     836  (let ((scheme (ext:pathname-scheme pathname))
     837        (host (pathname-host pathname))
     838        (port (ext:pathname-port pathname))
     839        (directory (pathname-directory pathname)))
     840    (flet ((not-unspecific (component)
     841             (and (not (eq component :unspecific)) component)))
     842      (cond ((or (not-unspecific port)
     843                 (and (not-unspecific host) (plusp (length host)))
     844                 (not-unspecific scheme))
     845             (let ((prefix ""))
     846               (when (not-unspecific port)
     847                 (setf prefix (format nil ":~D" port)))
     848               (when (and (not-unspecific host) (plusp (length host)))
     849                 (setf prefix (concatenate 'string host prefix)))
     850               (setf prefix (concatenate 'string ":" prefix))
     851               (when (not-unspecific scheme)
     852               (setf prefix (concatenate 'string scheme prefix)))
     853               (assert (and directory (eq (first directory) :absolute)))
     854               (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
     855                              :defaults pathname)))
     856            (t
     857             pathname)))))
    749858
    750859;;;; -------------------------------------------------------------------------
    … …  
    857966;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
    858967(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)))))
    866968   (when (find-class 'module nil)
    867969     (eval
    … …  
    870972         (declare (ignorable deleted plist))
    871973         (when (or *asdf-verbose* *load-verbose*)
    872            (asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version)))
     974           (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
     975                         m ,(asdf-version)))
    873976         (when (member 'components-by-name added)
    874977           (compute-module-components-by-name m))
    … …  
    8981001                error-component error-operation
    8991002                module-components module-components-by-name
    900                 circular-dependency-components)
     1003                circular-dependency-components
     1004                condition-arguments condition-form
     1005                condition-format condition-location
     1006                coerce-name)
    9011007         (ftype (function (t t) t) (setf module-components-by-name)))
    9021008
    … …  
    9061012   (format-arguments :initarg :format-arguments :reader format-arguments))
    9071013  (:report (lambda (c s)
    908              (apply #'format s (format-control c) (format-arguments c)))))
     1014               (apply #'format s (format-control c) (format-arguments c)))))
    9091015
    9101016(define-condition load-system-definition-error (system-definition-error)
    … …  
    9131019   (condition :initarg :condition :reader error-condition))
    9141020  (: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)))))
     1021             (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
     1022                     (error-name c) (error-pathname c) (error-condition c)))))
    9171023
    9181024(define-condition circular-dependency (system-definition-error)
    9191025  ((components :initarg :components :reader circular-dependency-components))
    9201026  (:report (lambda (c s)
    921              (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
     1027             (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
     1028                     (circular-dependency-components c)))))
    9221029
    9231030(define-condition duplicate-names (system-definition-error)
    9241031  ((name :initarg :name :reader duplicate-names-name))
    9251032  (:report (lambda (c s)
    926              (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
    927                      (duplicate-names-name c)))))
     1033             (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
     1034                     (duplicate-names-name c)))))
    9281035
    9291036(define-condition missing-component (system-definition-error)
    … …  
    9451052   (operation :reader error-operation :initarg :operation))
    9461053  (:report (lambda (c s)
    947              (format s "~@<erred while invoking ~A on ~A~@:>"
    948                      (error-operation c) (error-component c)))))
     1054               (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
     1055                       (error-operation c) (error-component c)))))
    9491056(define-condition compile-error (operation-error) ())
    9501057(define-condition compile-failed (compile-error) ())
    … …  
    9571064   (arguments :reader condition-arguments :initarg :arguments :initform nil))
    9581065  (: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))))))
     1066               (format s (compatfmt "~@<~? (will be skipped)~@:>")
     1067                       (condition-format c)
     1068                       (list* (condition-form c) (condition-location c)
     1069                              (condition-arguments c))))))
    9631070(define-condition invalid-source-registry (invalid-configuration warning)
    964   ((format :initform "~@<invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~>")))
     1071  ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    9651072(define-condition invalid-output-translation (invalid-configuration warning)
    966   ((format :initform "~@<invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~>")))
     1073  ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    9671074
    9681075(defclass component ()
    … …  
    9701077         "Component name: designator for a string composed of portable pathname characters")
    9711078   (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
     1079   (description :accessor component-description :initarg :description)
     1080   (long-description :accessor component-long-description :initarg :long-description)
     1081   ;; This one below is used by POIU - http://www.cliki.net/poiu
     1082   ;; a parallelizing extension of ASDF that compiles in multiple parallel
     1083   ;; slave processes (forked on demand) and loads in the master process.
     1084   ;; Maybe in the future ASDF may use it internally instead of in-order-to.
    9751085   (load-dependencies :accessor component-load-dependencies :initform nil)
    9761086   ;; In the ASDF object model, dependencies exist between *actions*
    … …  
    9911101   ;; hasn't yet been loaded in the current image (do-first).
    9921102   ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
     1103   ;; See our ASDF 2 paper for more complete explanations.
    9931104   (in-order-to :initform nil :initarg :in-order-to
    9941105                :accessor component-in-order-to)
    … …  
    10181129(defmethod print-object ((c component) stream)
    10191130  (print-unreadable-object (c stream :type t :identity nil)
    1020     (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
     1131    (format stream "~{~S~^ ~}" (component-find-path c))))
    10211132
    10221133
    … …  
    10241135
    10251136(defmethod print-object ((c missing-dependency) s)
    1026   (format s "~@<~A, required by ~A~@:>"
     1137  (format s (compatfmt "~@<~A, required by ~A~@:>")
    10271138          (call-next-method c nil) (missing-required-by c)))
    10281139
    … …  
    10341145
    10351146(defmethod print-object ((c missing-component) s)
    1036   (format s "~@<component ~S not found~@[ in ~A~]~@:>"
     1147  (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
    10371148          (missing-requires c)
    10381149          (when (missing-parent c)
    … …  
    10401151
    10411152(defmethod print-object ((c missing-component-of-version) s)
    1042   (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
     1153  (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
    10431154          (missing-requires c)
    10441155          (missing-version c)
    … …  
    11001211             (pathname-directory-pathname (component-parent-pathname component)))))
    11011212        (unless (or (null pathname) (absolute-pathname-p pathname))
    1102           (error "Invalid relative pathname ~S for component ~S"
     1213          (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
    11031214                 pathname (component-find-path component)))
    11041215        (setf (slot-value component 'absolute-pathname) pathname)
    … …  
    11171228
    11181229(defclass system (module)
    1119   ((description :accessor system-description :initarg :description)
    1120    (long-description
    1121     :accessor system-long-description :initarg :long-description)
     1230  (;; description and long-description are now available for all component's,
     1231   ;; but now also inherited from component, but we add the legacy accessor
     1232   (description :accessor system-description :initarg :description)
     1233   (long-description :accessor system-long-description :initarg :long-description)
    11221234   (author :accessor system-author :initarg :author)
    11231235   (maintainer :accessor system-maintainer :initarg :maintainer)
    … …  
    11681280    (symbol (string-downcase (symbol-name name)))
    11691281    (string name)
    1170     (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
     1282    (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
    11711283
    11721284(defun* system-registered-p (name)
    … …  
    11861298FN should be a function of one argument. It will be
    11871299called with an object of type asdf:system."
    1188   (maphash (lambda (_ datum)
    1189              (declare (ignore _))
    1190              (destructuring-bind (_ . def) datum
     1300  (maphash #'(lambda (_ datum)
    11911301               (declare (ignore _))
    1192                (funcall fn def)))
     1302               (destructuring-bind (_ . def) datum
     1303                 (declare (ignore _))
     1304                 (funcall fn def)))
    11931305           *defined-systems*))
    11941306
    … …  
    12021314  (let ((system-name (coerce-name system)))
    12031315    (or
    1204      (some (lambda (x) (funcall x system-name))
     1316     (some #'(lambda (x) (funcall x system-name))
    12051317           *system-definition-search-functions*)
    12061318     (let ((system-pair (system-registered-p system-name)))
    … …  
    12311343              :name name
    12321344              :type "asd")))
    1233         (when (probe-file file)
     1345        (when (probe-file* file)
    12341346          (return file)))
    1235       #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     1347      #+(and asdf-windows (not clisp))
    12361348      (let ((shortcut
    12371349             (make-pathname
    … …  
    12391351              :name (concatenate 'string name ".asd")
    12401352              :type "lnk")))
    1241         (when (probe-file shortcut)
     1353        (when (probe-file* shortcut)
    12421354          (let ((target (parse-windows-shortcut shortcut)))
    12431355            (when target
    … …  
    12621374                                   (message
    12631375                                    (format nil
    1264                                             "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
     1376                                            (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
    12651377                                            system dir defaults)))
    12661378                              (error message))
    … …  
    12701382                          (coerce-entry-to-directory ()
    12711383                            :report (lambda (s)
    1272                                       (format s "Coerce entry to ~a, replace ~a and continue."
    1273                                               (ensure-directory-pathname defaults) dir))
     1384                                      (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
     1385                                              (ensure-directory-pathname defaults) dir))
    12741386                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
    12751387        ;; cleanup
    … …  
    13031415  ;; as if the file were very old.
    13041416  ;; (or should we treat the case in a different, special way?)
    1305   (or (and pathname (probe-file pathname) (file-write-date pathname))
     1417  (or (and pathname (probe-file* pathname) (file-write-date pathname))
    13061418      (progn
    13071419        (when (and pathname *asdf-verbose*)
    1308           (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
     1420          (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
    13091421                pathname))
    13101422        0)))
    … …  
    13181430    (unwind-protect
    13191431         (handler-bind
    1320              ((error (lambda (condition)
    1321                        (error 'load-system-definition-error
    1322                               :name name :pathname pathname
    1323                               :condition condition))))
     1432             ((error #'(lambda (condition)
     1433                         (error 'load-system-definition-error
     1434                                :name name :pathname pathname
     1435                                :condition condition))))
    13241436           (let ((*package* package))
    1325              (asdf-message
    1326               "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
    1327               pathname package)
     1437             (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
     1438                           pathname package)
    13281439             (load pathname)))
    13291440      (delete-package package))))
    … …  
    13501461
    13511462(defun* register-system (name system)
    1352   (asdf-message "~&~@<; ~@;Registering ~A as ~A~@:>~%" system name)
    1353   (setf (gethash (coerce-name name) *defined-systems*)
    1354         (cons (get-universal-time) system)))
     1463  (setf name (coerce-name name))
     1464  (assert (equal name (component-name system)))
     1465  (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
     1466  (setf (gethash name *defined-systems*) (cons (get-universal-time) system)))
    13551467
    13561468(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
    … …  
    14281540  (source-file-explicit-type component))
    14291541
    1430 (defun* merge-component-name-type (name &key type defaults)
     1542(defun* coerce-pathname (name &key type defaults)
     1543  "coerce NAME into a PATHNAME.
     1544When given a string, portably decompose it into a relative pathname:
     1545#\\/ separates subdirectories. The last #\\/-separated string is as follows:
     1546if TYPE is NIL, its last #\\. if any separates name and type from from type;
     1547if TYPE is a string, it is the type, and the whole string is the name;
     1548if TYPE is :DIRECTORY, the string is a directory component;
     1549if the string is empty, it's a directory.
     1550Any directory named .. is read as :BACK.
     1551Host, device and version components are taken from DEFAULTS."
    14311552  ;; The defaults are required notably because they provide the default host
    14321553  ;; to the below make-pathname, which may crucially matter to people using
    14331554  ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
    14341555  ;; NOTE that the host and device slots will be taken from the defaults,
    1435   ;; but that should only matter if you either (a) use absolute pathnames, or
    1436   ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
    1437   ;; ASDF:MERGE-PATHNAMES*
     1556  ;; but that should only matter if you later merge relative pathnames with
     1557  ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
    14381558  (etypecase name
    1439     (pathname
     1559    ((or null pathname)
    14401560     name)
    14411561    (symbol
    1442      (merge-component-name-type (string-downcase name) :type type :defaults defaults))
     1562     (coerce-pathname (string-downcase name) :type type :defaults defaults))
    14431563    (string
    14441564     (multiple-value-bind (relative path filename)
    … …  
    14531573             (t
    14541574              (split-name-type filename)))
    1455          (let* ((defaults (pathname (or defaults *default-pathname-defaults*)))
    1456                 (host (pathname-host defaults))
    1457                 (device (pathname-device defaults)))
    1458            (make-pathname :directory `(,relative ,@path)
    1459                           :name name :type type
    1460                           :host host :device device)))))))
     1575         (make-pathname :directory `(,relative ,@path) :name name :type type
     1576                        :defaults (or defaults *default-pathname-defaults*)))))))
     1577
     1578(defun* merge-component-name-type (name &key type defaults)
     1579  ;; For backwards compatibility only, for people using internals.
     1580  ;; Will be removed in a future release, e.g. 2.014.
     1581  (coerce-pathname name :type type :defaults defaults))
    14611582
    14621583(defmethod component-relative-pathname ((component component))
    1463   (merge-component-name-type
     1584  (coerce-pathname
    14641585   (or (slot-value component 'relative-pathname)
    14651586       (component-name component))
    … …  
    15691690(defmethod component-self-dependencies ((o operation) (c component))
    15701691  (let ((all-deps (component-depends-on o c)))
    1571     (remove-if-not (lambda (x)
    1572                      (member (component-name c) (cdr x) :test #'string=))
     1692    (remove-if-not #'(lambda (x)
     1693                       (member (component-name c) (cdr x) :test #'string=))
    15731694                   all-deps)))
    15741695
    … …  
    15771698        (self-deps (component-self-dependencies operation c)))
    15781699    (if self-deps
    1579         (mapcan (lambda (dep)
    1580                   (destructuring-bind (op name) dep
    1581                     (output-files (make-instance op)
    1582                                   (find-component parent name))))
     1700        (mapcan #'(lambda (dep)
     1701                    (destructuring-bind (op name) dep
     1702                      (output-files (make-instance op)
     1703                                    (find-component parent name))))
    15831704                self-deps)
    15841705        ;; no previous operations needed?  I guess we work with the
    … …  
    16341755         ;; second). So that's cool.
    16351756         (and
    1636           (every #'probe-file in-files)
    1637           (every #'probe-file out-files)
     1757          (every #'probe-file* in-files)
     1758          (every #'probe-file* out-files)
    16381759          (>= (earliest-out) (latest-in))))))))
    16391760
    … …  
    16821803      (retry ()
    16831804        :report (lambda (s)
    1684                   (format s "~@<Retry loading component ~S.~@:>" required-c))
     1805                  (format s "~@<Retry loading component ~3i~_~S.~@:>" required-c))
    16851806        :test
    16861807        (lambda (c)
    1687           (or (null c)
    1688               (and (typep c 'missing-dependency)
    1689                    (equalp (missing-requires c)
    1690                            required-c))))))))
     1808          (or (null c)
     1809              (and (typep c 'missing-dependency)
     1810                   (equalp (missing-requires c)
     1811                           required-c))))))))
    16911812
    16921813(defun* do-dep (operation c collect op dep)
    … …  
    17261847                            (dep op (third d) nil)))
    17271848                         (t
    1728                           (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
     1849                          (error (compatfmt "~@<Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name.~@:>") d))))))
    17291850           flag))))
    17301851
    … …  
    18511972(defmethod perform ((operation operation) (c source-file))
    18521973  (sysdef-error
    1853    "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
     1974   (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
    18541975   (class-of operation) (class-of c)))
    18551976
    … …  
    18621983
    18631984(defmethod operation-description (operation component)
    1864   (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
     1985  (format nil (compatfmt "~@<~A on component ~S~@:>")
     1986          (class-of operation) (component-find-path component)))
    18651987
    18661988;;;; -------------------------------------------------------------------------
    … …  
    18741996               :initform *compile-file-failure-behaviour*)
    18751997   (flags :initarg :flags :accessor compile-op-flags
    1876           :initform #-ecl nil #+ecl '(:system-p t))))
     1998          :initform nil)))
    18771999
    18782000(defun output-file (operation component)
    … …  
    18832005
    18842006(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))))
     2007   (loop :for file :in (asdf:output-files operation c)
     2008     :for pathname = (if (typep file 'logical-pathname)
     2009                         (translate-logical-pathname file)
     2010                         file)
     2011     :do (ensure-directories-exist pathname)))
    18952012
    18962013(defmethod perform :after ((operation operation) (c component))
    … …  
    18982015        (get-universal-time)))
    18992016
    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*))
     2017(defvar *compile-op-compile-file-function* 'compile-file*
     2018  "Function used to compile lisp files.")
    19042019
    19052020;;; perform is required to check output-files to find out where to put
    … …  
    19142029        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    19152030    (multiple-value-bind (output warnings-p failure-p)
    1916         (apply #'compile-file* source-file :output-file output-file
     2031        (apply *compile-op-compile-file-function* source-file :output-file output-file
    19172032               (compile-op-flags operation))
    19182033      (when warnings-p
    19192034        (case (operation-on-warnings operation)
    19202035          (:warn (warn
    1921                   "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
     2036                  (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
    19222037                  operation c))
    19232038          (:error (error 'compile-warned :component c :operation operation))
    … …  
    19262041        (case (operation-on-failure operation)
    19272042          (:warn (warn
    1928                   "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
     2043                  (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
    19292044                  operation c))
    19302045          (:error (error 'compile-failed :component c :operation operation))
    … …  
    19362051  (declare (ignorable operation))
    19372052  (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)))
     2053    #-broken-fasl-loader (list (compile-file-pathname p))
     2054    #+broken-fasl-loader (list p)))
    19422055
    19432056(defmethod perform ((operation compile-op) (c static-file))
    … …  
    19652078
    19662079(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)))))
     2080  (map () #'load (input-files o c)))
    19722081
    19732082(defmethod perform-with-restarts (operation component)
    … …  
    20342143(defmethod operation-description ((operation load-op) component)
    20352144  (declare (ignorable operation))
    2036   (format nil "loading component ~S" (component-find-path component)))
     2145  (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
     2146          (component-find-path component)))
    20372147
    20382148
    … …  
    20622172  (let ((what-would-load-op-do (cdr (assoc 'load-op
    20632173                                           (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))
     2174    (mapcar #'(lambda (dep)
     2175                (if (eq (car dep) 'load-op)
     2176                    (cons 'load-source-op (cdr dep))
     2177                    dep))
    20682178            what-would-load-op-do)))
    20692179
    … …  
    20772187(defmethod operation-description ((operation load-source-op) component)
    20782188  (declare (ignorable operation))
    2079   (format nil "loading component ~S" (component-find-path component)))
     2189  (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
     2190          (component-find-path component)))
    20802191
    20812192
    … …  
    21282239                :report
    21292240                (lambda (s)
    2130                   (format s "~@<Retry ~A.~@:>" (operation-description op component))))
     2241                  (format s (compatfmt "~@<Retry ~A.~@:>")
     2242                          (operation-description op component))))
    21312243              (accept ()
    21322244                :report
    21332245                (lambda (s)
    2134                   (format s "~@<Continue, treating ~A as having been successful.~@:>"
    2135                           (operation-description op component)))
     2246                  (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
     2247                          (operation-description op component)))
    21362248                (setf (gethash (type-of op)
    21372249                               (component-operation-times component))
    … …  
    22112323  (let* ((file-pathname (load-pathname))
    22122324         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
    2213     (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
     2325    (or (and pathname-supplied-p
     2326             (merge-pathnames* (coerce-pathname pathname :type :directory)
     2327                               directory-pathname))
    22142328        directory-pathname
    22152329        (default-directory))))
    22162330
    22172331(defmacro defsystem (name &body options)
     2332  (setf name (coerce-name name))
    22182333  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
    22192334                            defsystem-depends-on &allow-other-keys)
    … …  
    22252340         ;; to reuse options (e.g. pathname) from
    22262341         ,@(loop :for system :in defsystem-depends-on
    2227              :collect `(load-system ,system))
     2342             :collect `(load-system ',(coerce-name system)))
    22282343         (let ((s (system-registered-p ',name)))
    22292344           (cond ((and s (eq (type-of (cdr s)) ',class))
    … …  
    22542369           (or (module-default-component-class parent)
    22552370               (find-class *default-component-class*)))
    2256       (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
     2371      (sysdef-error "don't recognize component type ~A" type)))
    22572372
    22582373(defun* maybe-add-tree (tree op1 op2 c)
    … …  
    22862401(defun* sysdef-error-component (msg type name value)
    22872402  (sysdef-error (concatenate 'string msg
    2288                              "~&The value specified for ~(~A~) ~A is ~S")
     2403                             (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
    22892404                type name value))
    22902405
    … …  
    23112426         ;; methods will not be for this particular gf
    23122427         ;; But this is hardly performance-critical
    2313          (lambda (m)
    2314            (remove-method (symbol-function name) m))
     2428         #'(lambda (m)
     2429             (remove-method (symbol-function name) m))
    23152430         (component-inline-methods component)))
    23162431  ;; clear methods, then add the new ones
    … …  
    25132628(defun* system-relative-pathname (system name &key type)
    25142629  (merge-pathnames*
    2515    (merge-component-name-type name :type type)
     2630   (coerce-pathname name :type type)
    25162631   (system-source-directory system)))
    25172632
    … …  
    25242639
    25252640(defparameter *implementation-features*
    2526   '((:acl :allegro)
    2527     (:lw :lispworks)
    2528     (:digitool) ; before clozure, so it won't get preempted by ccl
     2641  '((:abcl :armedbear)
     2642    (:acl :allegro)
     2643    (:mcl :digitool) ; before clozure, so it won't get preempted by ccl
    25292644    (:ccl :clozure)
    25302645    (:corman :cormanlisp)
    2531     (:abcl :armedbear)
    2532     :sbcl :cmu :clisp :gcl :ecl :scl))
     2646    (:lw :lispworks)
     2647    :clisp :cmu :ecl :gcl :sbcl :scl :symbolics))
    25332648
    25342649(defparameter *os-features*
    … …  
    25382653    (:macosx :darwin :darwin-target :apple)
    25392654    :freebsd :netbsd :openbsd :bsd
    2540     :unix))
     2655    :unix
     2656    :genera))
    25412657
    25422658(defparameter *architecture-features*
    … …  
    25502666    (:sparc32 :sparc)
    25512667    (:arm :arm-target)
    2552     (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
     2668    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
     2669    :imach))
    25532670
    25542671(defun* lisp-version-string ()
    … …  
    25682685                      (if (member :64bit *features*) "-64bit" ""))
    25692686    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    2570     #+clisp (subseq s 0 (position #\space s))
     2687    #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
    25712688    #+clozure (format nil "~d.~d-f~d" ; shorten for windows
    25722689                      ccl::*openmcl-major-version*
    … …  
    25742691                      (logand ccl::fasl-version #xFF))
    25752692    #+cmu (substitute #\- #\/ s)
    2576     #+digitool (subseq s 8)
    25772693    #+ecl (format nil "~A~@[-~A~]" s
    25782694                  (let ((vcs-id (ext:lisp-implementation-vcs-id)))
    … …  
    25802696                      (subseq vcs-id 0 8))))
    25812697    #+gcl (subseq s (1+ (position #\space s)))
     2698    #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
     2699               (format nil "~D.~D" major minor))
    25822700    #+lispworks (format nil "~A~@[~A~]" s
    25832701                        (when (member :lispworks-64bit *features*) "-64bit"))
    25842702    ;; #+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))
     2703    #+mcl (subseq s 8) ; strip the leading "Version "
     2704    #+(or cormanlisp sbcl scl) s
     2705    #-(or allegro armedbear clisp clozure cmu cormanlisp
     2706          ecl gcl genera lispworks mcl sbcl scl) s))
    25882707
    25892708(defun* first-feature (features)
    … …  
    26132732                  "unknown"))))
    26142733    (let ((lisp (maybe-warn (implementation-type)
    2615                             "No implementation feature found in ~a."
     2734                            (compatfmt "~@<No implementation feature found in ~a.~@:>")
    26162735                            *implementation-features*))
    26172736          (os   (maybe-warn (first-feature *os-features*)
    2618                             "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*))
     2737                            (compatfmt "~@<No OS feature found in ~a.~@:>") *os-features*))
     2738          (arch (or #-clisp
     2739                    (maybe-warn (first-feature *architecture-features*)
     2740                                (compatfmt "~@<No architecture feature found in ~a.~@:>")
     2741                                *architecture-features*)))
    26232742          (version (maybe-warn (lisp-version-string)
    26242743                               "Don't know how to get Lisp implementation version.")))
    26252744      (substitute-if
    2626        #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
    2627        (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
     2745       #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))
     2746       (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))
    26282747
    26292748
    … …  
    26322751
    26332752(defparameter *inter-directory-separator*
    2634   #+(or unix cygwin) #\:
    2635   #-(or unix cygwin) #\;)
     2753  #+asdf-unix #\:
     2754  #-asdf-unix #\;)
    26362755
    26372756(defun* user-homedir ()
    2638   (truename (user-homedir-pathname)))
     2757  (truenamize (pathname-directory-pathname (user-homedir-pathname))))
    26392758
    26402759(defun* try-directory-subpath (x sub &key type)
    26412760  (let* ((p (and x (ensure-directory-pathname x)))
    26422761         (tp (and p (probe-file* p)))
    2643          (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
     2762         (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))
    26442763         (ts (and sp (probe-file* sp))))
    26452764    (and ts (values sp ts))))
    … …  
    26522771           :for dir :in (split-string dirs :separator ":")
    26532772           :collect (try dir "common-lisp/"))
    2654        #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2773       #+asdf-windows
    26552774        ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
    26562775            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    … …  
    26612780   #'null
    26622781   (append
    2663     #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2782    #+asdf-windows
    26642783    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    26652784      `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
    26662785           ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    26672786        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
     2787    #+asdf-unix
    26682788    (list #p"/etc/common-lisp/"))))
    26692789(defun* in-first-directory (dirs x)
    … …  
    27182838    (unless (= inherit 1)
    27192839      (report-invalid-form invalid-form-reporter
    2720              :arguments (list "One and only one of ~S or ~S is required"
     2840             :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
    27212841                              :inherit-configuration :ignore-inherited-configuration)))
    27222842    (return (nreverse x))))
    … …  
    27252845  (let ((forms (read-file-forms file)))
    27262846    (unless (length=n-p forms 1)
    2727       (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
     2847      (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
     2848             description forms))
    27282849    (funcall validator (car forms) :location file)))
    27292850
    … …  
    27342855  (apply 'directory pathname-spec
    27352856         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
    2736                              #+ccl '(:follow-links nil)
     2857                             #+clozure '(:follow-links nil)
    27372858                             #+clisp '(:circle t :if-does-not-exist :ignore)
    27382859                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
    … …  
    27822903    (or
    27832904     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
    2784      #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2905     #+asdf-windows
    27852906     (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
    27862907     '(:home ".cache" "common-lisp" :implementation))))
    … …  
    27972918        (list
    27982919         (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))))))))
     2920                      :key #'(lambda (x)
     2921                               (etypecase (car x)
     2922                                 ((eql t) -1)
     2923                                 (pathname
     2924                                  (let ((directory (pathname-directory (car x))))
     2925                                    (if (listp directory) (length directory) 0))))))))
    28052926  new-value)
    28062927
    … …  
    28412962              ((eql :implementation) (implementation-identifier))
    28422963              ((eql :implementation-type) (string-downcase (implementation-type)))
    2843               #-(and (or win32 windows mswindows mingw32) (not cygwin))
     2964              #+asdf-unix
    28442965              ((eql :uid) (princ-to-string (get-uid)))))
    28452966         (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
    28462967         (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
    28472968    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
    2848       (error "pathname ~S is not relative to ~S" s super))
     2969      (error (compatfmt "~@<Pathname ~S is not relative to ~S~@:>") s super))
    28492970    (merge-pathnames* s super)))
    28502971
    … …  
    28883009                r)))
    28893010    (unless (absolute-pathname-p s)
    2890       (error "Not an absolute pathname ~S" s))
     3011      (error (compatfmt "~@<Not an absolute pathname: ~3i~_~S~@:>") s))
    28913012    s))
    28923013
    … …  
    29123033                      (member :default-directory :*/ :**/ :*.*.*
    29133034                        :implementation :implementation-type
    2914                         #-(and (or win32 windows mswindows mingw32) (not cygwin)) :uid)))))
     3035                        #+asdf-unix :uid)))))
    29153036    (or (typep x 'boolean)
    29163037        (absolute-component-p x)
    … …  
    29603081     '(:output-translations :inherit-configuration))
    29613082    ((not (stringp string))
    2962      (error "environment string isn't: ~S" string))
     3083     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
    29633084    ((eql (char string 0) #\")
    29643085     (parse-output-translations-string (read-from-string string) :location location))
    … …  
    29803101          ((equal "" s)
    29813102           (when inherit
    2982              (error "only one inherited configuration allowed: ~S" string))
     3103             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     3104                    string))
    29833105           (setf inherit t)
    29843106           (push :inherit-configuration directives))
    … …  
    29883110        (when (> start end)
    29893111          (when source
    2990             (error "Uneven number of components in source to destination mapping ~S" string))
     3112            (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
     3113                   string))
    29913114          (unless inherit
    29923115            (push :ignore-inherited-configuration directives))
    … …  
    30043127    ;; Some implementations have precompiled ASDF systems,
    30053128    ;; so we must disable translations for implementation paths.
    3006     #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
     3129    #+sbcl ,(let ((h (getenv "SBCL_HOME")))
     3130                 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
    30073131    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
    30083132    #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
    … …  
    30153139    :enable-user-cache))
    30163140
    3017 (defparameter *output-translations-file* #p"asdf-output-translations.conf")
    3018 (defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
     3141(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
     3142(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
    30193143
    30203144(defun* user-output-translations-pathname ()
    … …  
    30443168     (process-output-translations (validate-output-translations-directory pathname)
    30453169                                  :inherit inherit :collect collect))
    3046     ((probe-file pathname)
     3170    ((probe-file* pathname)
    30473171     (process-output-translations (validate-output-translations-file pathname)
    30483172                                  :inherit inherit :collect collect))
    … …  
    31073231   :test 'equal :from-end t))
    31083232
    3109 (defun* initialize-output-translations (&optional parameter)
     3233(defvar *output-translations-parameter* nil)
     3234
     3235(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
    31103236  "read the configuration, initialize the internal configuration variable,
    31113237return the configuration"
    3112   (setf (output-translations) (compute-output-translations parameter)))
     3238  (setf *output-translations-parameter* parameter
     3239        (output-translations) (compute-output-translations parameter)))
    31133240
    31143241(defun* disable-output-translations ()
    … …  
    31353262     path)
    31363263    ((not (pathnamep destination))
    3137      (error "invalid destination"))
     3264     (error "Invalid destination"))
    31383265    ((not (absolute-pathname-p destination))
    31393266     (translate-pathname path absolute-source (merge-pathnames* destination root)))
    … …  
    31863313
    31873314(defun* delete-file-if-exists (x)
    3188   (when (and x (probe-file x))
     3315  (when (and x (probe-file* x))
    31893316    (delete-file x)))
    31903317
    … …  
    32793406;;;; http://www.wotsit.org/list.asp?fc=13
    32803407
    3281 #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     3408#+(and asdf-windows (not clisp))
    32823409(progn
    32833410(defparameter *link-initial-dword* 76)
    … …  
    33893516(defun directory-has-asd-files-p (directory)
    33903517  (ignore-errors
    3391     (directory* (merge-pathnames* *wild-asd* directory))
    3392     t))
     3518    (and (directory* (merge-pathnames* *wild-asd* directory)) t)))
    33933519
    33943520(defun subdirectories (directory)
    33953521  (let* ((directory (ensure-directory-pathname directory))
    3396          #-cormanlisp
     3522         #-(or cormanlisp genera)
    33973523         (wild (merge-pathnames*
    33983524                #-(or abcl allegro lispworks scl)
    … …  
    34013527                directory))
    34023528         (dirs
    3403           #-cormanlisp
     3529          #-(or cormanlisp genera)
    34043530          (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)
     3531            (directory* wild . #.(or #+clozure '(:directories t :files nil)
     3532                                     #+mcl '(:directories t))))
     3533          #+cormanlisp (cl::directory-subdirs directory)
     3534          #+genera (fs:directory-list directory))
     3535         #+(or abcl allegro genera lispworks scl)
    34093536         (dirs (remove-if-not #+abcl #'extensions:probe-directory
    34103537                              #+allegro #'excl:probe-directory
    34113538                              #+lispworks #'lw:file-directory-p
    3412                               #-(or abcl allegro lispworks) #'directory-pathname-p
    3413                               dirs)))
     3539                              #+genera #'(lambda (x) (getf (cdr x) :directory))
     3540                              #-(or abcl allegro genera lispworks) #'directory-pathname-p
     3541                              dirs))
     3542         #+genera
     3543         (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs)))
    34143544    dirs))
    34153545
    … …  
    34633593     '(:source-registry :inherit-configuration))
    34643594    ((not (stringp string))
    3465      (error "environment string isn't: ~S" string))
     3595     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
    34663596    ((find (char string 0) "\"(")
    34673597     (validate-source-registry-form (read-from-string string) :location location))
    … …  
    34773607         ((equal "" s) ; empty element: inherit
    34783608          (when inherit
    3479             (error "only one inherited configuration allowed: ~S" string))
     3609            (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     3610                   string))
    34803611          (setf inherit t)
    34813612          (push ':inherit-configuration directives))
    … …  
    35063637    default-source-registry))
    35073638
    3508 (defparameter *source-registry-file* #p"source-registry.conf")
    3509 (defparameter *source-registry-directory* #p"source-registry.conf.d/")
     3639(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
     3640(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
    35103641
    35113642(defun* wrapping-source-registry ()
    35123643  `(:source-registry
    3513     #+sbcl (:tree ,(getenv "SBCL_HOME"))
     3644    #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
    35143645    :inherit-configuration
    35153646    #+cmu (:tree #p"modules:")))
    … …  
    35183649    `(:source-registry
    35193650      #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
    3520       (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
     3651      (:directory ,(default-directory))
    35213652      ,@(let*
    3522          #+(or unix cygwin)
     3653         #+asdf-unix
    35233654         ((datahome
    35243655           (or (getenv "XDG_DATA_HOME")
    … …  
    35273658           (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
    35283659          (dirs (cons datahome (split-string datadirs :separator ":"))))
    3529          #+(and (or win32 windows mswindows mingw32) (not cygwin))
     3660         #+asdf-windows
    35303661         ((datahome (getenv "APPDATA"))
    35313662          (datadir
    … …  
    35343665                            "Application Data"))
    35353666          (dirs (list datahome datadir)))
    3536          #-(or unix win32 windows mswindows mingw32 cygwin)
     3667         #-(or asdf-unix asdf-windows)
    35373668         ((dirs ()))
    35383669         (loop :for dir :in dirs
    … …  
    35653696       (process-source-registry (validate-source-registry-directory pathname)
    35663697                                :inherit inherit :register register)))
    3567     ((probe-file pathname)
     3698    ((probe-file* pathname)
    35683699     (let ((*here-directory* (pathname-directory-pathname pathname)))
    35693700       (process-source-registry (validate-source-registry-file pathname)
    … …  
    36213752          ,parameter
    36223753          ,@*default-source-registries*)
    3623         :register (lambda (directory &key recurse exclude)
    3624                     (collect (list directory :recurse recurse :exclude exclude)))))
     3754        :register #'(lambda (directory &key recurse exclude)
     3755                      (collect (list directory :recurse recurse :exclude exclude)))))
    36253756     :test 'equal :from-end t)))
    36263757
    … …  
    36353766         :recurse recurse :exclude exclude :collect #'collect)))))
    36363767
    3637 (defun* initialize-source-registry (&optional parameter)
    3638   (setf (source-registry) (compute-source-registry parameter)))
     3768(defvar *source-registry-parameter* nil)
     3769
     3770(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
     3771  (setf *source-registry-parameter* parameter
     3772        (source-registry) (compute-source-registry parameter)))
    36393773
    36403774;; Checks an initial variable to see whether the state is initialized
    … …  
    36693803      ((style-warning #'muffle-warning)
    36703804       (missing-component (constantly nil))
    3671        (error (lambda (e)
    3672                 (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
    3673                         name e))))
    3674     (let* ((*verbose-out* (make-broadcast-stream))
     3805       (error #'(lambda (e)
     3806                  (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
     3807                          name e))))
     3808    (let ((*verbose-out* (make-broadcast-stream))
    36753809           (system (find-system (string-downcase name) nil)))
    36763810      (when system
    3677         (load-system system)
    3678         t))))
     3811        (load-system system)))))
    36793812
    36803813#+(or abcl clisp clozure cmu ecl sbcl)
    … …  
    36953828;;;; See https://bugs.launchpad.net/asdf/+bug/485687
    36963829;;;;
    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))))))
    37083830
    37093831;;; If a previous version of ASDF failed to read some configuration, try again.
Note: See TracChangeset for help on using the changeset viewer.