Changeset 15207


Ignore:
Timestamp:
Feb 13, 2012, 6:09:49 PM (8 years ago)
Author:
rme
Message:

Update to ASDF 2.20.

File:
1 edited

Legend:

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

    r15098 r15207  
    1 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.017: Another System Definition Facility.
     1;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
     2;;; This is ASDF 2.20: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    5757(eval-when (:compile-toplevel :load-toplevel :execute)
    5858  ;;; Implementation-dependent tweaks
    59   ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
     59  ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
    6060  #+allegro
    6161  (setf excl::*autoload-package-name-alist*
    6262        (remove "asdf" excl::*autoload-package-name-alist*
    6363                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
    64   #+(and ecl (not ecl-bytecmp)) (require :cmp)
     64  #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
     65  #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
    6566  #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
    6667  (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
     
    6869                 (< system::*gcl-minor-version* 7)))
    6970    (pushnew :gcl-pre2.7 *features*))
    70   #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
    71   #+(or unix cygwin) (pushnew :asdf-unix *features*)
    7271  ;;; make package if it doesn't exist yet.
    7372  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
     
    8988  ;; Strip out formatting that is not supported on Genera.
    9089  ;; Has to be inside the eval-when to make Lispworks happy (!)
     90  (defun strcat (&rest strings)
     91    (apply 'concatenate 'string strings))
    9192  (defmacro compatfmt (format)
    9293    #-(or gcl genera) format
    9394    #+(or gcl genera)
    9495    (loop :for (unsupported . replacement) :in
    95       `(("~3i~_" . "")
    96         #+genera
    97         ,@(("~@<" . "")
    98            ("; ~@;" . "; ")
    99            ("~@:>" . "")
    100            ("~:>" . ""))) :do
     96      (append
     97       '(("~3i~_" . ""))
     98       #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
    10199      (loop :for found = (search unsupported format) :while found :do
    102         (setf format
    103               (concatenate 'simple-string
    104                            (subseq format 0 found) replacement
    105                            (subseq format (+ found (length unsupported)))))))
     100        (setf format (strcat (subseq format 0 found) replacement
     101                             (subseq format (+ found (length unsupported)))))))
    106102    format)
    107103  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
     
    113109         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    114110         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    115          (asdf-version "2.017")
     111         (asdf-version "2.20")
    116112         (existing-asdf (find-class 'component nil))
    117113         (existing-version *asdf-version*)
     
    191187                     (push sym formerly-exported-symbols)))
    192188               (loop :for sym :in export :do
    193                  (unless (member sym bothly-exported-symbols :test 'string-equal)
     189                 (unless (member sym bothly-exported-symbols :test 'equal)
    194190                   (push sym newly-exported-symbols)))
    195191               (loop :for user :in (package-used-by-list package)
     
    201197               (loop :for x :in newly-exported-symbols :do
    202198                 (export (intern* x package)))))
    203            (ensure-package (name &key nicknames use unintern fmakunbound
    204                                 shadow export redefined-functions)
     199           (ensure-package (name &key nicknames use unintern
     200                                shadow export redefined-functions)
    205201             (let* ((p (ensure-exists name nicknames use)))
    206202               (ensure-unintern p unintern)
    207203               (ensure-shadow p shadow)
    208204               (ensure-export p export)
    209                (ensure-fmakunbound p (append fmakunbound redefined-functions))
     205               (ensure-fmakunbound p redefined-functions)
    210206               p)))
    211207        (macrolet
    212208            ((pkgdcl (name &key nicknames use export
    213                            redefined-functions unintern fmakunbound shadow)
     209                           redefined-functions unintern shadow)
    214210                 `(ensure-package
    215211                   ',name :nicknames ',nicknames :use ',use :export ',export
    216212                   :shadow ',shadow
    217213                   :unintern ',unintern
    218                    :redefined-functions ',redefined-functions
    219                    :fmakunbound ',fmakunbound)))
     214                   :redefined-functions ',redefined-functions)))
    220215          (pkgdcl
    221216           :asdf
     
    227222            #:system-source-file #:operate #:find-component #:find-system
    228223            #:apply-output-translations #:translate-pathname* #:resolve-location
     224            #:system-relative-pathname
     225            #:inherit-source-registry #:process-source-registry
     226            #:process-source-registry-directive
    229227            #:compile-file* #:source-file-type)
    230228           :unintern
    231229           (#:*asdf-revision* #:around #:asdf-method-combination
    232             #:split #:make-collector
     230            #:split #:make-collector #:do-dep #:do-one-dep
     231            #:resolve-relative-location-component #:resolve-absolute-location-component
    233232            #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
    234            :fmakunbound
    235            (#:system-source-file
    236             #:component-relative-pathname #:system-relative-pathname
    237             #:process-source-registry
    238             #:inherit-source-registry #:process-source-registry-directive)
    239233           :export
    240            (#:defsystem #:oos #:operate #:find-system #:run-shell-command
     234           (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
    241235            #:system-definition-pathname #:with-system-definitions
    242             #:search-for-system-definition #:find-component ; miscellaneous
    243             #:compile-system #:load-system #:test-system #:clear-system
    244             #:compile-op #:load-op #:load-source-op
    245             #:test-op
    246             #:operation               ; operations
    247             #:feature                 ; sort-of operation
    248             #:version                 ; metaphorically sort-of an operation
    249             #:version-satisfies
     236            #:search-for-system-definition #:find-component #:component-find-path
     237            #:compile-system #:load-system #:load-systems #:test-system #:clear-system
     238            #:operation #:compile-op #:load-op #:load-source-op #:test-op
     239            #:feature #:version #:version-satisfies
    250240            #:upgrade-asdf
    251241            #:implementation-identifier #:implementation-type
    252 
    253             #:input-files #:output-files #:output-file #:perform ; operation methods
     242            #:input-files #:output-files #:output-file #:perform
    254243            #:operation-done-p #:explain
    255244
     
    299288            #:*compile-file-failure-behaviour*
    300289            #:*resolve-symlinks*
     290            #:*require-asdf-operator*
    301291            #:*asdf-verbose*
     292            #:*verbose-out*
    302293
    303294            #:asdf-version
     
    341332            #:system-registered-p
    342333            #:asdf-message
     334            #:user-output-translations-pathname
     335            #:system-output-translations-pathname
     336            #:user-output-translations-directory-pathname
     337            #:system-output-translations-directory-pathname
     338            #:user-source-registry
     339            #:system-source-registry
     340            #:user-source-registry-directory
     341            #:system-source-registry-directory
    343342
    344343            ;; Utilities
    345344            #:absolute-pathname-p
    346345            ;; #:aif #:it
    347             ;; #:appendf
     346            ;; #:appendf #:orf
    348347            #:coerce-name
    349348            #:directory-pathname-p
     
    353352            ;; #:length=n-p
    354353            ;; #:find-symbol*
    355             #:merge-pathnames*
    356             #:coerce-pathname
     354            #:merge-pathnames* #:coerce-pathname #:subpathname
    357355            #:pathname-directory-pathname
    358356            #:read-file-forms
     
    417415                condition-format condition-location
    418416                coerce-name)
     417         (ftype (function (&optional t) (values)) initialize-source-registry)
    419418         #-(or cormanlisp gcl-pre2.7)
    420419         (ftype (function (t t) t) (setf module-components-by-name)))
     
    425424(progn
    426425  (deftype logical-pathname () nil)
    427   (defun* make-broadcast-stream () *error-output*)
    428   (defun* file-namestring (p)
     426  (defun make-broadcast-stream () *error-output*)
     427  (defun file-namestring (p)
    429428    (setf p (pathname p))
    430429    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
     
    526525              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
    527526
     527(defun* ununspecific (x)
     528  (if (eq x :unspecific) nil x))
     529
    528530(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    529531  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
     
    544546         (type (or (pathname-type specified) (pathname-type defaults)))
    545547         (version (or (pathname-version specified) (pathname-version defaults))))
    546     (labels ((ununspecific (x)
    547                (if (eq x :unspecific) nil x))
    548              (unspecific-handler (p)
     548    (labels ((unspecific-handler (p)
    549549               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
    550550      (multiple-value-bind (host device directory unspecific-handler)
     
    676676(defun* getenv (x)
    677677  (declare (ignorable x))
    678   #+(or abcl clisp xcl) (ext:getenv x)
     678  #+(or abcl clisp ecl xcl) (ext:getenv x)
    679679  #+allegro (sys:getenv x)
    680680  #+clozure (ccl:getenv x)
     
    690690      (ct:free buffer)
    691691      (ct:free buffer1)))
    692   #+ecl (si:getenv x)
    693692  #+gcl (system:getenv x)
    694693  #+genera nil
     
    898897        (port (ext:pathname-port pathname))
    899898        (directory (pathname-directory pathname)))
    900     (flet ((not-unspecific (component)
    901              (and (not (eq component :unspecific)) component)))
    902       (cond ((or (not-unspecific port)
    903                  (and (not-unspecific host) (plusp (length host)))
    904                  (not-unspecific scheme))
    905              (let ((prefix ""))
    906                (when (not-unspecific port)
    907                  (setf prefix (format nil ":~D" port)))
    908                (when (and (not-unspecific host) (plusp (length host)))
    909                  (setf prefix (concatenate 'string host prefix)))
    910                (setf prefix (concatenate 'string ":" prefix))
    911                (when (not-unspecific scheme)
    912                (setf prefix (concatenate 'string scheme prefix)))
    913                (assert (and directory (eq (first directory) :absolute)))
    914                (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
    915                               :defaults pathname)))
    916             (t
    917              pathname)))))
     899    (if (or (ununspecific port)
     900            (and (ununspecific host) (plusp (length host)))
     901            (ununspecific scheme))
     902        (let ((prefix ""))
     903          (when (ununspecific port)
     904            (setf prefix (format nil ":~D" port)))
     905          (when (and (ununspecific host) (plusp (length host)))
     906            (setf prefix (strcat host prefix)))
     907          (setf prefix (strcat ":" prefix))
     908          (when (ununspecific scheme)
     909            (setf prefix (strcat scheme prefix)))
     910          (assert (and directory (eq (first directory) :absolute)))
     911          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
     912                         :defaults pathname)))
     913    pathname))
    918914
    919915;;;; -------------------------------------------------------------------------
     
    923919(defgeneric* perform (operation component))
    924920(defgeneric* operation-done-p (operation component))
     921(defgeneric* mark-operation-done (operation component))
    925922(defgeneric* explain (operation component))
    926923(defgeneric* output-files (operation component))
     
    11671164   ;; it to default in funky ways if not supplied
    11681165   (relative-pathname :initarg :pathname)
     1166   ;; the absolute-pathname is computed based on relative-pathname...
    11691167   (absolute-pathname)
    11701168   (operation-times :initform (make-hash-table)
    11711169                    :accessor component-operation-times)
     1170   (around-compile :initarg :around-compile)
    11721171   ;; XXX we should provide some atomic interface for updating the
    11731172   ;; component properties
     
    12801279  new-value)
    12811280
    1282 (defclass system (module)
     1281(defclass proto-system () ; slots to keep when resetting a system
     1282  ;; To preserve identity for all objects, we'd need keep the components slots
     1283  ;; but also to modify parse-component-form to reset the recycled objects.
     1284  ((name) #|(components) (components-by-names)|#))
     1285
     1286(defclass system (module proto-system)
    12831287  (;; description and long-description are now available for all component's,
    12841288   ;; but now also inherited from component, but we add the legacy accessor
     
    12891293   (licence :accessor system-licence :initarg :licence
    12901294            :accessor system-license :initarg :license)
    1291    (source-file :reader system-source-file :initarg :source-file
     1295   (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade
    12921296                :writer %set-system-source-file)
    12931297   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
     
    13411345           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
    13421346
     1347;;;; -----------------------------------------------------------------
     1348;;;; Windows shortcut support.  Based on:
     1349;;;;
     1350;;;; Jesse Hager: The Windows Shortcut File Format.
     1351;;;; http://www.wotsit.org/list.asp?fc=13
     1352
     1353#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
     1354(progn
     1355(defparameter *link-initial-dword* 76)
     1356(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
     1357
     1358(defun* read-null-terminated-string (s)
     1359  (with-output-to-string (out)
     1360    (loop :for code = (read-byte s)
     1361      :until (zerop code)
     1362      :do (write-char (code-char code) out))))
     1363
     1364(defun* read-little-endian (s &optional (bytes 4))
     1365  (loop :for i :from 0 :below bytes
     1366    :sum (ash (read-byte s) (* 8 i))))
     1367
     1368(defun* parse-file-location-info (s)
     1369  (let ((start (file-position s))
     1370        (total-length (read-little-endian s))
     1371        (end-of-header (read-little-endian s))
     1372        (fli-flags (read-little-endian s))
     1373        (local-volume-offset (read-little-endian s))
     1374        (local-offset (read-little-endian s))
     1375        (network-volume-offset (read-little-endian s))
     1376        (remaining-offset (read-little-endian s)))
     1377    (declare (ignore total-length end-of-header local-volume-offset))
     1378    (unless (zerop fli-flags)
     1379      (cond
     1380        ((logbitp 0 fli-flags)
     1381          (file-position s (+ start local-offset)))
     1382        ((logbitp 1 fli-flags)
     1383          (file-position s (+ start
     1384                              network-volume-offset
     1385                              #x14))))
     1386      (strcat (read-null-terminated-string s)
     1387              (progn
     1388                (file-position s (+ start remaining-offset))
     1389                (read-null-terminated-string s))))))
     1390
     1391(defun* parse-windows-shortcut (pathname)
     1392  (with-open-file (s pathname :element-type '(unsigned-byte 8))
     1393    (handler-case
     1394        (when (and (= (read-little-endian s) *link-initial-dword*)
     1395                   (let ((header (make-array (length *link-guid*))))
     1396                     (read-sequence header s)
     1397                     (equalp header *link-guid*)))
     1398          (let ((flags (read-little-endian s)))
     1399            (file-position s 76)        ;skip rest of header
     1400            (when (logbitp 0 flags)
     1401              ;; skip shell item id list
     1402              (let ((length (read-little-endian s 2)))
     1403                (file-position s (+ length (file-position s)))))
     1404            (cond
     1405              ((logbitp 1 flags)
     1406                (parse-file-location-info s))
     1407              (t
     1408                (when (logbitp 2 flags)
     1409                  ;; skip description string
     1410                  (let ((length (read-little-endian s 2)))
     1411                    (file-position s (+ length (file-position s)))))
     1412                (when (logbitp 3 flags)
     1413                  ;; finally, our pathname
     1414                  (let* ((length (read-little-endian s 2))
     1415                         (buffer (make-array length)))
     1416                    (read-sequence buffer s)
     1417                    (map 'string #'code-char buffer)))))))
     1418      (end-of-file ()
     1419        nil)))))
     1420
    13431421;;;; -------------------------------------------------------------------------
    13441422;;;; Finding systems
     
    13961474;;; convention that functions in this list are prefixed SYSDEF-
    13971475
    1398 (defparameter *system-definition-search-functions*
    1399   '(sysdef-central-registry-search
    1400     sysdef-source-registry-search
    1401     sysdef-find-asdf))
     1476(defvar *system-definition-search-functions* '())
     1477
     1478(setf *system-definition-search-functions*
     1479      (append
     1480       ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
     1481       (remove 'contrib-sysdef-search *system-definition-search-functions*)
     1482       ;; Tuck our defaults at the end of the list if they were absent.
     1483       ;; This is imperfect, in case they were removed on purpose,
     1484       ;; but then it will be the responsibility of whoever does that
     1485       ;; to upgrade asdf before he does such a thing rather than after.
     1486       (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
     1487                  '(sysdef-central-registry-search
     1488                    sysdef-source-registry-search
     1489                    sysdef-find-asdf))))
    14021490
    14031491(defun* search-for-system-definition (system)
    1404   (let ((system-name (coerce-name system)))
    1405     (some #'(lambda (x) (funcall x system-name))
    1406           (cons 'find-system-if-being-defined *system-definition-search-functions*))))
     1492  (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
     1493        (cons 'find-system-if-being-defined
     1494              *system-definition-search-functions*)))
    14071495
    14081496(defvar *central-registry* nil
     
    14201508Going forward, we recommend new users should be using the source-registry.
    14211509")
     1510
     1511(defun* featurep (x &optional (features *features*))
     1512  (cond
     1513    ((atom x)
     1514     (and (member x features) t))
     1515    ((eq :not (car x))
     1516     (assert (null (cddr x)))
     1517     (not (featurep (cadr x) features)))
     1518    ((eq :or (car x))
     1519     (some #'(lambda (x) (featurep x features)) (cdr x)))
     1520    ((eq :and (car x))
     1521     (every #'(lambda (x) (featurep x features)) (cdr x)))
     1522    (t
     1523     (error "Malformed feature specification ~S" x))))
     1524
     1525(defun* os-unix-p ()
     1526  (featurep '(:or :unix :cygwin :darwin)))
     1527
     1528(defun* os-windows-p ()
     1529  (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
    14221530
    14231531(defun* probe-asd (name defaults)
     
    14291537        (when (probe-file* file)
    14301538          (return file)))
    1431       #+(and asdf-windows (not clisp))
    1432       (let ((shortcut
    1433              (make-pathname
    1434               :defaults defaults :version :newest :case :local
    1435               :name (concatenate 'string name ".asd")
    1436               :type "lnk")))
    1437         (when (probe-file* shortcut)
    1438           (let ((target (parse-windows-shortcut shortcut)))
    1439             (when target
    1440               (return (pathname target)))))))))
     1539      #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
     1540      (when (os-windows-p)
     1541        (let ((shortcut
     1542               (make-pathname
     1543                :defaults defaults :version :newest :case :local
     1544                :name (strcat name ".asd")
     1545                :type "lnk")))
     1546          (when (probe-file* shortcut)
     1547            (let ((target (parse-windows-shortcut shortcut)))
     1548              (when target
     1549                (return (pathname target))))))))))
    14411550
    14421551(defun* sysdef-central-registry-search (system)
     
    15071616
    15081617(defmethod find-system ((name null) &optional (error-p t))
     1618  (declare (ignorable name))
    15091619  (when error-p
    15101620    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
     
    15261636        (funcall thunk))))
    15271637
    1528 (defmacro with-system-definitions (() &body body)
     1638(defmacro with-system-definitions ((&optional) &body body)
    15291639  `(call-with-system-definitions #'(lambda () ,@body)))
    15301640
     
    15391649                                  :name name :pathname pathname
    15401650                                  :condition condition))))
    1541              (let ((*package* package))
     1651             (let ((*package* package)
     1652                   (*default-pathname-defaults*
     1653                    (pathname-directory-pathname pathname)))
    15421654               (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
    15431655                             pathname package)
     
    15451657        (delete-package package)))))
    15461658
    1547 (defmethod find-system ((name string) &optional (error-p t))
    1548   (with-system-definitions ()
    1549     (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    1550            (previous (cdr in-memory))
    1551            (previous (and (typep previous 'system) previous))
    1552            (previous-time (car in-memory))
     1659(defun* locate-system (name)
     1660  "Given a system NAME designator, try to locate where to load the system from.
     1661Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
     1662FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
     1663FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
     1664PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system.
     1665PREVIOUS when not null is a previously loaded SYSTEM object of same name.
     1666PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
     1667  (let* ((name (coerce-name name))
     1668         (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
     1669         (previous (cdr in-memory))
     1670         (previous (and (typep previous 'system) previous))
     1671         (previous-time (car in-memory))
    15531672           (found (search-for-system-definition name))
    1554            (found-system (and (typep found 'system) found))
    1555            (pathname (or (and (typep found '(or pathname string)) (pathname found))
    1556                          (and found-system (system-source-file found-system))
    1557                          (and previous (system-source-file previous)))))
     1673         (found-system (and (typep found 'system) found))
     1674         (pathname (or (and (typep found '(or pathname string)) (pathname found))
     1675                       (and found-system (system-source-file found-system))
     1676                       (and previous (system-source-file previous))))
     1677         (foundp (and (or found-system pathname previous) t)))
     1678    (check-type found (or null pathname system))
     1679    (when foundp
    15581680      (setf pathname (resolve-symlinks* pathname))
    15591681      (when (and pathname (not (absolute-pathname-p pathname)))
     
    15651687        (%set-system-source-file pathname previous)
    15661688        (setf previous-time nil))
    1567       (when (and found-system (not previous))
    1568         (register-system found-system))
    1569       (when (and pathname
    1570                  (or (not previous-time)
    1571                      ;; don't reload if it's already been loaded,
    1572                      ;; or its filestamp is in the future which means some clock is skewed
    1573                      ;; and trying to load might cause an infinite loop.
    1574                      (< previous-time (safe-file-write-date pathname) (get-universal-time))))
    1575         (load-sysdef name pathname))
    1576       (let ((in-memory (system-registered-p name))) ; try again after loading from disk
    1577         (cond
    1578           (in-memory
    1579            (when pathname
    1580              (setf (car in-memory) (safe-file-write-date pathname)))
    1581            (cdr in-memory))
    1582           (error-p
    1583            (error 'missing-component :requires name)))))))
     1689      (values foundp found-system pathname previous previous-time))))
     1690
     1691(defmethod find-system ((name string) &optional (error-p t))
     1692  (with-system-definitions ()
     1693    (loop
     1694      (restart-case
     1695          (multiple-value-bind (foundp found-system pathname previous previous-time)
     1696              (locate-system name)
     1697            (declare (ignore foundp))
     1698            (when (and found-system (not previous))
     1699              (register-system found-system))
     1700            (when (and pathname
     1701                       (or (not previous-time)
     1702                           ;; don't reload if it's already been loaded,
     1703                           ;; or its filestamp is in the future which means some clock is skewed
     1704                           ;; and trying to load might cause an infinite loop.
     1705                           (< previous-time (safe-file-write-date pathname) (get-universal-time))))
     1706              (load-sysdef name pathname))
     1707            (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
     1708              (return
     1709                (cond
     1710                  (in-memory
     1711                   (when pathname
     1712                     (setf (car in-memory) (safe-file-write-date pathname)))
     1713                   (cdr in-memory))
     1714                  (error-p
     1715                   (error 'missing-component :requires name))))))
     1716        (reinitialize-source-registry-and-retry ()
     1717          :report (lambda (s)
     1718                    (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
     1719          (initialize-source-registry))))))
    15841720
    15851721(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
     
    17031839   :defaults (component-parent-pathname component)))
    17041840
     1841(defun* subpathname (pathname subpath &key type)
     1842  (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
     1843                                  (pathname-directory-pathname pathname))))
     1844
     1845(defun subpathname* (pathname subpath &key type)
     1846  (and pathname
     1847       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
     1848
    17051849;;;; -------------------------------------------------------------------------
    17061850;;;; Operations
     
    18051949
    18061950(defmethod component-self-dependencies ((o operation) (c component))
    1807   (let ((all-deps (component-depends-on o c)))
    1808     (remove-if-not #'(lambda (x)
    1809                        (member (component-name c) (cdr x) :test #'string=))
    1810                    all-deps)))
     1951  (remove-if-not
     1952   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
     1953   (component-depends-on o c)))
    18111954
    18121955(defmethod input-files ((operation operation) (c component))
     
    18521995         (and op-time (>= op-time (latest-in))))
    18531996        ((not in-files)
    1854          ;; an operation without output-files and no input-files
     1997         ;; an operation with output-files and no input-files
    18551998         ;; is probably meant for its side-effects on the file-system,
    18561999         ;; assumed to have to be done everytime.
     
    18942037(defgeneric* do-traverse (operation component collect))
    18952038
    1896 (defun* %do-one-dep (operation c collect required-op required-c required-v)
    1897   ;; collects a partial plan that results from performing required-op
    1898   ;; on required-c, possibly with a required-vERSION
    1899   (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
    1900                       (and d (version-satisfies d required-v) d))
    1901                     (if required-v
    1902                         (error 'missing-dependency-of-version
    1903                                :required-by c
    1904                                :version required-v
    1905                                :requires required-c)
    1906                         (error 'missing-dependency
    1907                                :required-by c
    1908                                :requires required-c))))
    1909          (op (make-sub-operation c operation dep-c required-op)))
    1910     (do-traverse op dep-c collect)))
    1911 
    1912 (defun* do-one-dep (operation c collect required-op required-c required-v)
    1913   ;; this function is a thin, error-handling wrapper around %do-one-dep.
    1914   ;; Collects a partial plan per that function.
     2039(defun* resolve-dependency-name (component name &optional version)
    19152040  (loop
    19162041    (restart-case
    1917         (return (%do-one-dep operation c collect
    1918                              required-op required-c required-v))
     2042        (return
     2043          (let ((comp (find-component (component-parent component) name)))
     2044            (unless comp
     2045              (error 'missing-dependency
     2046                     :required-by component
     2047                     :requires name))
     2048            (when version
     2049              (unless (version-satisfies comp version)
     2050                (error 'missing-dependency-of-version
     2051                       :required-by component
     2052                       :version version
     2053                       :requires name)))
     2054            comp))
    19192055      (retry ()
    19202056        :report (lambda (s)
    1921                   (format s "~@<Retry loading ~3i~_~A.~@:>" required-c))
     2057                  (format s "~@<Retry loading ~3i~_~A.~@:>" name))
    19222058        :test
    19232059        (lambda (c)
    19242060          (or (null c)
    19252061              (and (typep c 'missing-dependency)
    1926                    (equalp (missing-requires c)
    1927                            required-c))))))))
    1928 
    1929 (defun* do-dep (operation c collect op dep)
    1930   ;; type of arguments uncertain:
    1931   ;; op seems to at least potentially be a symbol, rather than an operation
    1932   ;; dep is a list of component names
    1933   (cond ((eq op 'feature)
    1934          (if (member (car dep) *features*)
     2062                   (eq (missing-required-by c) component)
     2063                   (equal (missing-requires c) name))))))))
     2064
     2065(defun* resolve-dependency-spec (component dep-spec)
     2066  (cond
     2067    ((atom dep-spec)
     2068     (resolve-dependency-name component dep-spec))
     2069    ;; Structured dependencies --- this parses keywords.
     2070    ;; The keywords could conceivably be broken out and cleanly (extensibly)
     2071    ;; processed by EQL methods. But for now, here's what we've got.
     2072    ((eq :version (first dep-spec))
     2073     ;; https://bugs.launchpad.net/asdf/+bug/527788
     2074     (resolve-dependency-name component (second dep-spec) (third dep-spec)))
     2075    ((eq :feature (first dep-spec))
     2076     ;; This particular subform is not documented and
     2077     ;; has always been broken in the past.
     2078     ;; Therefore no one uses it, and I'm cerroring it out,
     2079     ;; after fixing it
     2080     ;; See https://bugs.launchpad.net/asdf/+bug/518467
     2081     (cerror "Continue nonetheless."
     2082             "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
     2083     (when (find (second dep-spec) *features* :test 'string-equal)
     2084       (resolve-dependency-name component (third dep-spec))))
     2085    (t
     2086     (error (compatfmt "~@<Bad dependency ~s.  Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
     2087
     2088(defun* do-one-dep (op c collect dep-op dep-c)
     2089  ;; Collects a partial plan for performing dep-op on dep-c
     2090  ;; as dependencies of a larger plan involving op and c.
     2091  ;; Returns t if this should force recompilation of those who depend on us.
     2092  ;; dep-op is an operation class name (not an operation object),
     2093  ;; whereas dep-c is a component object.n
     2094  (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
     2095
     2096(defun* do-dep (op c collect dep-op-spec dep-c-specs)
     2097  ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
     2098  ;; as dependencies of a larger plan involving op and c.
     2099  ;; Returns t if this should force recompilation of those who depend on us.
     2100  ;; dep-op-spec is either an operation class name (not an operation object),
     2101  ;; or the magic symbol asdf:feature.
     2102  ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
     2103  ;; and the plan will succeed if that keyword is present in *feature*,
     2104  ;; or fail if it isn't
     2105  ;; (at which point c's :if-component-dep-fails will kick in).
     2106  ;; If dep-op-spec is an operation class name,
     2107  ;; then dep-c-specs specifies a list of sibling component of c,
     2108  ;; as per resolve-dependency-spec, such that operating op on c
     2109  ;; depends on operating dep-op-spec on each of them.
     2110  (cond ((eq dep-op-spec 'feature)
     2111         (if (member (car dep-c-specs) *features*)
    19352112             nil
    19362113             (error 'missing-dependency
    19372114                    :required-by c
    1938                     :requires (car dep))))
     2115                    :requires (list :feature (car dep-c-specs)))))
    19392116        (t
    19402117         (let ((flag nil))
    1941            (flet ((dep (op comp ver)
    1942                     (when (do-one-dep operation c collect
    1943                                       op comp ver)
    1944                       (setf flag t))))
    1945              (dolist (d dep)
    1946                (if (atom d)
    1947                    (dep op d nil)
    1948                    ;; structured dependencies --- this parses keywords
    1949                    ;; the keywords could be broken out and cleanly (extensibly)
    1950                    ;; processed by EQL methods
    1951                    (cond ((eq :version (first d))
    1952                           ;; https://bugs.launchpad.net/asdf/+bug/527788
    1953                           (dep op (second d) (third d)))
    1954                          ;; This particular subform is not documented and
    1955                          ;; has always been broken in the past.
    1956                          ;; Therefore no one uses it, and I'm cerroring it out,
    1957                          ;; after fixing it
    1958                          ;; See https://bugs.launchpad.net/asdf/+bug/518467
    1959                          ((eq :feature (first d))
    1960                           (cerror "Continue nonetheless."
    1961                                   "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
    1962                           (when (find (second d) *features* :test 'string-equal)
    1963                             (dep op (third d) nil)))
    1964                          (t
    1965                           (error (compatfmt "~@<Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name.~@:>") d))))))
     2118           (dolist (d dep-c-specs)
     2119             (when (do-one-dep op c collect dep-op-spec
     2120                               (resolve-dependency-spec c d))
     2121               (setf flag t)))
    19662122           flag))))
    19672123
     
    20242180                                (update-flag
    20252181                                 (do-traverse operation kid #'internal-collect))
     2182                              #-genera
    20262183                              (missing-dependency (condition)
    20272184                                (when (eq (module-if-component-dep-fails c)
     
    20882245  nil)
    20892246
     2247(defmethod mark-operation-done ((operation operation) (c component))
     2248  (setf (gethash (type-of operation) (component-operation-times c))
     2249    (reduce #'max
     2250            (cons (get-universal-time)
     2251                  (mapcar #'safe-file-write-date (input-files operation c))))))
     2252
     2253(defmethod perform-with-restarts (operation component)
     2254  ;; TOO verbose, especially as the default. Add your own :before method
     2255  ;; to perform-with-restart or perform if you want that:
     2256  #|(when *asdf-verbose* (explain operation component))|#
     2257  (perform operation component))
     2258
     2259(defmethod perform-with-restarts :around (operation component)
     2260  (loop
     2261    (restart-case
     2262        (return (call-next-method))
     2263      (retry ()
     2264        :report
     2265        (lambda (s)
     2266          (format s (compatfmt "~@<Retry ~A.~@:>")
     2267                  (operation-description operation component))))
     2268      (accept ()
     2269        :report
     2270        (lambda (s)
     2271          (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
     2272                  (operation-description operation component)))
     2273        (mark-operation-done operation component)
     2274        (return)))))
     2275
    20902276(defmethod explain ((operation operation) (component component))
    20912277  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
     
    21142300    (first files)))
    21152301
     2302(defun* ensure-all-directories-exist (pathnames)
     2303   (loop :for pn :in pathnames
     2304     :for pathname = (if (typep pn 'logical-pathname)
     2305                         (translate-logical-pathname pn)
     2306                         pn)
     2307     :do (ensure-directories-exist pathname)))
     2308
    21162309(defmethod perform :before ((operation compile-op) (c source-file))
    2117    (loop :for file :in (asdf:output-files operation c)
    2118      :for pathname = (if (typep file 'logical-pathname)
    2119                          (translate-logical-pathname file)
    2120                          file)
    2121      :do (ensure-directories-exist pathname)))
     2310  (ensure-all-directories-exist (asdf:output-files operation c)))
    21222311
    21232312(defmethod perform :after ((operation operation) (c component))
    2124   (setf (gethash (type-of operation) (component-operation-times c))
    2125         (get-universal-time)))
     2313  (mark-operation-done operation c))
     2314
     2315(defgeneric* around-compile-hook (component))
     2316(defgeneric* call-with-around-compile-hook (component thunk))
     2317
     2318(defmethod around-compile-hook ((c component))
     2319  (cond
     2320    ((slot-boundp c 'around-compile)
     2321     (slot-value c 'around-compile))
     2322    ((component-parent c)
     2323     (around-compile-hook (component-parent c)))))
     2324
     2325(defun ensure-function (fun &key (package :asdf))
     2326  (etypecase fun
     2327    ((or symbol function) fun)
     2328    (cons (eval `(function ,fun)))
     2329    (string (eval `(function ,(with-standard-io-syntax
     2330                               (let ((*package* (find-package package)))
     2331                                 (read-from-string fun))))))))
     2332
     2333(defmethod call-with-around-compile-hook ((c component) thunk)
     2334  (let ((hook (around-compile-hook c)))
     2335    (if hook
     2336        (funcall (ensure-function hook) thunk)
     2337        (funcall thunk))))
    21262338
    21272339(defvar *compile-op-compile-file-function* 'compile-file*
     
    21392351        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    21402352    (multiple-value-bind (output warnings-p failure-p)
    2141         (apply *compile-op-compile-file-function* source-file
    2142                :output-file output-file (compile-op-flags operation))
     2353        (call-with-around-compile-hook
     2354         c #'(lambda ()
     2355               (apply *compile-op-compile-file-function* source-file
     2356                      :output-file output-file (compile-op-flags operation))))
    21432357      (unless output
    21442358        (error 'compile-error :component c :operation operation))
     
    21922406(defclass load-op (basic-load-op) ())
    21932407
     2408(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
     2409  (loop
     2410    (restart-case
     2411        (return (call-next-method))
     2412      (try-recompiling ()
     2413        :report (lambda (s)
     2414                  (format s "Recompile ~a and try loading it again"
     2415                          (component-name c)))
     2416        (perform (make-sub-operation c o c 'compile-op) c)))))
     2417
    21942418(defmethod perform ((o load-op) (c cl-source-file))
    21952419  (map () #'load (input-files o c)))
    2196 
    2197 (defmethod perform-with-restarts (operation component)
    2198   ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default.
    2199   (perform operation component))
    2200 
    2201 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
    2202   (declare (ignorable o))
    2203   (loop :with state = :initial
    2204     :until (or (eq state :success)
    2205                (eq state :failure)) :do
    2206     (case state
    2207       (:recompiled
    2208        (setf state :failure)
    2209        (call-next-method)
    2210        (setf state :success))
    2211       (:failed-load
    2212        (setf state :recompiled)
    2213        (perform (make-sub-operation c o c 'compile-op) c))
    2214       (t
    2215        (with-simple-restart
    2216            (try-recompiling "Recompile ~a and try loading it again"
    2217                             (component-name c))
    2218          (setf state :failed-load)
    2219          (call-next-method)
    2220          (setf state :success))))))
    2221 
    2222 (defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
    2223   (loop :with state = :initial
    2224     :until (or (eq state :success)
    2225                (eq state :failure)) :do
    2226     (case state
    2227       (:recompiled
    2228        (setf state :failure)
    2229        (call-next-method)
    2230        (setf state :success))
    2231       (:failed-compile
    2232        (setf state :recompiled)
    2233        (perform-with-restarts o c))
    2234       (t
    2235        (with-simple-restart
    2236            (try-recompiling "Try recompiling ~a"
    2237                             (component-name c))
    2238          (setf state :failed-compile)
    2239          (call-next-method)
    2240          (setf state :success))))))
    22412420
    22422421(defmethod perform ((operation load-op) (c static-file))
     
    22812460  (let ((source (component-pathname c)))
    22822461    (setf (component-property c 'last-loaded-as-source)
    2283           (and (load source)
     2462          (and (call-with-around-compile-hook c #'(lambda () (load source)))
    22842463               (get-universal-time)))))
    22852464
     
    23412520(defgeneric* perform-plan (plan &key))
    23422521
     2522;;;; Separating this into a different function makes it more forward-compatible
     2523(defun* cleanup-upgraded-asdf (old-version)
     2524  (let ((new-version (asdf:asdf-version)))
     2525    (unless (equal old-version new-version)
     2526      (cond
     2527        ((version-satisfies new-version old-version)
     2528         (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
     2529                       old-version new-version))
     2530        ((version-satisfies old-version new-version)
     2531         (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
     2532               old-version new-version))
     2533        (t
     2534         (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
     2535                       old-version new-version)))
     2536      (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
     2537        ;; Invalidate all systems but ASDF itself.
     2538        (setf *defined-systems* (make-defined-systems-table))
     2539        (register-system asdf)
     2540        ;; If we're in the middle of something, restart it.
     2541        (when *systems-being-defined*
     2542          (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
     2543            (clrhash *systems-being-defined*)
     2544            (dolist (s l) (find-system s nil))))
     2545        t))))
     2546
    23432547;;;; Try to upgrade of ASDF. If a different version was used, return T.
    23442548;;;; We need do that before we operate on anything that depends on ASDF.
     
    23472551    (handler-bind (((or style-warning warning) #'muffle-warning))
    23482552      (operate 'load-op :asdf :verbose nil))
    2349     (let ((new-version (asdf:asdf-version)))
    2350       (block nil
    2351         (cond
    2352           ((equal version new-version)
    2353            (return nil))
    2354           ((version-satisfies new-version version)
    2355            (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
    2356                          version new-version))
    2357           ((version-satisfies version new-version)
    2358            (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
    2359                  version new-version))
    2360           (t
    2361            (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
    2362                          version new-version)))
    2363         (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
    2364           ;; invalidate all systems but ASDF itself
    2365           (setf *defined-systems* (make-defined-systems-table))
    2366           (register-system asdf)
    2367           t)))))
     2553    (cleanup-upgraded-asdf version)))
    23682554
    23692555(defmethod perform-plan ((steps list) &key)
     
    23722558    (with-compilation-unit ()
    23732559      (loop :for (op . component) :in steps :do
    2374         (loop
    2375           (restart-case
    2376               (progn
    2377                 (perform-with-restarts op component)
    2378                 (return))
    2379             (retry ()
    2380               :report
    2381               (lambda (s)
    2382                 (format s (compatfmt "~@<Retry ~A.~@:>")
    2383                         (operation-description op component))))
    2384             (accept ()
    2385               :report
    2386               (lambda (s)
    2387                 (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
    2388                         (operation-description op component)))
    2389               (setf (gethash (type-of op)
    2390                              (component-operation-times component))
    2391                     (get-universal-time))
    2392               (return))))))))
     2560        (perform-with-restarts op component)))))
    23932561
    23942562(defmethod operate (operation-class system &rest args
     
    24472615  (setf (documentation 'oos 'function)
    24482616        (format nil
    2449                 "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
     2617                "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
    24502618                operate-docstring))
    24512619  (setf (documentation 'operate 'function)
     
    24582626  (apply 'operate 'load-op system args)
    24592627  t)
     2628
     2629(defun* load-systems (&rest systems)
     2630  (map () 'load-system systems))
    24602631
    24612632(defun* compile-system (system &rest args &key force verbose version
     
    24812652  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
    24822653
    2483 (defun* determine-system-pathname (pathname pathname-supplied-p)
     2654(defun* determine-system-pathname (pathname)
    24842655  ;; The defsystem macro calls us to determine
    24852656  ;; the pathname of a system as follows:
     
    24892660  (let* ((file-pathname (load-pathname))
    24902661         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
    2491     (or (and pathname-supplied-p
    2492              (merge-pathnames* (coerce-pathname pathname :type :directory)
    2493                                directory-pathname))
     2662    (or (and pathname (subpathname directory-pathname pathname :type :directory))
    24942663        directory-pathname
    24952664        (default-directory))))
     
    25172686        (progn
    25182687          (aif (assoc op2 (cdr first-op-tree))
    2519                (if (find c (cdr it))
     2688               (if (find c (cdr it) :test #'equal)
    25202689                   nil
    25212690                   (setf (cdr it) (cons c (cdr it))))
     
    25392708
    25402709(defun* sysdef-error-component (msg type name value)
    2541   (sysdef-error (concatenate 'string msg
    2542                              (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
     2710  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
    25432711                type name value))
    25442712
     
    26172785              version name parent)))
    26182786
    2619     (let* ((other-args (remove-keys
    2620                         '(components pathname default-component-class
    2621                           perform explain output-files operation-done-p
    2622                           weakly-depends-on
    2623                           depends-on serial in-order-to)
    2624                         rest))
    2625            (ret
    2626             (or (find-component parent name)
    2627                 (make-instance (class-for-type parent type)))))
     2787    (let* ((args (list* :name (coerce-name name)
     2788                        :pathname pathname
     2789                        :parent parent
     2790                        (remove-keys
     2791                         '(components pathname default-component-class
     2792                           perform explain output-files operation-done-p
     2793                           weakly-depends-on depends-on serial in-order-to)
     2794                         rest)))
     2795           (ret (find-component parent name)))
    26282796      (when weakly-depends-on
    2629         (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
     2797        (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
    26302798      (when *serial-depends-on*
    26312799        (push *serial-depends-on* depends-on))
    2632       (apply 'reinitialize-instance ret
    2633              :name (coerce-name name)
    2634              :pathname pathname
    2635              :parent parent
    2636              other-args)
     2800      (if ret ; preserve identity
     2801          (apply 'reinitialize-instance ret args)
     2802          (setf ret (apply 'make-instance (class-for-type parent type) args)))
    26372803      (component-pathname ret) ; eagerly compute the absolute pathname
    26382804      (when (typep ret 'module)
     
    26612827            (union-of-dependencies
    26622828             do-first
    2663              `((compile-op (load-op ,@depends-on)))))
     2829             `((compile-op (load-op ,@depends-on)))))
    26642830
    26652831      (%refresh-component-inline-methods ret rest)
    26662832      ret)))
    26672833
     2834(defun* reset-system (system &rest keys &key &allow-other-keys)
     2835  (change-class (change-class system 'proto-system) 'system)
     2836  (apply 'reinitialize-instance system keys))
     2837
    26682838(defun* do-defsystem (name &rest options
    2669                            &key (pathname nil pathname-arg-p) (class 'system)
     2839                           &key pathname (class 'system)
    26702840                           defsystem-depends-on &allow-other-keys)
    26712841  ;; The system must be registered before we parse the body,
     
    26782848    (let* ((name (coerce-name name))
    26792849           (registered (system-registered-p name))
    2680            (system (cdr (or registered
    2681                             (register-system (make-instance 'system :name name)))))
     2850           (registered! (if registered
     2851                            (rplaca registered (get-universal-time))
     2852                            (register-system (make-instance 'system :name name))))
     2853           (system (reset-system (cdr registered!)
     2854                                :name name :source-file (load-pathname)))
    26822855           (component-options (remove-keys '(:class) options)))
    2683       (%set-system-source-file (load-pathname) system)
    26842856      (setf (gethash name *systems-being-defined*) system)
    2685       (when registered
    2686         (setf (car registered) (get-universal-time)))
    2687       (map () 'load-system defsystem-depends-on)
     2857      (apply 'load-systems defsystem-depends-on)
    26882858      ;; We change-class (when necessary) AFTER we load the defsystem-dep's
    26892859      ;; since the class might not be defined as part of those.
     
    26942864       nil (list*
    26952865            :module name
    2696             :pathname (determine-system-pathname pathname pathname-arg-p)
     2866            :pathname (determine-system-pathname pathname)
    26972867            component-options)))))
    26982868
     
    27072877;;;; If the docstring is ambiguous, send a bug report.
    27082878;;;;
     2879;;;; WARNING! The function below is mostly dysfunctional.
     2880;;;; For instance, it will probably run fine on most implementations on Unix,
     2881;;;; which will hopefully use the shell /bin/sh (which we force in some cases)
     2882;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
     2883;;;; But behavior on Windows may vary wildly between implementations,
     2884;;;; either relying on your having installed a POSIX sh, or going through
     2885;;;; the CMD.EXE interpreter, for a totally different meaning, depending on
     2886;;;; what is easily expressible in said implementation.
     2887;;;;
    27092888;;;; We probably should move this functionality to its own system and deprecate
    27102889;;;; use of it from the asdf package. However, this would break unspecified
     
    27122891;;;; it, and even after it's been deprecated, we will support it for a few
    27132892;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
     2893;;;;
     2894;;;; As a suggested replacement which is portable to all ASDF-supported
     2895;;;; implementations and operating systems except Genera, I recommend
     2896;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its
     2897;;;; derivatives such as xcvb-driver:run-program/for-side-effects.
    27142898
    27152899(defun* run-shell-command (control-string &rest args)
     
    27272911    (multiple-value-bind (stdout stderr exit-code)
    27282912        (excl.osi:command-output
    2729          (format nil "~a -c \"~a\""
    2730                  #+mswindows "sh" #-mswindows "/bin/sh" command)
     2913         #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
     2914         #+mswindows command ; BEWARE!
    27312915         :input nil :whole nil
    27322916         #+mswindows :show-window #+mswindows :hide)
    2733       (asdf-message "~{~&; ~a~%~}~%" stderr)
    2734       (asdf-message "~{~&; ~a~%~}~%" stdout)
     2917      (asdf-message "~{~&~a~%~}~%" stderr)
     2918      (asdf-message "~{~&~a~%~}~%" stdout)
    27352919      exit-code)
    27362920
    2737     #+clisp                    ;XXX not exactly *verbose-out*, I know
    2738     (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)
     2921    #+clisp
     2922    ;; CLISP returns NIL for exit status zero.
     2923    (if *verbose-out*
     2924        (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
     2925                                    command))
     2926               (outstream (ext:run-shell-command new-command :output :stream :wait t)))
     2927            (multiple-value-bind (retval out-lines)
     2928                (unwind-protect
     2929                     (parse-clisp-shell-output outstream)
     2930                  (ignore-errors (close outstream)))
     2931              (asdf-message "~{~&~a~%~}~%" out-lines)
     2932              retval))
     2933        ;; there will be no output, just grab up the exit status
     2934        (or (ext:run-shell-command command :output nil :wait t) 0))
    27392935
    27402936    #+clozure
    27412937    (nth-value 1
    27422938               (ccl:external-process-status
    2743                 (ccl:run-program "/bin/sh" (list "-c" command)
    2744                                  :input nil :output *verbose-out*
    2745                                  :wait t)))
     2939                (ccl:run-program
     2940                 (cond
     2941                   ((os-unix-p) "/bin/sh")
     2942                   ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
     2943                   (t (error "Unsupported OS")))
     2944                 (if (os-unix-p) (list "-c" command) '())
     2945                 :input nil :output *verbose-out* :wait t)))
    27462946
    27472947    #+(or cmu scl)
     
    27492949     (ext:run-program
    27502950      "/bin/sh"
    2751       (list  "-c" command)
     2951      (list "-c" command)
    27522952      :input nil :output *verbose-out*))
    27532953
     2954    #+cormanlisp
     2955    (win32:system command)
     2956
    27542957    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    2755     (si:system command)
     2958    (ext:system command)
    27562959
    27572960    #+gcl
     
    27592962
    27602963    #+lispworks
    2761     (system:call-system-showing-output
    2762      command
    2763      :shell-type "/bin/sh"
    2764      :show-cmd nil
    2765      :prefix ""
    2766      :output-stream *verbose-out*)
     2964    (apply 'system:call-system-showing-output command
     2965           :show-cmd nil :prefix "" :output-stream *verbose-out*
     2966           (when (os-unix-p) '(:shell-type "/bin/sh")))
    27672967
    27682968    #+mcl
     
    27822982    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
    27832983    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
     2984
     2985#+clisp
     2986(defun* parse-clisp-shell-output (stream)
     2987  "Helper function for running shell commands under clisp.  Parses a specially-
     2988crafted output string to recover the exit status of the shell command and a
     2989list of lines of output."
     2990  (loop :with status-prefix = "ASDF-EXIT-STATUS "
     2991    :with prefix-length = (length status-prefix)
     2992    :with exit-status = -1 :with lines = ()
     2993    :for line = (read-line stream nil nil)
     2994    :while line :do (push line lines) :finally
     2995    (let* ((last (car lines))
     2996           (status (and last (>= (length last) prefix-length)
     2997                        (string-equal last status-prefix :end1 prefix-length)
     2998                        (parse-integer last :start prefix-length :junk-allowed t))))
     2999      (when status
     3000        (setf exit-status status)
     3001        (pop lines) (when (equal "" (car lines)) (pop lines)))
     3002      (return (values exit-status (reverse lines))))))
    27843003
    27853004;;;; ---------------------------------------------------------------------------
     
    27993018  (system-source-file x))
    28003019
     3020(defmethod system-source-file ((system system))
     3021  (%system-source-file system))
    28013022(defmethod system-source-file ((system-name string))
    2802   (system-source-file (find-system system-name)))
     3023  (%system-source-file (find-system system-name)))
    28033024(defmethod system-source-file ((system-name symbol))
    2804   (system-source-file (find-system system-name)))
     3025  (%system-source-file (find-system system-name)))
    28053026
    28063027(defun* system-source-directory (system-designator)
     
    28263047
    28273048(defun* system-relative-pathname (system name &key type)
    2828   (merge-pathnames*
    2829    (coerce-pathname name :type type)
    2830    (system-source-directory system)))
     3049  (subpathname (system-source-directory system) name :type type))
    28313050
    28323051
     
    28363055;;; produce a string to identify current implementation.
    28373056;;; Initially stolen from SLIME's SWANK, rewritten since.
    2838 ;;; The (car '(...)) idiom avoids unreachable code warnings.
    2839 
    2840 (defparameter *implementation-type*
    2841   (car '(#+abcl :abcl #+allegro :acl
    2842          #+clozure :ccl #+clisp :clisp #+cormanlisp :corman #+cmu :cmu
    2843          #+ecl :ecl #+gcl :gcl #+lispworks :lw #+mcl :mcl
    2844          #+sbcl :sbcl #+scl :scl #+symbolics :symbolic #+xcl :xcl)))
    2845 
    2846 (defparameter *operating-system*
    2847   (car '(#+cygwin :cygwin #+(or windows mswindows win32 mingw32) :win
    2848          #+(or linux linux-target) :linux ;; for GCL at least, must appear before :bsd.
    2849          #+(or macosx darwin darwin-target apple) :macosx ; also before :bsd
    2850          #+(or solaris sunos) :solaris
    2851          #+(or freebsd netbsd openbsd bsd) :bsd
    2852          #+unix :unix
    2853          #+genera :genera)))
    2854 
    2855 (defparameter *architecture*
    2856   (car '(#+(or amd64 x86-64 x86_64 x8664-target (and word-size=64 pc386)) :x64
    2857          #+(or x86 i386 i486 i586 i686 pentium3 pentium4 pc386 iapx386 x8632-target) :x86
    2858          #+hppa64 :hppa64 #+hppa :hppa
    2859          #+(or ppc64 ppc64-target) :ppc64
    2860          #+(or ppc32 ppc32-target ppc powerpc) :ppc32
    2861          #+sparc64 :sparc64 #+(or sparc32 sparc) :sparc32
    2862          #+(or arm arm-target) :arm
    2863          #+(or java java-1.4 java-1.5 java-1.6 java-1.7) :java
    2864          #+mipsel :mispel #+mipseb :mipseb #+mips :mips
    2865          #+alpha :alpha #+imach :imach)))
    2866 
    2867 (defparameter *lisp-version-string*
     3057;;; We're back to runtime checking, for the sake of e.g. ABCL.
     3058
     3059(defun* first-feature (features)
     3060  (dolist (x features)
     3061    (multiple-value-bind (val feature)
     3062        (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
     3063      (when (featurep feature) (return val)))))
     3064
     3065(defun implementation-type ()
     3066  (first-feature
     3067   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
     3068     :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl)))
     3069
     3070(defun operating-system ()
     3071  (first-feature
     3072   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
     3073     (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
     3074     (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
     3075     (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
     3076     :genera)))
     3077
     3078(defun architecture ()
     3079  (first-feature
     3080   '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
     3081     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
     3082     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
     3083     :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
     3084     :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
     3085     ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
     3086     ;; we may have to segregate the code still by architecture.
     3087     (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
     3088
     3089#+clozure
     3090(defun* ccl-fasl-version ()
     3091  ;; the fasl version is target-dependent from CCL 1.8 on.
     3092  (or (and (fboundp 'ccl::target-fasl-version)
     3093           (funcall 'ccl::target-fasl-version))
     3094      (and (boundp 'ccl::fasl-version)
     3095           (symbol-value 'ccl::fasl-version))
     3096      (error "Can't determine fasl version.")))
     3097
     3098(defun lisp-version-string ()
    28683099  (let ((s (lisp-implementation-version)))
    2869     (or
    2870      #+allegro
    2871      (format nil "~A~A~@[~A~]"
    2872              excl::*common-lisp-version-number*
    2873              ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
    2874              (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
    2875              ;; Note if not using International ACL
    2876              ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
    2877              (excl:ics-target-case (:-ics "8")))
    2878      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    2879      #+clisp
    2880      (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
    2881      #+clozure
    2882      (format nil "~d.~d-f~d" ; shorten for windows
    2883              ccl::*openmcl-major-version*
    2884              ccl::*openmcl-minor-version*
    2885              (logand (ccl:target-fasl-version) #xFF))
    2886      #+cmu (substitute #\- #\/ s)
    2887      #+ecl (format nil "~A~@[-~A~]" s
    2888                    (let ((vcs-id (ext:lisp-implementation-vcs-id)))
    2889                      (subseq vcs-id 0 (min (length vcs-id) 8))))
    2890      #+gcl (subseq s (1+ (position #\space s)))
    2891      #+genera
    2892      (multiple-value-bind (major minor) (sct:get-system-version "System")
    2893        (format nil "~D.~D" major minor))
    2894      #+mcl (subseq s 8) ; strip the leading "Version "
    2895      s)))
    2896 
    2897 (defun* implementation-type ()
    2898   *implementation-type*)
     3100    (car ; as opposed to OR, this idiom prevents some unreachable code warning
     3101     (list
     3102      #+allegro
     3103      (format nil "~A~A~@[~A~]"
     3104              excl::*common-lisp-version-number*
     3105              ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
     3106              (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
     3107              ;; Note if not using International ACL
     3108              ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     3109              (excl:ics-target-case (:-ics "8")))
     3110      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
     3111      #+clisp
     3112      (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
     3113      #+clozure
     3114      (format nil "~d.~d-f~d" ; shorten for windows
     3115              ccl::*openmcl-major-version*
     3116              ccl::*openmcl-minor-version*
     3117              (logand (ccl-fasl-version) #xFF))
     3118      #+cmu (substitute #\- #\/ s)
     3119      #+scl (format nil "~A~A" s
     3120                    ;; ANSI upper case vs lower case.
     3121                    (ecase ext:*case-mode* (:upper "") (:lower "l")))
     3122      #+ecl (format nil "~A~@[-~A~]" s
     3123                    (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     3124                      (subseq vcs-id 0 (min (length vcs-id) 8))))
     3125      #+gcl (subseq s (1+ (position #\space s)))
     3126      #+genera
     3127      (multiple-value-bind (major minor) (sct:get-system-version "System")
     3128        (format nil "~D.~D" major minor))
     3129      #+mcl (subseq s 8) ; strip the leading "Version "
     3130      s))))
    28993131
    29003132(defun* implementation-identifier ()
     
    29023134   #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
    29033135   (format nil "~(~a~@{~@[-~a~]~}~)"
    2904            (or *implementation-type* (lisp-implementation-type))
    2905            (or *lisp-version-string* (lisp-implementation-version))
    2906            (or *operating-system* (software-type))
    2907            (or *architecture* (machine-type)))))
     3136           (or (implementation-type) (lisp-implementation-type))
     3137           (or (lisp-version-string) (lisp-implementation-version))
     3138           (or (operating-system) (software-type))
     3139           (or (architecture) (machine-type)))))
    29083140
    29093141
     
    29113143;;; Generic support for configuration files
    29123144
    2913 (defparameter *inter-directory-separator*
    2914   #+asdf-unix #\:
    2915   #-asdf-unix #\;)
     3145(defun inter-directory-separator ()
     3146  (if (os-unix-p) #\: #\;))
    29163147
    29173148(defun* user-homedir ()
     
    29213152    #-mcl (user-homedir-pathname))))
    29223153
    2923 (defun* try-directory-subpath (x sub &key type)
    2924   (let* ((p (and x (ensure-directory-pathname x)))
    2925          (tp (and p (probe-file* p)))
    2926          (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))
    2927          (ts (and sp (probe-file* sp))))
    2928     (and ts (values sp ts))))
     3154(defun* ensure-absolute-pathname* (x fmt &rest args)
     3155  (and (plusp (length x))
     3156       (or (absolute-pathname-p x)
     3157           (cerror "ignore relative pathname"
     3158                   "Invalid relative pathname ~A~@[ ~?~]" x fmt args))
     3159       x))
     3160(defun* split-absolute-pathnames (x fmt &rest args)
     3161  (loop :for dir :in (split-string
     3162                      x :separator (string (inter-directory-separator)))
     3163    :do (apply 'ensure-absolute-pathname* dir fmt args)
     3164    :collect dir))
     3165(defun getenv-absolute-pathname (x &aux (s (getenv x)))
     3166  (ensure-absolute-pathname* s "from (getenv ~S)" x))
     3167(defun getenv-absolute-pathnames (x &aux (s (getenv x)))
     3168  (split-absolute-pathnames s "from (getenv ~S) = ~S" x s))
     3169
    29293170(defun* user-configuration-directories ()
    29303171  (let ((dirs
    2931          (flet ((try (x sub) (try-directory-subpath x sub)))
    2932            `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
    2933              ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
    2934                  :for dir :in (split-string dirs :separator ":")
    2935                  :collect (try dir "common-lisp/"))
    2936              #+asdf-windows
    2937              ,@`(,(try (or #+lispworks (sys:get-folder-path :local-appdata)
    2938                            (getenv "LOCALAPPDATA"))
    2939                        "common-lisp/config/")
     3172         `(,@(when (os-unix-p)
     3173               (cons
     3174                (subpathname* (getenv-absolute-pathname "XDG_CONFIG_HOME") "common-lisp/")
     3175                (loop :for dir :in (getenv-absolute-pathnames "XDG_CONFIG_DIRS")
     3176                  :collect (subpathname* dir "common-lisp/"))))
     3177           ,@(when (os-windows-p)
     3178               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
     3179                                    (getenv-absolute-pathname "LOCALAPPDATA"))
     3180                               "common-lisp/config/")
    29403181                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    2941                  ,(try (or #+lispworks (sys:get-folder-path :appdata)
    2942                            (getenv "APPDATA"))
    2943                            "common-lisp/config/"))
    2944              ,(try (user-homedir) ".config/common-lisp/")))))
    2945     (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
     3182                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
     3183                                    (getenv-absolute-pathname "APPDATA"))
     3184                                "common-lisp/config/")))
     3185           ,(subpathname (user-homedir) ".config/common-lisp/"))))
     3186    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
     3187                       :from-end t :test 'equal)))
     3188
    29463189(defun* system-configuration-directories ()
    2947   (remove-if
    2948    #'null
    2949    `(#+asdf-windows
    2950      ,(flet ((try (x sub) (try-directory-subpath x sub)))
    2951         ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    2952         (try (or #+lispworks (sys:get-folder-path :common-appdata)
    2953                  (getenv "ALLUSERSAPPDATA")
    2954                  (try (getenv "ALLUSERSPROFILE") "Application Data/"))
    2955              "common-lisp/config/"))
    2956      #+asdf-unix #p"/etc/common-lisp/")))
    2957 
    2958 (defun* in-first-directory (dirs x)
    2959   (loop :for dir :in dirs
    2960     :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
    2961 (defun* in-user-configuration-directory (x)
    2962   (in-first-directory (user-configuration-directories) x))
    2963 (defun* in-system-configuration-directory (x)
    2964   (in-first-directory (system-configuration-directories) x))
     3190  (cond
     3191    ((os-unix-p) '(#p"/etc/common-lisp/"))
     3192    ((os-windows-p)
     3193     (aif
     3194      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
     3195      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
     3196                        (getenv-absolute-pathname "ALLUSERSAPPDATA")
     3197                        (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/"))
     3198                    "common-lisp/config/")
     3199      (list it)))))
     3200
     3201(defun* in-first-directory (dirs x &key (direction :input))
     3202  (loop :with fun = (ecase direction
     3203                      ((nil :input :probe) 'probe-file*)
     3204                      ((:output :io) 'identity))
     3205    :for dir :in dirs
     3206    :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
     3207
     3208(defun* in-user-configuration-directory (x &key (direction :input))
     3209  (in-first-directory (user-configuration-directories) x :direction direction))
     3210(defun* in-system-configuration-directory (x &key (direction :input))
     3211  (in-first-directory (system-configuration-directories) x :direction direction))
    29653212
    29663213(defun* configuration-inheritance-directive-p (x)
     
    30723319  (flet ((try (x &rest sub) (and x `(,x ,@sub))))
    30733320    (or
    3074      (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
    3075      #+asdf-windows
    3076      (try (or #+lispworks (sys:get-folder-path :local-appdata)
    3077               (getenv "LOCALAPPDATA")
    3078               #+lispworks (sys:get-folder-path :appdata)
    3079               (getenv "APPDATA"))
    3080           "common-lisp" "cache" :implementation)
     3321     (try (getenv-absolute-pathname "XDG_CACHE_HOME") "common-lisp" :implementation)
     3322     (when (os-windows-p)
     3323       (try (or #+lispworks (sys:get-folder-path :local-appdata)
     3324                (getenv-absolute-pathname "LOCALAPPDATA")
     3325                #+lispworks (sys:get-folder-path :appdata)
     3326                (getenv-absolute-pathname "APPDATA"))
     3327            "common-lisp" "cache" :implementation))
    30813328     '(:home ".cache" "common-lisp" :implementation))))
    30823329
     
    32053452           (typep c '(or string pathname
    32063453                      (member :default-directory :*/ :**/ :*.*.*
    3207                         :implementation :implementation-type
    3208                         #+asdf-unix :uid)))))
     3454                        :implementation :implementation-type)))))
    32093455    (or (typep x 'boolean)
    32103456        (absolute-component-p x)
     
    32133459(defun* location-function-p (x)
    32143460  (and
    3215    (consp x)
    32163461   (length=n-p x 2)
    3217    (or (and (equal (first x) :function)
    3218             (typep (second x) 'symbol))
    3219        (and (equal (first x) 'lambda)
    3220             (cddr x)
    3221             (length=n-p (second x) 2)))))
     3462   (eq (car x) :function)
     3463   (or (symbolp (cadr x))
     3464       (and (consp (cadr x))
     3465            (eq (caadr x) 'lambda)
     3466            (length=n-p (cadadr x) 2)))))
    32223467
    32233468(defun* validate-output-translations-directive (directive)
     
    32663511      :with end = (length string)
    32673512      :with source = nil
    3268       :for i = (or (position *inter-directory-separator* string :start start) end) :do
     3513      :with separator = (inter-directory-separator)
     3514      :for i = (or (position separator string :start start) end) :do
    32693515      (let ((s (subseq string start i)))
    32703516        (cond
     
    33163562(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
    33173563
    3318 (defun* user-output-translations-pathname ()
    3319   (in-user-configuration-directory *output-translations-file*))
    3320 (defun* system-output-translations-pathname ()
    3321   (in-system-configuration-directory *output-translations-file*))
    3322 (defun* user-output-translations-directory-pathname ()
    3323   (in-user-configuration-directory *output-translations-directory*))
    3324 (defun* system-output-translations-directory-pathname ()
    3325   (in-system-configuration-directory *output-translations-directory*))
     3564(defun* user-output-translations-pathname (&key (direction :input))
     3565  (in-user-configuration-directory *output-translations-file* :direction direction))
     3566(defun* system-output-translations-pathname (&key (direction :input))
     3567  (in-system-configuration-directory *output-translations-file* :direction direction))
     3568(defun* user-output-translations-directory-pathname (&key (direction :input))
     3569  (in-user-configuration-directory *output-translations-directory* :direction direction))
     3570(defun* system-output-translations-directory-pathname (&key (direction :input))
     3571  (in-system-configuration-directory *output-translations-directory* :direction direction))
    33263572(defun* environment-output-translations ()
    33273573  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
     
    34463692
    34473693(defun* apply-output-translations (path)
     3694  #+cormanlisp (truenamize path) #-cormanlisp
    34483695  (etypecase path
    3449     #+cormanlisp (t (truenamize path))
    34503696    (logical-pathname
    34513697     path)
     
    34683714(defmethod output-files :around (operation component)
    34693715  "Translate output files, unless asked not to"
    3470   (declare (ignorable operation component))
     3716  operation component ;; hush genera, not convinced by declare ignorable(!)
    34713717  (values
    34723718   (multiple-value-bind (files fixedp) (call-next-method)
     
    34883734(defun* tmpize-pathname (x)
    34893735  (make-pathname
    3490    :name (format nil "ASDF-TMP-~A" (pathname-name x))
     3736   :name (strcat "ASDF-TMP-" (pathname-name x))
    34913737   :defaults x))
    34923738
     
    35523798     (centralize-lisp-binaries nil)
    35533799     (default-toplevel-directory
    3554          ;; Use ".cache/common-lisp" instead ???
    3555          (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
    3556                            (user-homedir)))
     3800         (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
    35573801     (include-per-user-information nil)
    35583802     (map-all-source-files (or #+(or ecl clisp) t nil))
     
    35803824
    35813825;;;; -----------------------------------------------------------------
    3582 ;;;; Windows shortcut support.  Based on:
    3583 ;;;;
    3584 ;;;; Jesse Hager: The Windows Shortcut File Format.
    3585 ;;;; http://www.wotsit.org/list.asp?fc=13
    3586 
    3587 #+(and asdf-windows (not clisp))
    3588 (progn
    3589 (defparameter *link-initial-dword* 76)
    3590 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
    3591 
    3592 (defun* read-null-terminated-string (s)
    3593   (with-output-to-string (out)
    3594     (loop :for code = (read-byte s)
    3595       :until (zerop code)
    3596       :do (write-char (code-char code) out))))
    3597 
    3598 (defun* read-little-endian (s &optional (bytes 4))
    3599   (loop :for i :from 0 :below bytes
    3600     :sum (ash (read-byte s) (* 8 i))))
    3601 
    3602 (defun* parse-file-location-info (s)
    3603   (let ((start (file-position s))
    3604         (total-length (read-little-endian s))
    3605         (end-of-header (read-little-endian s))
    3606         (fli-flags (read-little-endian s))
    3607         (local-volume-offset (read-little-endian s))
    3608         (local-offset (read-little-endian s))
    3609         (network-volume-offset (read-little-endian s))
    3610         (remaining-offset (read-little-endian s)))
    3611     (declare (ignore total-length end-of-header local-volume-offset))
    3612     (unless (zerop fli-flags)
    3613       (cond
    3614         ((logbitp 0 fli-flags)
    3615           (file-position s (+ start local-offset)))
    3616         ((logbitp 1 fli-flags)
    3617           (file-position s (+ start
    3618                               network-volume-offset
    3619                               #x14))))
    3620       (concatenate 'string
    3621         (read-null-terminated-string s)
    3622         (progn
    3623           (file-position s (+ start remaining-offset))
    3624           (read-null-terminated-string s))))))
    3625 
    3626 (defun* parse-windows-shortcut (pathname)
    3627   (with-open-file (s pathname :element-type '(unsigned-byte 8))
    3628     (handler-case
    3629         (when (and (= (read-little-endian s) *link-initial-dword*)
    3630                    (let ((header (make-array (length *link-guid*))))
    3631                      (read-sequence header s)
    3632                      (equalp header *link-guid*)))
    3633           (let ((flags (read-little-endian s)))
    3634             (file-position s 76)        ;skip rest of header
    3635             (when (logbitp 0 flags)
    3636               ;; skip shell item id list
    3637               (let ((length (read-little-endian s 2)))
    3638                 (file-position s (+ length (file-position s)))))
    3639             (cond
    3640               ((logbitp 1 flags)
    3641                 (parse-file-location-info s))
    3642               (t
    3643                 (when (logbitp 2 flags)
    3644                   ;; skip description string
    3645                   (let ((length (read-little-endian s 2)))
    3646                     (file-position s (+ length (file-position s)))))
    3647                 (when (logbitp 3 flags)
    3648                   ;; finally, our pathname
    3649                   (let* ((length (read-little-endian s 2))
    3650                          (buffer (make-array length)))
    3651                     (read-sequence buffer s)
    3652                     (map 'string #'code-char buffer)))))))
    3653       (end-of-file ()
    3654         nil)))))
    3655 
    3656 ;;;; -----------------------------------------------------------------
    36573826;;;; Source Registry Configuration, by Francois-Rene Rideau
    36583827;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
     
    36963865        :for p = (or (and (typep f 'logical-pathname) f)
    36973866                     (let* ((u (ignore-errors (funcall merger f))))
     3867                       ;; The first u avoids a cumbersome (truename u) error
    36983868                       (and u (equal (ignore-errors (truename u)) f) u)))
    36993869        :when p :collect p)
     
    37093879     directory entries
    37103880     #'(lambda (f)
    3711          (make-pathname :defaults directory :version (pathname-version f)
    3712                         :name (pathname-name f) :type (pathname-type f))))))
     3881         (make-pathname :defaults directory
     3882                        :name (pathname-name f) :type (ununspecific (pathname-type f))
     3883                        :version (ununspecific (pathname-version f)))))))
    37133884
    37143885(defun* directory-asd-files (directory)
     
    37193890         #-(or abcl cormanlisp genera xcl)
    37203891         (wild (merge-pathnames*
    3721                 #-(or abcl allegro cmu lispworks scl xcl)
     3892                #-(or abcl allegro cmu lispworks sbcl scl xcl)
    37223893                *wild-directory*
    3723                 #+(or abcl allegro cmu lispworks scl xcl) "*.*"
     3894                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
    37243895                directory))
    37253896         (dirs
     
    37313902          #+cormanlisp (cl::directory-subdirs directory)
    37323903          #+genera (fs:directory-list directory))
    3733          #+(or abcl allegro cmu genera lispworks scl xcl)
     3904         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
    37343905         (dirs (loop :for x :in dirs
    37353906                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
    37363907                          #+allegro (excl:probe-directory x)
    3737                           #+(or cmu scl) (directory-pathname-p x)
     3908                          #+(or cmu sbcl scl) (directory-pathname-p x)
    37383909                          #+genera (getf (cdr x) :directory)
    37393910                          #+lispworks (lw:file-directory-p x)
    37403911                 :when d :collect #+(or abcl allegro xcl) d
    37413912                                  #+genera (ensure-directory-pathname (first x))
    3742                                   #+(or cmu lispworks scl) x)))
     3913                                  #+(or cmu lispworks sbcl scl) x)))
    37433914    (filter-logical-directory-results
    37443915     directory dirs
     
    38143985      :with start = 0
    38153986      :with end = (length string)
    3816       :for pos = (position *inter-directory-separator* string :start start) :do
     3987      :with separator = (inter-directory-separator)
     3988      :for pos = (position separator string :start start) :do
    38173989      (let ((s (subseq string start (or pos end))))
    38183990        (flet ((check (dir)
     
    38604032    #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
    38614033    :inherit-configuration
    3862     #+cmu (:tree #p"modules:")))
     4034    #+cmu (:tree #p"modules:")
     4035    #+scl (:tree #p"file://modules/")))
    38634036(defun* default-source-registry ()
    3864   (flet ((try (x sub) (try-directory-subpath x sub)))
    3865     `(:source-registry
    3866       #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
    3867       (:directory ,(default-directory))
     4037  `(:source-registry
     4038    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
     4039    (:directory ,(default-directory))
    38684040      ,@(loop :for dir :in
    3869           `(#+asdf-unix
    3870             ,@`(,(or (getenv "XDG_DATA_HOME")
    3871                      (try (user-homedir) ".local/share/"))
    3872                 ,@(split-string (or (getenv "XDG_DATA_DIRS")
    3873                                     "/usr/local/share:/usr/share")
    3874                                 :separator ":"))
    3875             #+asdf-windows
    3876             ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata)
    3877                      (getenv "LOCALAPPDATA"))
    3878                 ,(or #+lispworks (sys:get-folder-path :appdata)
    3879                      (getenv "APPDATA"))
    3880                 ,(or #+lispworks (sys:get-folder-path :common-appdata)
    3881                      (getenv "ALLUSERSAPPDATA")
    3882                      (try (getenv "ALLUSERSPROFILE") "Application Data/"))))
    3883           :collect `(:directory ,(try dir "common-lisp/systems/"))
    3884           :collect `(:tree ,(try dir "common-lisp/source/")))
    3885       :inherit-configuration)))
    3886 (defun* user-source-registry ()
    3887   (in-user-configuration-directory *source-registry-file*))
    3888 (defun* system-source-registry ()
    3889   (in-system-configuration-directory *source-registry-file*))
    3890 (defun* user-source-registry-directory ()
    3891   (in-user-configuration-directory *source-registry-directory*))
    3892 (defun* system-source-registry-directory ()
    3893   (in-system-configuration-directory *source-registry-directory*))
     4041          `(,@(when (os-unix-p)
     4042                `(,(or (getenv-absolute-pathname "XDG_DATA_HOME")
     4043                       (subpathname (user-homedir) ".local/share/"))
     4044                  ,@(or (getenv-absolute-pathnames "XDG_DATA_DIRS")
     4045                        '("/usr/local/share" "/usr/share"))))
     4046            ,@(when (os-windows-p)
     4047                `(,(or #+lispworks (sys:get-folder-path :local-appdata)
     4048                       (getenv-absolute-pathname "LOCALAPPDATA"))
     4049                  ,(or #+lispworks (sys:get-folder-path :appdata)
     4050                       (getenv-absolute-pathname "APPDATA"))
     4051                  ,(or #+lispworks (sys:get-folder-path :common-appdata)
     4052                       (getenv-absolute-pathname "ALLUSERSAPPDATA")
     4053                       (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/")))))
     4054          :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
     4055          :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
     4056      :inherit-configuration))
     4057(defun* user-source-registry (&key (direction :input))
     4058  (in-user-configuration-directory *source-registry-file* :direction direction))
     4059(defun* system-source-registry (&key (direction :input))
     4060  (in-system-configuration-directory *source-registry-file* :direction direction))
     4061(defun* user-source-registry-directory (&key (direction :input))
     4062  (in-user-configuration-directory *source-registry-directory* :direction direction))
     4063(defun* system-source-registry-directory (&key (direction :input))
     4064  (in-system-configuration-directory *source-registry-directory* :direction direction))
    38944065(defun* environment-source-registry ()
    38954066  (getenv "CL_SOURCE_REGISTRY"))
     
    39664137          ,@*default-source-registries*)
    39674138        :register #'(lambda (directory &key recurse exclude)
    3968                       (collect (list directory :recurse recurse :exclude exclude)))))
    3969      :test 'equal :from-end t)))
    3970 
    3971 ;; Will read the configuration and initialize all internal variables,
    3972 ;; and return the new configuration.
     4139                      (collect (list directory :recurse recurse :exclude exclude))))))
     4140   :test 'equal :from-end t))
     4141
     4142;; Will read the configuration and initialize all internal variables.
    39734143(defun* compute-source-registry (&optional parameter (registry *source-registry*))
    39744144  (dolist (entry (flatten-source-registry parameter))
     
    40424212#+ecl
    40434213(progn
    4044   (setf *compile-op-compile-file-function*
    4045         (lambda (input-file &rest keys &key output-file &allow-other-keys)
    4046           (declare (ignore output-file))
    4047           (multiple-value-bind (object-file flags1 flags2)
    4048               (apply 'compile-file* input-file :system-p t keys)
    4049             (values (and object-file
    4050                          (c::build-fasl (compile-file-pathname object-file :type :fasl)
    4051                                         :lisp-files (list object-file))
    4052                          object-file)
    4053                     flags1
    4054                     flags2))))
     4214  (setf *compile-op-compile-file-function* 'ecl-compile-file)
     4215
     4216  (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys)
     4217    (if (use-ecl-byte-compiler-p)
     4218        (apply 'compile-file* input-file keys)
     4219        (multiple-value-bind (object-file flags1 flags2)
     4220            (apply 'compile-file* input-file :system-p t keys)
     4221          (values (and object-file
     4222                       (c::build-fasl (compile-file-pathname object-file :type :fasl)
     4223                                      :lisp-files (list object-file))
     4224                       object-file)
     4225                  flags1
     4226                  flags2))))
    40554227
    40564228  (defmethod output-files ((operation compile-op) (c cl-source-file))
    40574229    (declare (ignorable operation))
    4058     (let ((p (lispize-pathname (component-pathname c))))
    4059       (list (compile-file-pathname p :type :object)
    4060             (compile-file-pathname p :type :fasl))))
     4230    (let* ((p (lispize-pathname (component-pathname c)))
     4231           (f (compile-file-pathname p :type :fasl)))
     4232      (if (use-ecl-byte-compiler-p)
     4233          (list f)
     4234          (list (compile-file-pathname p :type :object) f))))
    40614235
    40624236  (defmethod perform ((o load-op) (c cl-source-file))
     
    40644238         (loop :for i :in (input-files o c)
    40654239           :unless (string= (pathname-type i) "fas")
    4066            :collect (compile-file-pathname (lispize-pathname i))))))
     4240               :collect (compile-file-pathname (lispize-pathname i))))))
    40674241
    40684242;;;; -----------------------------------------------------------------
     
    40744248  (handler-bind
    40754249      ((style-warning #'muffle-warning)
     4250       #-genera
    40764251       (missing-component (constantly nil))
    40774252       (error #'(lambda (e)
     
    40914266            #+clisp ,x
    40924267            #+clozure ccl:*module-provider-functions*
    4093             #+cmu ext:*module-provider-functions*
    4094             #+ecl si:*module-provider-functions*
     4268            #+(or cmu ecl) ext:*module-provider-functions*
    40954269            #+sbcl sb-ext:*module-provider-functions*))))
    40964270
Note: See TracChangeset for help on using the changeset viewer.