Changeset 14687


Ignore:
Timestamp:
Mar 21, 2011, 3:56:28 PM (9 years ago)
Author:
rme
Message:

ASDF 2.013 from upstream.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/tools/asdf.lisp

    r14554 r14687  
    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.