Changeset 14688


Ignore:
Timestamp:
Mar 21, 2011, 8:25:16 PM (9 years ago)
Author:
rme
Message:

Revert r14687. The ASDF dust seems not to have settled yet.

File:
1 edited

Legend:

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

    r14687 r14688  
    1 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.013: Another System Definition Facility.
     1;;; -*- mode: common-lisp; package: asdf; -*-
     2;;; This is ASDF: 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 master
    14 ;;; branch is the latest development version, whereas the git release
    15 ;;; branch may be slightly older but is considered `stable'
     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'
    1616
    1717;;; -- LICENSE START
     
    4848#+xcvb (module ())
    4949
    50 (cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
     50(cl:in-package :cl-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 '(:common-lisp)))
     58    (make-package :asdf :use '(:cl)))
    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   #+(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*))
     65  #+ecl (require :cmp))
    6866
    6967(in-package :asdf)
     
    7977         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
    8078         ;; 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.
    8279         ;; "2.345" would be an official release
    8380         ;; "2.345.6" would be a development version in the official upstream
    8481         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    8582         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    86          (asdf-version "2.013")
     83         (asdf-version "2.012")
    8784         (existing-asdf (fboundp 'find-system))
    8885         (existing-version *asdf-version*)
     
    9188      (when existing-asdf
    9289        (format *trace-output*
    93          "~&; Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
     90         "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%"
    9491         existing-version asdf-version))
    9592      (labels
    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)
     93          ((unlink-package (package)
    10594             (let ((u (find-package package)))
    10695               (when u
    107                  (ensure-unintern u (present-symbols u))
     96                 (ensure-unintern u
     97                   (loop :for s :being :each :present-symbol :in u :collect s))
    10898                 (loop :for p :in (package-used-by-list u) :do
    10999                   (unuse-package u p))
     
    159149                   (bothly-exported-symbols nil)
    160150                   (newly-exported-symbols nil))
    161                (do-external-symbols (sym package)
     151               (loop :for sym :being :each :external-symbol :in package :do
    162152                 (if (member sym export :test 'string-equal)
    163153                     (push sym bothly-exported-symbols)
     
    197187            #:perform-with-restarts #:component-relative-pathname
    198188            #:system-source-file #:operate #:find-component #:find-system
    199             #:apply-output-translations #:translate-pathname* #:resolve-location
    200             #:compile-file*)
     189            #:apply-output-translations #:translate-pathname* #:resolve-location)
    201190           :unintern
    202191           (#:*asdf-revision* #:around #:asdf-method-combination
     
    290279
    291280            #:clear-configuration
    292             #:*output-translations-parameter*
    293281            #:initialize-output-translations
    294282            #:disable-output-translations
     
    300288            #:enable-asdf-binary-locations-compatibility
    301289            #:*default-source-registries*
    302             #:*source-registry-parameter*
    303290            #:initialize-source-registry
    304291            #:compute-source-registry
     
    322309            ;; #:find-symbol*
    323310            #:merge-pathnames*
    324             #:coerce-pathname
    325311            #:pathname-directory-pathname
    326312            #:read-file-forms
     
    334320            #:truenamize
    335321            #:while-collecting)))
    336         #+genera (import 'scl:boolean :asdf)
    337322        (setf *asdf-version* asdf-version
    338323              *upgraded-p* (if existing-version
     
    346331  "Exported interface to the version of ASDF currently installed. A string.
    347332You can compare this string with e.g.:
    348 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.013\")."
     333(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
    349334  *asdf-version*)
    350335
     
    421406    (make-pathname :name nil :type nil :version nil :defaults pathname)))
    422407
    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 
    458408(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    459409  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
     
    464414  (let* ((specified (pathname specified))
    465415         (defaults (pathname defaults))
    466          (directory (normalize-pathname-directory-component (pathname-directory specified)))
     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))))
    467429         (name (or (pathname-name specified) (pathname-name defaults)))
    468430         (type (or (pathname-type specified) (pathname-type defaults)))
     
    474436      (multiple-value-bind (host device directory unspecific-handler)
    475437          (ecase (first directory)
     438            ((nil)
     439             (values (pathname-host defaults)
     440                     (pathname-device defaults)
     441                     (pathname-directory defaults)
     442                     (unspecific-handler defaults)))
    476443            ((:absolute)
    477444             (values (pathname-host specified)
     
    479446                     directory
    480447                     (unspecific-handler specified)))
    481             ((nil :relative)
     448            ((:relative)
    482449             (values (pathname-host defaults)
    483450                     (pathname-device defaults)
    484                      (merge-pathname-directory-components directory (pathname-directory defaults))
     451                     (if (pathname-directory defaults)
     452                         (append (pathname-directory defaults) (cdr directory))
     453                         directory)
    485454                     (unspecific-handler defaults))))
    486455        (make-pathname :host host :device device :directory directory
     
    489458                       :version (funcall unspecific-handler version))))))
    490459
    491 (defun* pathname-parent-directory-pathname (pathname)
    492   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    493 and 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 
    500460(define-modify-macro appendf (&rest args)
    501461  append "Append onto list") ;; only to be used on short lists.
     
    510470  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    511471
    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 
    518472(defun* asdf-message (format-string &rest format-args)
    519473  (declare (dynamic-extent format-args))
    520   (apply #'errfmt *verbose-out* format-string format-args))
     474  (apply #'format *verbose-out* format-string format-args))
    521475
    522476(defun* split-string (string &key max (separator '(#\Space #\Tab)))
     
    545499         ;; See CLHS make-pathname and 19.2.2.2.3.
    546500         ;; We only use it on implementations that support it.
    547          (or #+(or clozure gcl lispworks sbcl) :unspecific)))
     501         (or #+(or ccl gcl lispworks sbcl) :unspecific)))
    548502    (destructuring-bind (name &optional (type unspecific))
    549503        (split-string filename :max 2 :separator ".")
     
    582536                (values :relative nil))
    583537          (values :relative components))
    584       (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
    585       (setf components (substitute :back ".." components :test #'equal))
     538      (setf components (remove "" components :test #'equal))
    586539      (cond
    587540        ((equal last-comp "")
     
    603556    :append (list k v)))
    604557
    605 #+mcl
    606 (eval-when (:compile-toplevel :load-toplevel :execute)
    607   (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))
    608 
    609558(defun* getenv (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"))
     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))
    626568
    627569(defun* directory-pathname-p (pathname)
     
    661603                   :defaults pathspec))))
    662604
    663 #+genera
    664 (unless (fboundp 'ensure-directories-exist)
    665   (defun ensure-directories-exist (path)
    666     (fs:create-directories-recursively (pathname path))))
    667 
    668605(defun* absolute-pathname-p (pathspec)
    669606  (and (typep pathspec '(or pathname string))
     
    693630     :collect form)))
    694631
    695 #+asdf-unix
     632#-(and (or win32 windows mswindows mingw32) (not cygwin))
    696633(progn
    697634  #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
     
    733670   (pathname (unless (wild-pathname-p p)
    734671               #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
    735                      #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
    736                      '(ignore-errors (truename p)))))))
     672               #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
     673               '(ignore-errors (truename p)))))))
    737674
    738675(defun* truenamize (p)
    739676  "Resolve as much of a pathname as possible"
    740677  (block nil
    741     (when (typep p '(or null logical-pathname)) (return p))
     678    (when (typep p 'logical-pathname) (return p))
    742679    (let* ((p (merge-pathnames* p))
    743680           (directory (pathname-directory p)))
     
    771708(defun* resolve-symlinks (path)
    772709  #-allegro (truenamize path)
    773   #+allegro (if (typep path 'logical-pathname)
    774                 path
    775                 (excl:pathname-resolve-symbolic-links path)))
     710  #+allegro (excl:pathname-resolve-symbolic-links path))
    776711
    777712(defun* default-directory ()
     
    793728  (merge-pathnames* *wild-path* path))
    794729
    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 
    799730(defun* directorize-pathname-host-device (pathname)
    800731  (let* ((root (pathname-root pathname))
    801732         (wild-root (wilden root))
    802733         (absolute-pathname (merge-pathnames* pathname root))
    803          (separator (directory-separator-for-host root))
     734         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
     735         (separator (last-char (namestring foo)))
    804736         (root-namestring (namestring root))
    805737         (root-string
    806738          (substitute-if #\/
    807                          #'(lambda (x) (or (eql x #\:)
    808                                            (eql x separator)))
     739                         (lambda (x) (or (eql x #\:)
     740                                         (eql x separator)))
    809741                         root-namestring)))
    810742    (multiple-value-bind (relative path filename)
     
    925857;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
    926858(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)))))
    927866   (when (find-class 'module nil)
    928867     (eval
     
    931870         (declare (ignorable deleted plist))
    932871         (when (or *asdf-verbose* *load-verbose*)
    933            (asdf-message "~&; Updating ~A for ASDF ~A~%" m ,(asdf-version)))
     872           (asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version)))
    934873         (when (member 'components-by-name added)
    935874           (compute-module-components-by-name m))
     
    959898                error-component error-operation
    960899                module-components module-components-by-name
    961                 circular-dependency-components
    962                 condition-arguments condition-form
    963                 condition-format condition-location
    964                 coerce-name)
     900                circular-dependency-components)
    965901         (ftype (function (t t) t) (setf module-components-by-name)))
    966902
     
    970906   (format-arguments :initarg :format-arguments :reader format-arguments))
    971907  (:report (lambda (c s)
    972                (apply #'errfmt s (format-control c) (format-arguments c)))))
     908             (apply #'format s (format-control c) (format-arguments c)))))
    973909
    974910(define-condition load-system-definition-error (system-definition-error)
     
    977913   (condition :initarg :condition :reader error-condition))
    978914  (:report (lambda (c s)
    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)))))
     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)))))
    981917
    982918(define-condition circular-dependency (system-definition-error)
    983919  ((components :initarg :components :reader circular-dependency-components))
    984920  (:report (lambda (c s)
    985              (errfmt s "Circular dependency: ~S" (circular-dependency-components c)))))
     921             (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
    986922
    987923(define-condition duplicate-names (system-definition-error)
    988924  ((name :initarg :name :reader duplicate-names-name))
    989925  (:report (lambda (c s)
    990              (errfmt s "Error while defining system: multiple components are given same name ~A"
    991                      (duplicate-names-name c)))))
     926             (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
     927                     (duplicate-names-name c)))))
    992928
    993929(define-condition missing-component (system-definition-error)
     
    1009945   (operation :reader error-operation :initarg :operation))
    1010946  (:report (lambda (c s)
    1011                (errfmt s "erred while invoking ~A on ~A"
    1012                        (error-operation c) (error-component c)))))
     947             (format s "~@<erred while invoking ~A on ~A~@:>"
     948                     (error-operation c) (error-component c)))))
    1013949(define-condition compile-error (operation-error) ())
    1014950(define-condition compile-failed (compile-error) ())
     
    1021957   (arguments :reader condition-arguments :initarg :arguments :initform nil))
    1022958  (:report (lambda (c s)
    1023                (errfmt s "~? (will be skipped)"
    1024                        (condition-format c)
    1025                        (list* (condition-form c) (condition-location c)
    1026                               (condition-arguments c))))))
     959             (format s "~@<~? (will be skipped)~@:>"
     960                     (condition-format c)
     961                     (list* (condition-form c) (condition-location c)
     962                            (condition-arguments c))))))
    1027963(define-condition invalid-source-registry (invalid-configuration warning)
    1028   ((format :initform "invalid source registry ~S~@[ in ~S~]~@{ ~@?~}")))
     964  ((format :initform "~@<invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~>")))
    1029965(define-condition invalid-output-translation (invalid-configuration warning)
    1030   ((format :initform "invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}")))
     966  ((format :initform "~@<invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~>")))
    1031967
    1032968(defclass component ()
     
    1034970         "Component name: designator for a string composed of portable pathname characters")
    1035971   (version :accessor component-version :initarg :version)
    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.
     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
    1042975   (load-dependencies :accessor component-load-dependencies :initform nil)
    1043976   ;; In the ASDF object model, dependencies exist between *actions*
     
    1058991   ;; hasn't yet been loaded in the current image (do-first).
    1059992   ;; 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.
    1061993   (in-order-to :initform nil :initarg :in-order-to
    1062994                :accessor component-in-order-to)
     
    10861018(defmethod print-object ((c component) stream)
    10871019  (print-unreadable-object (c stream :type t :identity nil)
    1088     (format stream "~{~S~^ ~}" (component-find-path c))))
     1020    (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
    10891021
    10901022
     
    10921024
    10931025(defmethod print-object ((c missing-dependency) s)
    1094   (format s "~A, required by ~A"
     1026  (format s "~@<~A, required by ~A~@:>"
    10951027          (call-next-method c nil) (missing-required-by c)))
    10961028
     
    11021034
    11031035(defmethod print-object ((c missing-component) s)
    1104   (format s "component ~S not found~@[ in ~A~]"
     1036  (format s "~@<component ~S not found~@[ in ~A~]~@:>"
    11051037          (missing-requires c)
    11061038          (when (missing-parent c)
     
    11081040
    11091041(defmethod print-object ((c missing-component-of-version) s)
    1110   (format s "component ~S does not match version ~A~@[ in ~A~]"
     1042  (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
    11111043          (missing-requires c)
    11121044          (missing-version c)
     
    11851117
    11861118(defclass system (module)
    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)
     1119  ((description :accessor system-description :initarg :description)
     1120   (long-description
     1121    :accessor system-long-description :initarg :long-description)
    11911122   (author :accessor system-author :initarg :author)
    11921123   (maintainer :accessor system-maintainer :initarg :maintainer)
     
    12371168    (symbol (string-downcase (symbol-name name)))
    12381169    (string name)
    1239     (t (sysdef-error "invalid component designator ~A" name))))
     1170    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
    12401171
    12411172(defun* system-registered-p (name)
     
    12551186FN should be a function of one argument. It will be
    12561187called with an object of type asdf:system."
    1257   (maphash #'(lambda (_ datum)
     1188  (maphash (lambda (_ datum)
     1189             (declare (ignore _))
     1190             (destructuring-bind (_ . def) datum
    12581191               (declare (ignore _))
    1259                (destructuring-bind (_ . def) datum
    1260                  (declare (ignore _))
    1261                  (funcall fn def)))
     1192               (funcall fn def)))
    12621193           *defined-systems*))
    12631194
     
    12711202  (let ((system-name (coerce-name system)))
    12721203    (or
    1273      (some #'(lambda (x) (funcall x system-name))
     1204     (some (lambda (x) (funcall x system-name))
    12741205           *system-definition-search-functions*)
    12751206     (let ((system-pair (system-registered-p system-name)))
     
    13001231              :name name
    13011232              :type "asd")))
    1302         (when (probe-file* file)
     1233        (when (probe-file file)
    13031234          (return file)))
    1304       #+(and asdf-windows (not clisp))
     1235      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
    13051236      (let ((shortcut
    13061237             (make-pathname
     
    13081239              :name (concatenate 'string name ".asd")
    13091240              :type "lnk")))
    1310         (when (probe-file* shortcut)
     1241        (when (probe-file shortcut)
    13111242          (let ((target (parse-windows-shortcut shortcut)))
    13121243            (when target
     
    13301261                            (let* ((*print-circle* nil)
    13311262                                   (message
    1332                                     (errfmt nil
    1333                                             "While searching for system ~S: ~S evaluated to ~S which is not a directory."
     1263                                    (format nil
     1264                                            "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
    13341265                                            system dir defaults)))
    13351266                              (error message))
     
    13391270                          (coerce-entry-to-directory ()
    13401271                            :report (lambda (s)
    1341                                       (errfmt s "Coerce entry to ~a, replace ~a and continue."
    1342                                               (ensure-directory-pathname defaults) dir))
     1272                                      (format s "Coerce entry to ~a, replace ~a and continue."
     1273                                              (ensure-directory-pathname defaults) dir))
    13431274                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
    13441275        ;; cleanup
     
    13721303  ;; as if the file were very old.
    13731304  ;; (or should we treat the case in a different, special way?)
    1374   (or (and pathname (probe-file* pathname) (file-write-date pathname))
     1305  (or (and pathname (probe-file pathname) (file-write-date pathname))
    13751306      (progn
    13761307        (when (and pathname *asdf-verbose*)
     
    13871318    (unwind-protect
    13881319         (handler-bind
    1389              ((error #'(lambda (condition)
    1390                          (error 'load-system-definition-error
    1391                                 :name name :pathname pathname
    1392                                 :condition condition))))
     1320             ((error (lambda (condition)
     1321                       (error 'load-system-definition-error
     1322                              :name name :pathname pathname
     1323                              :condition condition))))
    13931324           (let ((*package* package))
    13941325             (asdf-message
    1395               "~&; Loading system definition from ~A into ~A~%"
     1326              "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
    13961327              pathname package)
    13971328             (load pathname)))
     
    14191350
    14201351(defun* register-system (name system)
    1421   (asdf-message "~&; Registering ~A as ~A~%" system name)
     1352  (asdf-message "~&~@<; ~@;Registering ~A as ~A~@:>~%" system name)
    14221353  (setf (gethash (coerce-name name) *defined-systems*)
    14231354        (cons (get-universal-time) system)))
     
    14981429
    14991430(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.
    1506 When given a string, portably decompose it into a relative pathname:
    1507 #\\/ separates subdirectories. The last #\\/-separated string is as follows:
    1508 if TYPE is NIL, its last #\\. if any separates name and type from from type;
    1509 if TYPE is a string, it is the type, and the whole string is the name;
    1510 if TYPE is :DIRECTORY, the string is a directory component;
    1511 if the string is empty, it's a directory.
    1512 Any directory named .. is read as :BACK.
    1513 Host, device and version components are taken from DEFAULTS."
    15141431  ;; The defaults are required notably because they provide the default host
    15151432  ;; to the below make-pathname, which may crucially matter to people using
     
    15201437  ;; ASDF:MERGE-PATHNAMES*
    15211438  (etypecase name
    1522     ((or null pathname)
     1439    (pathname
    15231440     name)
    15241441    (symbol
    1525      (coerce-pathname (string-downcase name) :type type :defaults defaults))
     1442     (merge-component-name-type (string-downcase name) :type type :defaults defaults))
    15261443    (string
    15271444     (multiple-value-bind (relative path filename)
     
    15441461
    15451462(defmethod component-relative-pathname ((component component))
    1546   (coerce-pathname
     1463  (merge-component-name-type
    15471464   (or (slot-value component 'relative-pathname)
    15481465       (component-name component))
     
    16521569(defmethod component-self-dependencies ((o operation) (c component))
    16531570  (let ((all-deps (component-depends-on o c)))
    1654     (remove-if-not #'(lambda (x)
    1655                        (member (component-name c) (cdr x) :test #'string=))
     1571    (remove-if-not (lambda (x)
     1572                     (member (component-name c) (cdr x) :test #'string=))
    16561573                   all-deps)))
    16571574
     
    16601577        (self-deps (component-self-dependencies operation c)))
    16611578    (if self-deps
    1662         (mapcan #'(lambda (dep)
    1663                     (destructuring-bind (op name) dep
    1664                       (output-files (make-instance op)
    1665                                     (find-component parent name))))
     1579        (mapcan (lambda (dep)
     1580                  (destructuring-bind (op name) dep
     1581                    (output-files (make-instance op)
     1582                                  (find-component parent name))))
    16661583                self-deps)
    16671584        ;; no previous operations needed?  I guess we work with the
     
    17171634         ;; second). So that's cool.
    17181635         (and
    1719           (every #'probe-file* in-files)
    1720           (every #'probe-file* out-files)
     1636          (every #'probe-file in-files)
     1637          (every #'probe-file out-files)
    17211638          (>= (earliest-out) (latest-in))))))))
    17221639
     
    17651682      (retry ()
    17661683        :report (lambda (s)
    1767                   (errfmt s "Retry loading component ~S." required-c))
     1684                  (format s "~@<Retry loading component ~S.~@:>" required-c))
    17681685        :test
    17691686        (lambda (c)
    1770           (or (null c)
    1771               (and (typep c 'missing-dependency)
    1772                    (equalp (missing-requires c)
    1773                            required-c))))))))
     1687          (or (null c)
     1688              (and (typep c 'missing-dependency)
     1689                   (equalp (missing-requires c)
     1690                           required-c))))))))
    17741691
    17751692(defun* do-dep (operation c collect op dep)
     
    19341851(defmethod perform ((operation operation) (c source-file))
    19351852  (sysdef-error
    1936    "required method PERFORM not implemented for operation ~A, component ~A"
     1853   "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
    19371854   (class-of operation) (class-of c)))
    19381855
     
    19571874               :initform *compile-file-failure-behaviour*)
    19581875   (flags :initarg :flags :accessor compile-op-flags
    1959           :initform nil)))
     1876          :initform #-ecl nil #+ecl '(:system-p t))))
    19601877
    19611878(defun output-file (operation component)
     
    19661883
    19671884(defmethod perform :before ((operation compile-op) (c source-file))
    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)))
     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))))
    19731895
    19741896(defmethod perform :after ((operation operation) (c component))
     
    19761898        (get-universal-time)))
    19771899
    1978 (defvar *compile-op-compile-file-function* 'compile-file*
    1979   "Function used to compile lisp files.")
     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*))
    19801904
    19811905;;; perform is required to check output-files to find out where to put
     
    19901914        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    19911915    (multiple-value-bind (output warnings-p failure-p)
    1992         (apply *compile-op-compile-file-function* source-file :output-file output-file
     1916        (apply #'compile-file* source-file :output-file output-file
    19931917               (compile-op-flags operation))
    19941918      (when warnings-p
    19951919        (case (operation-on-warnings operation)
    19961920          (:warn (warn
    1997                   "COMPILE-FILE warned while performing ~A on ~A."
     1921                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
    19981922                  operation c))
    19991923          (:error (error 'compile-warned :component c :operation operation))
     
    20021926        (case (operation-on-failure operation)
    20031927          (:warn (warn
    2004                   "COMPILE-FILE failed while performing ~A on ~A."
     1928                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
    20051929                  operation c))
    20061930          (:error (error 'compile-failed :component c :operation operation))
     
    20121936  (declare (ignorable operation))
    20131937  (let ((p (lispize-pathname (component-pathname c))))
    2014     #-broken-fasl-loader (list (compile-file-pathname p))
    2015     #+broken-fasl-loader (list p)))
     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)))
    20161942
    20171943(defmethod perform ((operation compile-op) (c static-file))
     
    20391965
    20401966(defmethod perform ((o load-op) (c cl-source-file))
    2041   (map () #'load (input-files o c)))
     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)))))
    20421972
    20431973(defmethod perform-with-restarts (operation component)
     
    21322062  (let ((what-would-load-op-do (cdr (assoc 'load-op
    21332063                                           (component-in-order-to c)))))
    2134     (mapcar #'(lambda (dep)
    2135                 (if (eq (car dep) 'load-op)
    2136                     (cons 'load-source-op (cdr dep))
    2137                     dep))
     2064    (mapcar (lambda (dep)
     2065              (if (eq (car dep) 'load-op)
     2066                  (cons 'load-source-op (cdr dep))
     2067                  dep))
    21382068            what-would-load-op-do)))
    21392069
     
    21982128                :report
    21992129                (lambda (s)
    2200                   (errfmt s "Retry ~A." (operation-description op component))))
     2130                  (format s "~@<Retry ~A.~@:>" (operation-description op component))))
    22012131              (accept ()
    22022132                :report
    22032133                (lambda (s)
    2204                   (errfmt s "Continue, treating ~A as having been successful."
    2205                           (operation-description op component)))
     2134                  (format s "~@<Continue, treating ~A as having been successful.~@:>"
     2135                          (operation-description op component)))
    22062136                (setf (gethash (type-of op)
    22072137                               (component-operation-times component))
     
    22812211  (let* ((file-pathname (load-pathname))
    22822212         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
    2283     (or (and pathname-supplied-p
    2284              (merge-pathnames* (coerce-pathname pathname :type :directory)
    2285                                directory-pathname))
     2213    (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
    22862214        directory-pathname
    22872215        (default-directory))))
     
    23262254           (or (module-default-component-class parent)
    23272255               (find-class *default-component-class*)))
    2328       (sysdef-error "don't recognize component type ~A" type)))
     2256      (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
    23292257
    23302258(defun* maybe-add-tree (tree op1 op2 c)
     
    23832311         ;; methods will not be for this particular gf
    23842312         ;; But this is hardly performance-critical
    2385          #'(lambda (m)
    2386              (remove-method (symbol-function name) m))
     2313         (lambda (m)
     2314           (remove-method (symbol-function name) m))
    23872315         (component-inline-methods component)))
    23882316  ;; clear methods, then add the new ones
     
    25852513(defun* system-relative-pathname (system name &key type)
    25862514  (merge-pathnames*
    2587    (coerce-pathname name :type type)
     2515   (merge-component-name-type name :type type)
    25882516   (system-source-directory system)))
    25892517
     
    25962524
    25972525(defparameter *implementation-features*
    2598   '((:abcl :armedbear)
    2599     (:acl :allegro)
    2600     (:mcl :digitool) ; before clozure, so it won't get preempted by ccl
     2526  '((:acl :allegro)
     2527    (:lw :lispworks)
     2528    (:digitool) ; before clozure, so it won't get preempted by ccl
    26012529    (:ccl :clozure)
    26022530    (:corman :cormanlisp)
    2603     (:lw :lispworks)
    2604     :clisp :cmu :ecl :gcl :sbcl :scl :symbolics))
     2531    (:abcl :armedbear)
     2532    :sbcl :cmu :clisp :gcl :ecl :scl))
    26052533
    26062534(defparameter *os-features*
     
    26102538    (:macosx :darwin :darwin-target :apple)
    26112539    :freebsd :netbsd :openbsd :bsd
    2612     :unix
    2613     :genera))
     2540    :unix))
    26142541
    26152542(defparameter *architecture-features*
     
    26232550    (:sparc32 :sparc)
    26242551    (:arm :arm-target)
    2625     (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
    2626     :imach))
     2552    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
    26272553
    26282554(defun* lisp-version-string ()
     
    26422568                      (if (member :64bit *features*) "-64bit" ""))
    26432569    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    2644     #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
     2570    #+clisp (subseq s 0 (position #\space s))
    26452571    #+clozure (format nil "~d.~d-f~d" ; shorten for windows
    26462572                      ccl::*openmcl-major-version*
     
    26482574                      (logand ccl::fasl-version #xFF))
    26492575    #+cmu (substitute #\- #\/ s)
     2576    #+digitool (subseq s 8)
    26502577    #+ecl (format nil "~A~@[-~A~]" s
    26512578                  (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     
    26532580                      (subseq vcs-id 0 8))))
    26542581    #+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))
    26572582    #+lispworks (format nil "~A~@[~A~]" s
    26582583                        (when (member :lispworks-64bit *features*) "-64bit"))
    26592584    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
    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))
     2585    #+(or cormanlisp mcl sbcl scl) s
     2586    #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
     2587          ecl gcl lispworks mcl sbcl scl) s))
    26642588
    26652589(defun* first-feature (features)
     
    26932617          (os   (maybe-warn (first-feature *os-features*)
    26942618                            "No os feature found in ~a." *os-features*))
    2695           (arch (or #-clisp
    2696                     (maybe-warn (first-feature *architecture-features*)
    2697                                 "No architecture feature found in ~a."
    2698                                 *architecture-features*)))
     2619          (arch #+clisp "" #-clisp
     2620                (maybe-warn (first-feature *architecture-features*)
     2621                            "No architecture feature found in ~a."
     2622                            *architecture-features*))
    26992623          (version (maybe-warn (lisp-version-string)
    27002624                               "Don't know how to get Lisp implementation version.")))
    27012625      (substitute-if
    2702        #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))
    2703        (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))
     2626       #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
     2627       (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
    27042628
    27052629
     
    27082632
    27092633(defparameter *inter-directory-separator*
    2710   #+asdf-unix #\:
    2711   #-asdf-unix #\;)
     2634  #+(or unix cygwin) #\:
     2635  #-(or unix cygwin) #\;)
    27122636
    27132637(defun* user-homedir ()
    2714   (truenamize (pathname-directory-pathname (user-homedir-pathname))))
     2638  (truename (user-homedir-pathname)))
    27152639
    27162640(defun* try-directory-subpath (x sub &key type)
    27172641  (let* ((p (and x (ensure-directory-pathname x)))
    27182642         (tp (and p (probe-file* p)))
    2719          (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))
     2643         (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
    27202644         (ts (and sp (probe-file* sp))))
    27212645    (and ts (values sp ts))))
     
    27282652           :for dir :in (split-string dirs :separator ":")
    27292653           :collect (try dir "common-lisp/"))
    2730        #+asdf-windows
     2654       #+(and (or win32 windows mswindows mingw32) (not cygwin))
    27312655        ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
    27322656            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
     
    27372661   #'null
    27382662   (append
    2739     #+asdf-windows
     2663    #+(and (or win32 windows mswindows mingw32) (not cygwin))
    27402664    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    27412665      `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
    27422666           ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    27432667        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
    2744     #+asdf-unix
    27452668    (list #p"/etc/common-lisp/"))))
    27462669(defun* in-first-directory (dirs x)
     
    28112734  (apply 'directory pathname-spec
    28122735         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
    2813                              #+clozure '(:follow-links nil)
     2736                             #+ccl '(:follow-links nil)
    28142737                             #+clisp '(:circle t :if-does-not-exist :ignore)
    28152738                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
     
    28592782    (or
    28602783     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
    2861      #+asdf-windows
     2784     #+(and (or win32 windows mswindows mingw32) (not cygwin))
    28622785     (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
    28632786     '(:home ".cache" "common-lisp" :implementation))))
     
    28742797        (list
    28752798         (stable-sort (copy-list new-value) #'>
    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))))))))
     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))))))))
    28822805  new-value)
    28832806
     
    29182841              ((eql :implementation) (implementation-identifier))
    29192842              ((eql :implementation-type) (string-downcase (implementation-type)))
    2920               #+asdf-unix
     2843              #-(and (or win32 windows mswindows mingw32) (not cygwin))
    29212844              ((eql :uid) (princ-to-string (get-uid)))))
    29222845         (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
     
    29892912                      (member :default-directory :*/ :**/ :*.*.*
    29902913                        :implementation :implementation-type
    2991                         #+asdf-unix :uid)))))
     2914                        #-(and (or win32 windows mswindows mingw32) (not cygwin)) :uid)))))
    29922915    (or (typep x 'boolean)
    29932916        (absolute-component-p x)
     
    30813004    ;; Some implementations have precompiled ASDF systems,
    30823005    ;; so we must disable translations for implementation paths.
    3083     #+sbcl ,(let ((h (getenv "SBCL_HOME")))
    3084                  (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
     3006    #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
    30853007    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
    30863008    #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
     
    30933015    :enable-user-cache))
    30943016
    3095 (defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
    3096 (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
     3017(defparameter *output-translations-file* #p"asdf-output-translations.conf")
     3018(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
    30973019
    30983020(defun* user-output-translations-pathname ()
     
    31223044     (process-output-translations (validate-output-translations-directory pathname)
    31233045                                  :inherit inherit :collect collect))
    3124     ((probe-file* pathname)
     3046    ((probe-file pathname)
    31253047     (process-output-translations (validate-output-translations-file pathname)
    31263048                                  :inherit inherit :collect collect))
     
    31853107   :test 'equal :from-end t))
    31863108
    3187 (defvar *output-translations-parameter* nil)
    3188 
    3189 (defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
     3109(defun* initialize-output-translations (&optional parameter)
    31903110  "read the configuration, initialize the internal configuration variable,
    31913111return the configuration"
    3192   (setf *output-translations-parameter* parameter
    3193         (output-translations) (compute-output-translations parameter)))
     3112  (setf (output-translations) (compute-output-translations parameter)))
    31943113
    31953114(defun* disable-output-translations ()
     
    32673186
    32683187(defun* delete-file-if-exists (x)
    3269   (when (and x (probe-file* x))
     3188  (when (and x (probe-file x))
    32703189    (delete-file x)))
    32713190
     
    33603279;;;; http://www.wotsit.org/list.asp?fc=13
    33613280
    3362 #+(and asdf-windows (not clisp))
     3281#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
    33633282(progn
    33643283(defparameter *link-initial-dword* 76)
     
    34703389(defun directory-has-asd-files-p (directory)
    34713390  (ignore-errors
    3472     (and (directory* (merge-pathnames* *wild-asd* directory)) t)))
     3391    (directory* (merge-pathnames* *wild-asd* directory))
     3392    t))
    34733393
    34743394(defun subdirectories (directory)
    34753395  (let* ((directory (ensure-directory-pathname directory))
    3476          #-(or cormanlisp genera)
     3396         #-cormanlisp
    34773397         (wild (merge-pathnames*
    34783398                #-(or abcl allegro lispworks scl)
     
    34813401                directory))
    34823402         (dirs
    3483           #-(or cormanlisp genera)
     3403          #-cormanlisp
    34843404          (ignore-errors
    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)
     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)
    34903409         (dirs (remove-if-not #+abcl #'extensions:probe-directory
    34913410                              #+allegro #'excl:probe-directory
    34923411                              #+lispworks #'lw:file-directory-p
    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)))
     3412                              #-(or abcl allegro lispworks) #'directory-pathname-p
     3413                              dirs)))
    34983414    dirs))
    34993415
     
    35903506    default-source-registry))
    35913507
    3592 (defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
    3593 (defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
     3508(defparameter *source-registry-file* #p"source-registry.conf")
     3509(defparameter *source-registry-directory* #p"source-registry.conf.d/")
    35943510
    35953511(defun* wrapping-source-registry ()
    35963512  `(:source-registry
    3597     #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
     3513    #+sbcl (:tree ,(getenv "SBCL_HOME"))
    35983514    :inherit-configuration
    35993515    #+cmu (:tree #p"modules:")))
     
    36023518    `(:source-registry
    36033519      #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
    3604       (:directory ,(default-directory))
     3520      (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
    36053521      ,@(let*
    3606          #+asdf-unix
     3522         #+(or unix cygwin)
    36073523         ((datahome
    36083524           (or (getenv "XDG_DATA_HOME")
     
    36113527           (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
    36123528          (dirs (cons datahome (split-string datadirs :separator ":"))))
    3613          #+asdf-windows
     3529         #+(and (or win32 windows mswindows mingw32) (not cygwin))
    36143530         ((datahome (getenv "APPDATA"))
    36153531          (datadir
     
    36183534                            "Application Data"))
    36193535          (dirs (list datahome datadir)))
    3620          #-(or asdf-unix asdf-windows)
     3536         #-(or unix win32 windows mswindows mingw32 cygwin)
    36213537         ((dirs ()))
    36223538         (loop :for dir :in dirs
     
    36493565       (process-source-registry (validate-source-registry-directory pathname)
    36503566                                :inherit inherit :register register)))
    3651     ((probe-file* pathname)
     3567    ((probe-file pathname)
    36523568     (let ((*here-directory* (pathname-directory-pathname pathname)))
    36533569       (process-source-registry (validate-source-registry-file pathname)
     
    37053621          ,parameter
    37063622          ,@*default-source-registries*)
    3707         :register #'(lambda (directory &key recurse exclude)
    3708                       (collect (list directory :recurse recurse :exclude exclude)))))
     3623        :register (lambda (directory &key recurse exclude)
     3624                    (collect (list directory :recurse recurse :exclude exclude)))))
    37093625     :test 'equal :from-end t)))
    37103626
     
    37193635         :recurse recurse :exclude exclude :collect #'collect)))))
    37203636
    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)))
     3637(defun* initialize-source-registry (&optional parameter)
     3638  (setf (source-registry) (compute-source-registry parameter)))
    37263639
    37273640;; Checks an initial variable to see whether the state is initialized
     
    37563669      ((style-warning #'muffle-warning)
    37573670       (missing-component (constantly nil))
    3758        (error #'(lambda (e)
    3759                   (errfmt *error-output* "ASDF could not load ~(~A~) because ~A.~%"
    3760                           name e))))
     3671       (error (lambda (e)
     3672                (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
     3673                        name e))))
    37613674    (let* ((*verbose-out* (make-broadcast-stream))
    37623675           (system (find-system (string-downcase name) nil)))
     
    37823695;;;; See https://bugs.launchpad.net/asdf/+bug/485687
    37833696;;;;
     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))))))
    37843708
    37853709;;; If a previous version of ASDF failed to read some configuration, try again.
Note: See TracChangeset for help on using the changeset viewer.