Changeset 13702


Ignore:
Timestamp:
12/18/11 15:25:19 (10 years ago)
Author:
Mark Evenson
Message:

asdf-2.019 with patch to get around ticket #181.

Location:
trunk/abcl
Files:
2 edited

Legend:

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

    r13655 r13702  
    896896system-definition := ( defsystem system-designator @var{system-option}* )
    897897
    898 system-option := :defsystem-depends-on system-list
     898system-option := :defsystem-depends-on system-list
     899                 | :class class-name (see discussion below)
    899900                 | module-option
    900901                 | option
     
    959960the current package @code{my-system-asd} can be specified as
    960961@code{:my-component-type}, or @code{my-component-type}.
     962
     963@subsection System class names
     964
     965A system class name will be looked up in the same way as a Component
     966type (see above).  Typically, one will not need to specify a system
     967class name, unless using a non-standard system class defined in some
     968ASDF extension, typically loaded through @code{DEFSYSTEM-DEPENDS-ON},
     969see below.  For such class names in the ASDF package, we recommend that
     970the @code{:class} option be specified using a keyword symbol, such as
     971
     972@example
     973:class :MY-NEW-SYSTEM-SUBCLASS
     974@end example
     975
     976This practice will ensure that package name conflicts are avoided.
     977Otherwise, the symbol @code{MY-NEW-SYSTEM-SUBCLASS} will be read into
     978the current package @emph{before} it has been exported from the ASDF
     979extension loaded by @code{:defsystem-depends-on}, causing a name
     980conflict in the current package.
    961981
    962982@subsection Defsystem depends on
     
    28312851
    28322852When declaring a component (system, module, file),
    2833 you can specify a keyword argument @code{:around-compile some-symbol}.
    2834 If left unspecified, the value will be inherited from the parent component if any,
    2835 or with a default of @code{nil} if no value is specified in any transitive parent.
    2836 
    2837 The argument must be a either fbound symbol or @code{nil}.
     2853you can specify a keyword argument @code{:around-compile function}.
     2854If left unspecified,
     2855the value will be inherited from the parent component if any,
     2856or with a default of @code{nil}
     2857if no value is specified in any transitive parent.
     2858
     2859The argument must be a either @code{nil}, a fbound symbol,
     2860a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk) ...)})
     2861a function object (e.g. using @code{#.#'} but that's discouraged
     2862because it prevents the introspection done by e.g. asdf-dependency-grovel),
     2863or a string that when read yields a symbol or a lambda-expression.
    28382864@code{nil} means the normal compile-file function will be called.
    2839 A symbol means the function fbound to it will be called with a single argument,
    2840 a thunk that calls the compile-file function;
    2841 the function you specify must then funcall that thunk
    2842 inside whatever wrapping you want.
     2865A non-nil value designates a function of one argument
     2866that will be called with a thunk for calling
     2867the compile-file function with proper arguments.
     2868
     2869Note that by using a string, you may reference
     2870a function, symbol and/or package
     2871that will only be created later during the build, but
     2872isn't yet present at the time the defsystem form is evaluated.
     2873However, if your entire system is using such a hook, you may have to
     2874explicitly override the hook with @code{nil} for all the modules and files
     2875that are compiled before the hook is defined.
    28432876
    28442877Using this hook, you may achieve such effects as:
     
    36503683@end lisp
    36513684
     3685@comment FIXME: Add a FAQ about how to use a new system class...
     3686
    36523687
    36533688@node  TODO list, Inspiration, FAQ, Top
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r13692 r13702  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.018: Another System Definition Facility.
     2;;; This is ASDF 2.019: 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*
     
    8787  ;; Strip out formatting that is not supported on Genera.
    8888  ;; Has to be inside the eval-when to make Lispworks happy (!)
     89  (defun strcat (&rest strings)
     90    (apply 'concatenate 'string strings))
    8991  (defmacro compatfmt (format)
    9092    #-(or gcl genera) format
     
    9597       #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
    9698      (loop :for found = (search unsupported format) :while found :do
    97         (setf format
    98               (concatenate 'simple-string
    99                            (subseq format 0 found) replacement
    100                            (subseq format (+ found (length unsupported)))))))
     99        (setf format (strcat (subseq format 0 found) replacement
     100                             (subseq format (+ found (length unsupported)))))))
    101101    format)
    102102  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
     
    108108         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    109109         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    110          (asdf-version "2.018")
     110         (asdf-version "2.019")
    111111         (existing-asdf (find-class 'component nil))
    112112         (existing-version *asdf-version*)
     
    186186                     (push sym formerly-exported-symbols)))
    187187               (loop :for sym :in export :do
    188                  (unless (member sym bothly-exported-symbols :test 'string-equal)
     188                 (unless (member sym bothly-exported-symbols :test 'equal)
    189189                   (push sym newly-exported-symbols)))
    190190               (loop :for user :in (package-used-by-list package)
     
    227227           :unintern
    228228           (#:*asdf-revision* #:around #:asdf-method-combination
    229             #:split #:make-collector
     229            #:split #:make-collector #:do-dep #:do-one-dep
     230            #:resolve-relative-location-component #:resolve-absolute-location-component
    230231            #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
    231232           :export
    232            (#:defsystem #:oos #:operate #:find-system #:run-shell-command
     233           (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
    233234            #:system-definition-pathname #:with-system-definitions
    234             #:search-for-system-definition #:find-component ; miscellaneous
    235             #:compile-system #:load-system #:test-system #:clear-system
    236             #:compile-op #:load-op #:load-source-op
    237             #:test-op
    238             #:operation               ; operations
    239             #:feature                 ; sort-of operation
    240             #:version                 ; metaphorically sort-of an operation
    241             #:version-satisfies
     235            #:search-for-system-definition #:find-component #:component-find-path
     236            #:compile-system #:load-system #:load-systems #:test-system #:clear-system
     237            #:operation #:compile-op #:load-op #:load-source-op #:test-op
     238            #:feature #:version #:version-satisfies
    242239            #:upgrade-asdf
    243240            #:implementation-identifier #:implementation-type
    244 
    245             #:input-files #:output-files #:output-file #:perform ; operation methods
     241            #:input-files #:output-files #:output-file #:perform
    246242            #:operation-done-p #:explain
    247243
     
    335331            #:system-registered-p
    336332            #:asdf-message
     333            #:user-output-translations-pathname
     334            #:system-output-translations-pathname
     335            #:user-output-translations-directory-pathname
     336            #:system-output-translations-directory-pathname
     337            #:user-source-registry
     338            #:system-source-registry
     339            #:user-source-registry-directory
     340            #:system-source-registry-directory
    337341
    338342            ;; Utilities
    339343            #:absolute-pathname-p
    340344            ;; #:aif #:it
    341             ;; #:appendf
     345            ;; #:appendf #:orf
    342346            #:coerce-name
    343347            #:directory-pathname-p
     
    347351            ;; #:length=n-p
    348352            ;; #:find-symbol*
    349             #:merge-pathnames*
    350             #:coerce-pathname
    351             #:subpathname
     353            #:merge-pathnames* #:coerce-pathname #:subpathname
    352354            #:pathname-directory-pathname
    353355            #:read-file-forms
     
    412414                condition-format condition-location
    413415                coerce-name)
     416         (ftype (function (&optional t) (values)) initialize-source-registry)
    414417         #-(or cormanlisp gcl-pre2.7)
    415418         (ftype (function (t t) t) (setf module-components-by-name)))
     
    420423(progn
    421424  (deftype logical-pathname () nil)
    422   (defun* make-broadcast-stream () *error-output*)
    423   (defun* file-namestring (p)
     425  (defun make-broadcast-stream () *error-output*)
     426  (defun file-namestring (p)
    424427    (setf p (pathname p))
    425428    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
     
    521524              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
    522525
     526(defun* ununspecific (x)
     527  (if (eq x :unspecific) nil x))
     528
    523529(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    524530  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
     
    539545         (type (or (pathname-type specified) (pathname-type defaults)))
    540546         (version (or (pathname-version specified) (pathname-version defaults))))
    541     (labels ((ununspecific (x)
    542                (if (eq x :unspecific) nil x))
    543              (unspecific-handler (p)
     547    (labels ((unspecific-handler (p)
    544548               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
    545549      (multiple-value-bind (host device directory unspecific-handler)
     
    892896        (port (ext:pathname-port pathname))
    893897        (directory (pathname-directory pathname)))
    894     (flet ((not-unspecific (component)
    895              (and (not (eq component :unspecific)) component)))
    896       (cond ((or (not-unspecific port)
    897                  (and (not-unspecific host) (plusp (length host)))
    898                  (not-unspecific scheme))
    899              (let ((prefix ""))
    900                (when (not-unspecific port)
    901                  (setf prefix (format nil ":~D" port)))
    902                (when (and (not-unspecific host) (plusp (length host)))
    903                  (setf prefix (concatenate 'string host prefix)))
    904                (setf prefix (concatenate 'string ":" prefix))
    905                (when (not-unspecific scheme)
    906                (setf prefix (concatenate 'string scheme prefix)))
    907                (assert (and directory (eq (first directory) :absolute)))
    908                (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
    909                               :defaults pathname)))
    910             (t
    911              pathname)))))
     898    (if (or (ununspecific port)
     899            (and (ununspecific host) (plusp (length host)))
     900            (ununspecific scheme))
     901        (let ((prefix ""))
     902          (when (ununspecific port)
     903            (setf prefix (format nil ":~D" port)))
     904          (when (and (ununspecific host) (plusp (length host)))
     905            (setf prefix (strcat host prefix)))
     906          (setf prefix (strcat ":" prefix))
     907          (when (ununspecific scheme)
     908            (setf prefix (strcat scheme prefix)))
     909          (assert (and directory (eq (first directory) :absolute)))
     910          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
     911                         :defaults pathname)))
     912    pathname))
    912913
    913914;;;; -------------------------------------------------------------------------
     
    11721173               :initform nil)))
    11731174
    1174 ;;; I believe that the following could probably be more efficiently done
    1175 ;;; by a primary method that invokes SHARED-INITIALIZE in a way that would
    1176 ;;; appropriately pass the slots to have their initforms re-applied, but I
    1177 ;;; do not know how to write such a method. [2011/09/02:rpg]
    1178 (defmethod reinitialize-instance :after ((obj component) &rest initargs
    1179                                          &key (version nil version-suppliedp)
    1180                                               (description nil description-suppliedp)
    1181                                               (long-description nil
    1182                                                                 long-description-suppliedp)
    1183                                               (load-dependencies nil
    1184                                                                  ld-suppliedp)
    1185                                               in-order-to
    1186                                               do-first
    1187                                               inline-methods
    1188                                               parent
    1189                                               properties)
    1190   "We reuse component objects from previously-existing systems, so we need to
    1191 make sure we clear them thoroughly."
    1192   (declare (ignore initargs load-dependencies
    1193                    long-description description version))
    1194   ;; this is a cache and should be cleared
    1195   (slot-makunbound obj 'absolute-pathname)
    1196   ;; component operation times are no longer valid when the component changes
    1197   (clrhash (component-operation-times obj))
    1198   (unless version-suppliedp (slot-makunbound obj 'version))
    1199   (unless description-suppliedp
    1200     (slot-makunbound obj 'description))
    1201   (unless long-description-suppliedp
    1202     (slot-makunbound obj 'long-description))
    1203   ;; replicate the logic of the initforms...
    1204   (unless ld-suppliedp
    1205     (setf (component-load-dependencies obj) nil))
    1206   (setf (component-in-order-to obj) in-order-to
    1207         (component-do-first obj) do-first
    1208         (component-inline-methods obj) inline-methods
    1209         (slot-value obj 'parent) parent
    1210         (slot-value obj 'properties) properties))
    1211 
    1212 
    12131175(defun* component-find-path (component)
    12141176  (reverse
     
    12831245    :accessor module-default-component-class)))
    12841246
    1285 ;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
    1286 ;;; [2011/09/02:rpg]
    1287 (defmethod reinitialize-instance :after ((obj module) &rest initargs &key)
    1288   "Clear MODULE's slots so it can be reused."
    1289   (slot-makunbound obj 'components-by-name)
    1290   ;; this may be a more elegant approach than in the
    1291   ;; COMPONENT method [2011/09/02:rpg]
    1292   (loop :for (initarg slot-name default) :in
    1293         `((:components components nil)
    1294           (:if-component-dep-fails if-component-dep-fails :fail)
    1295           (:default-component-class default-component-class
    1296               ,*default-component-class*))
    1297         :unless (member initarg initargs)
    1298         :do (setf (slot-value obj slot-name) default)))
    1299 
    13001247(defun* component-parent-pathname (component)
    13011248  ;; No default anymore (in particular, no *default-pathname-defaults*).
     
    13311278  new-value)
    13321279
    1333 (defclass system (module)
     1280(defclass proto-system () ; slots to keep when resetting a system
     1281  ;; To preserve identity for all objects, we'd need keep the components slots
     1282  ;; but also to modify parse-component-form to reset the recycled objects.
     1283  ((name) #|(components) (components-by-names)|#))
     1284
     1285(defclass system (module proto-system)
    13341286  (;; description and long-description are now available for all component's,
    13351287   ;; but now also inherited from component, but we add the legacy accessor
     
    13431295                :writer %set-system-source-file)
    13441296   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
    1345 
    1346 ;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
    1347 ;;; [2011/09/02:rpg]
    1348 (defmethod reinitialize-instance :after ((obj system) &rest initargs &key)
    1349   "Clear SYSTEM's slots so it can be reused."
    1350   ;; note that SYSTEM-SOURCE-FILE is very specially handled,
    1351   ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and
    1352   ;; not squash it.  SYSTEM COMPONENTS are handled very specially,
    1353   ;; because they are always, effectively, reused, since the system component
    1354   ;; is made early in DO-DEFSYSTEM, instead of being made later, in
    1355   ;; PARSE-COMPONENT-FORM [2011/09/02:rpg]
    1356   (loop :for (initarg slot-name) :in
    1357         `((:author author)
    1358           (:maintainer maintainer)
    1359           (:licence licence)
    1360           (:defsystem-depends-on defsystem-depends-on))
    1361         :unless (member initarg initargs)
    1362         :do (slot-makunbound obj slot-name)))
    13631297
    13641298;;;; -------------------------------------------------------------------------
     
    14491383                              network-volume-offset
    14501384                              #x14))))
    1451       (concatenate 'string
    1452         (read-null-terminated-string s)
    1453         (progn
    1454           (file-position s (+ start remaining-offset))
    1455           (read-null-terminated-string s))))))
     1385      (strcat (read-null-terminated-string s)
     1386              (progn
     1387                (file-position s (+ start remaining-offset))
     1388                (read-null-terminated-string s))))))
    14561389
    14571390(defun* parse-windows-shortcut (pathname)
     
    15401473;;; convention that functions in this list are prefixed SYSDEF-
    15411474
    1542 (defparameter *system-definition-search-functions*
    1543   '(sysdef-central-registry-search
    1544     sysdef-source-registry-search
    1545     sysdef-find-asdf))
     1475(defvar *system-definition-search-functions* '())
     1476
     1477(setf *system-definition-search-functions*
     1478      (append
     1479       ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
     1480       (remove 'contrib-sysdef-search *system-definition-search-functions*)
     1481       ;; Tuck our defaults at the end of the list if they were absent.
     1482       ;; This is imperfect, in case they were removed on purpose,
     1483       ;; but then it will be the responsibility of whoever does that
     1484       ;; to upgrade asdf before he does such a thing rather than after.
     1485       (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
     1486                  '(sysdef-central-registry-search
     1487                    sysdef-source-registry-search
     1488                    sysdef-find-asdf))))
    15461489
    15471490(defun* search-for-system-definition (system)
    1548   (let ((system-name (coerce-name system)))
    1549     (some #'(lambda (x) (funcall x system-name))
    1550           (cons 'find-system-if-being-defined *system-definition-search-functions*))))
     1491  (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
     1492        (cons 'find-system-if-being-defined
     1493              *system-definition-search-functions*)))
    15511494
    15521495(defvar *central-registry* nil
     
    15981541               (make-pathname
    15991542                :defaults defaults :version :newest :case :local
    1600                 :name (concatenate 'string name ".asd")
     1543                :name (strcat name ".asd")
    16011544                :type "lnk")))
    16021545          (when (probe-file* shortcut)
     
    16721615
    16731616(defmethod find-system ((name null) &optional (error-p t))
     1617  (declare (ignorable name))
    16741618  (when error-p
    16751619    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
     
    16911635        (funcall thunk))))
    16921636
    1693 (defmacro with-system-definitions (() &body body)
     1637(defmacro with-system-definitions ((&optional) &body body)
    16941638  `(call-with-system-definitions #'(lambda () ,@body)))
    16951639
     
    17071651                   (*default-pathname-defaults*
    17081652                    (pathname-directory-pathname pathname)))
    1709                ;;; XXX Under ABCL, if the PATHNAME is a JAR-PATHNAME the
    1710                ;;; MERGE-PATHNAMES are perhaps a bit wonky.
     1653               ;;; XXX Kludge for ABCL ticket #181
    17111654               #+abcl
    17121655               (when (ext:pathname-jar-p pathname)
     
    17181661        (delete-package package)))))
    17191662
    1720 (defmethod find-system ((name string) &optional (error-p t))
    1721   (with-system-definitions ()
    1722     (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    1723            (previous (cdr in-memory))
    1724            (previous (and (typep previous 'system) previous))
    1725            (previous-time (car in-memory))
     1663(defun* locate-system (name)
     1664  "Given a system NAME designator, try to locate where to load the system from.
     1665Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
     1666FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
     1667FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
     1668PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system.
     1669PREVIOUS when not null is a previously loaded SYSTEM object of same name.
     1670PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
     1671  (let* ((name (coerce-name name))
     1672         (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
     1673         (previous (cdr in-memory))
     1674         (previous (and (typep previous 'system) previous))
     1675         (previous-time (car in-memory))
    17261676           (found (search-for-system-definition name))
    1727            (found-system (and (typep found 'system) found))
    1728            (pathname (or (and (typep found '(or pathname string)) (pathname found))
    1729                          (and found-system (system-source-file found-system))
    1730                          (and previous (system-source-file previous)))))
     1677         (found-system (and (typep found 'system) found))
     1678         (pathname (or (and (typep found '(or pathname string)) (pathname found))
     1679                       (and found-system (system-source-file found-system))
     1680                       (and previous (system-source-file previous))))
     1681         (foundp (and (or found-system pathname previous) t)))
     1682    (check-type found (or null pathname system))
     1683    (when foundp
    17311684      (setf pathname (resolve-symlinks* pathname))
    17321685      (when (and pathname (not (absolute-pathname-p pathname)))
     
    17381691        (%set-system-source-file pathname previous)
    17391692        (setf previous-time nil))
    1740       (when (and found-system (not previous))
    1741         (register-system found-system))
    1742       (when (and pathname
    1743                  (or (not previous-time)
    1744                      ;; don't reload if it's already been loaded,
    1745                      ;; or its filestamp is in the future which means some clock is skewed
    1746                      ;; and trying to load might cause an infinite loop.
    1747                      (< previous-time (safe-file-write-date pathname) (get-universal-time))))
    1748         (load-sysdef name pathname))
    1749       (let ((in-memory (system-registered-p name))) ; try again after loading from disk
    1750         (cond
    1751           (in-memory
    1752            (when pathname
    1753              (setf (car in-memory) (safe-file-write-date pathname)))
    1754            (cdr in-memory))
    1755           (error-p
    1756            (error 'missing-component :requires name)))))))
     1693      (values foundp found-system pathname previous previous-time))))
     1694
     1695(defmethod find-system ((name string) &optional (error-p t))
     1696  (with-system-definitions ()
     1697    (loop
     1698      (restart-case
     1699          (multiple-value-bind (foundp found-system pathname previous previous-time)
     1700              (locate-system name)
     1701            (declare (ignore foundp))
     1702            (when (and found-system (not previous))
     1703              (register-system found-system))
     1704            (when (and pathname
     1705                       (or (not previous-time)
     1706                           ;; don't reload if it's already been loaded,
     1707                           ;; or its filestamp is in the future which means some clock is skewed
     1708                           ;; and trying to load might cause an infinite loop.
     1709                           (< previous-time (safe-file-write-date pathname) (get-universal-time))))
     1710              (load-sysdef name pathname))
     1711            (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
     1712              (return
     1713                (cond
     1714                  (in-memory
     1715                   (when pathname
     1716                     (setf (car in-memory) (safe-file-write-date pathname)))
     1717                   (cdr in-memory))
     1718                  (error-p
     1719                   (error 'missing-component :requires name))))))
     1720        (reinitialize-source-registry-and-retry ()
     1721          :report (lambda (s)
     1722                    (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
     1723          (initialize-source-registry))))))
    17571724
    17581725(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
     
    18801847                                  (pathname-directory-pathname pathname))))
    18811848
    1882 (defun* try-subpathname (pathname subpath &key type)
    1883   (let* ((sp (and pathname (probe-file* pathname)
    1884                   (subpathname pathname subpath :type type)))
    1885          (ts (and sp (probe-file* sp))))
    1886     (and ts (values sp ts))))
    1887 
     1849(defun subpathname* (pathname subpath &key type)
     1850  (and pathname
     1851       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
    18881852
    18891853;;;; -------------------------------------------------------------------------
     
    19891953
    19901954(defmethod component-self-dependencies ((o operation) (c component))
    1991   (let ((all-deps (component-depends-on o c)))
    1992     (remove-if-not #'(lambda (x)
    1993                        (member (component-name c) (cdr x) :test #'string=))
    1994                    all-deps)))
     1955  (remove-if-not
     1956   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
     1957   (component-depends-on o c)))
    19951958
    19961959(defmethod input-files ((operation operation) (c component))
     
    23642327     (around-compile-hook (component-parent c)))))
    23652328
     2329(defun ensure-function (fun &key (package :asdf))
     2330  (etypecase fun
     2331    ((or symbol function) fun)
     2332    (cons (eval `(function ,fun)))
     2333    (string (eval `(function ,(with-standard-io-syntax
     2334                               (let ((*package* (find-package package)))
     2335                                 (read-from-string fun))))))))
     2336
    23662337(defmethod call-with-around-compile-hook ((c component) thunk)
    23672338  (let ((hook (around-compile-hook c)))
    23682339    (if hook
    2369         (funcall hook thunk)
     2340        (funcall (ensure-function hook) thunk)
    23702341        (funcall thunk))))
    23712342
     
    25532524(defgeneric* perform-plan (plan &key))
    25542525
     2526;;;; Separating this into a different function makes it more forward-compatible
     2527(defun* cleanup-upgraded-asdf (old-version)
     2528  (let ((new-version (asdf:asdf-version)))
     2529    (unless (equal old-version new-version)
     2530      (cond
     2531        ((version-satisfies new-version old-version)
     2532         (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
     2533                       old-version new-version))
     2534        ((version-satisfies old-version new-version)
     2535         (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
     2536               old-version new-version))
     2537        (t
     2538         (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
     2539                       old-version new-version)))
     2540      (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
     2541        ;; Invalidate all systems but ASDF itself.
     2542        (setf *defined-systems* (make-defined-systems-table))
     2543        (register-system asdf)
     2544        ;; If we're in the middle of something, restart it.
     2545        (when *systems-being-defined*
     2546          (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
     2547            (clrhash *systems-being-defined*)
     2548            (dolist (s l) (find-system s nil))))
     2549        t))))
     2550
    25552551;;;; Try to upgrade of ASDF. If a different version was used, return T.
    25562552;;;; We need do that before we operate on anything that depends on ASDF.
     
    25592555    (handler-bind (((or style-warning warning) #'muffle-warning))
    25602556      (operate 'load-op :asdf :verbose nil))
    2561     (let ((new-version (asdf:asdf-version)))
    2562       (block nil
    2563         (cond
    2564           ((equal version new-version)
    2565            (return nil))
    2566           ((version-satisfies new-version version)
    2567            (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
    2568                          version new-version))
    2569           ((version-satisfies version new-version)
    2570            (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
    2571                  version new-version))
    2572           (t
    2573            (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
    2574                          version new-version)))
    2575         (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
    2576           ;; invalidate all systems but ASDF itself
    2577           (setf *defined-systems* (make-defined-systems-table))
    2578           (register-system asdf)
    2579           t)))))
     2557    (cleanup-upgraded-asdf version)))
    25802558
    25812559(defmethod perform-plan ((steps list) &key)
     
    26412619  (setf (documentation 'oos 'function)
    26422620        (format nil
    2643                 "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
     2621                "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
    26442622                operate-docstring))
    26452623  (setf (documentation 'operate 'function)
     
    26522630  (apply 'operate 'load-op system args)
    26532631  t)
     2632
     2633(defun* load-systems (&rest systems)
     2634  (map () 'load-system systems))
    26542635
    26552636(defun* compile-system (system &rest args &key force verbose version
     
    27092690        (progn
    27102691          (aif (assoc op2 (cdr first-op-tree))
    2711                (if (find c (cdr it))
     2692               (if (find c (cdr it) :test #'equal)
    27122693                   nil
    27132694                   (setf (cdr it) (cons c (cdr it))))
     
    27312712
    27322713(defun* sysdef-error-component (msg type name value)
    2733   (sysdef-error (concatenate 'string msg
    2734                              (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
     2714  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
    27352715                type name value))
    27362716
     
    28092789              version name parent)))
    28102790
    2811     (let* ((other-args (remove-keys
    2812                         '(components pathname default-component-class
    2813                           perform explain output-files operation-done-p
    2814                           weakly-depends-on
    2815                           depends-on serial in-order-to)
    2816                         rest))
     2791    (let* ((args (list* :name (coerce-name name)
     2792                        :pathname pathname
     2793                        :parent parent
     2794                        (remove-keys
     2795                         '(components pathname default-component-class
     2796                           perform explain output-files operation-done-p
     2797                           weakly-depends-on depends-on serial in-order-to)
     2798                         rest)))
    28172799           (ret (find-component parent name)))
    28182800      (when weakly-depends-on
     
    28202802      (when *serial-depends-on*
    28212803        (push *serial-depends-on* depends-on))
    2822       (if ret
    2823           (apply 'reinitialize-instance ret
    2824                  :name (coerce-name name)
    2825                  :pathname pathname
    2826                  :parent parent
    2827                  other-args)
    2828           (setf ret
    2829                 (apply 'make-instance (class-for-type parent type)
    2830                        :name (coerce-name name)
    2831                        :pathname pathname
    2832                        :parent parent
    2833                        other-args)))
     2804      (if ret ; preserve identity
     2805          (apply 'reinitialize-instance ret args)
     2806          (setf ret (apply 'make-instance (class-for-type parent type) args)))
    28342807      (component-pathname ret) ; eagerly compute the absolute pathname
    28352808      (when (typep ret 'module)
     
    28632836      ret)))
    28642837
     2838(defun* reset-system (system &rest keys &key &allow-other-keys)
     2839  (change-class (change-class system 'proto-system) 'system)
     2840  (apply 'reinitialize-instance system keys))
     2841
    28652842(defun* do-defsystem (name &rest options
    28662843                           &key pathname (class 'system)
     
    28752852    (let* ((name (coerce-name name))
    28762853           (registered (system-registered-p name))
    2877            (system (cdr (or registered
    2878                             (register-system (make-instance 'system :name name)))))
     2854           (registered! (if registered
     2855                            (rplaca registered (get-universal-time))
     2856                            (register-system (make-instance 'system :name name))))
     2857           (system (reset-system (cdr registered!)
     2858                                :name name :source-file (load-pathname)))
    28792859           (component-options (remove-keys '(:class) options)))
    2880       (%set-system-source-file (load-pathname) system)
    28812860      (setf (gethash name *systems-being-defined*) system)
    2882       (when registered
    2883         (setf (car registered) (get-universal-time)))
    2884       (map () 'load-system defsystem-depends-on)
     2861      (apply 'load-systems defsystem-depends-on)
    28852862      ;; We change-class (when necessary) AFTER we load the defsystem-dep's
    28862863      ;; since the class might not be defined as part of those.
     
    29672944                 (cond
    29682945                   ((os-unix-p) "/bin/sh")
    2969                    ((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE!
     2946                   ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
    29702947                   (t (error "Unsupported OS")))
    29712948                 (if (os-unix-p) (list "-c" command) '())
     
    29782955      (list "-c" command)
    29792956      :input nil :output *verbose-out*))
     2957
     2958    #+cormanlisp
     2959    (win32:system command)
    29802960
    29812961    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
     
    31693149(defun* user-configuration-directories ()
    31703150  (let ((dirs
    3171          `(,(try-subpathname (getenv "XDG_CONFIG_HOME") "common-lisp/")
    3172            ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
    3173                :for dir :in (split-string dirs :separator ":")
    3174                :collect (try-subpathname dir "common-lisp/"))
     3151         `(,@(when (os-unix-p)
     3152               (cons
     3153                (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/")
     3154                (loop :with dirs = (getenv "XDG_CONFIG_DIRS")
     3155                  :for dir :in (split-string dirs :separator ":")
     3156                  :collect (subpathname* dir "common-lisp/"))))
    31753157           ,@(when (os-windows-p)
    3176                `(,(try-subpathname (or #+lispworks (sys:get-folder-path :local-appdata)
    3177                                        (getenv "LOCALAPPDATA"))
    3178                                    "common-lisp/config/")
     3158               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
     3159                                    (getenv "LOCALAPPDATA"))
     3160                               "common-lisp/config/")
    31793161                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    3180                  ,(try-subpathname (or #+lispworks (sys:get-folder-path :appdata)
    3181                                        (getenv "APPDATA"))
    3182                                    "common-lisp/config/")))
    3183            ,(try-subpathname (user-homedir) ".config/common-lisp/"))))
    3184     (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
     3162                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
     3163                                    (getenv "APPDATA"))
     3164                                "common-lisp/config/")))
     3165           ,(subpathname (user-homedir) ".config/common-lisp/"))))
     3166    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
     3167                       :from-end t :test 'equal)))
    31853168
    31863169(defun* system-configuration-directories ()
     
    31903173     (aif
    31913174      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    3192       (try-subpathname (or #+lispworks (sys:get-folder-path :common-appdata)
    3193                            (getenv "ALLUSERSAPPDATA")
    3194                            (subpathname (getenv "ALLUSERSPROFILE") "Application Data/"))
    3195                        "common-lisp/config/")
     3175      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
     3176                        (getenv "ALLUSERSAPPDATA")
     3177                        (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))
     3178                    "common-lisp/config/")
    31963179      (list it)))))
    31973180
    3198 (defun* in-first-directory (dirs x)
    3199   (loop :for dir :in dirs
    3200     :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
    3201 (defun* in-user-configuration-directory (x)
    3202   (in-first-directory (user-configuration-directories) x))
    3203 (defun* in-system-configuration-directory (x)
    3204   (in-first-directory (system-configuration-directories) x))
     3181(defun* in-first-directory (dirs x &key (direction :input))
     3182  (loop :with fun = (ecase direction
     3183                      ((nil :input :probe) 'probe-file*)
     3184                      ((:output :io) 'identity))
     3185    :for dir :in dirs
     3186    :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
     3187
     3188(defun* in-user-configuration-directory (x &key (direction :input))
     3189  (in-first-directory (user-configuration-directories) x :direction direction))
     3190(defun* in-system-configuration-directory (x &key (direction :input))
     3191  (in-first-directory (system-configuration-directories) x :direction direction))
    32053192
    32063193(defun* configuration-inheritance-directive-p (x)
     
    35563543(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
    35573544
    3558 (defun* user-output-translations-pathname ()
    3559   (in-user-configuration-directory *output-translations-file*))
    3560 (defun* system-output-translations-pathname ()
    3561   (in-system-configuration-directory *output-translations-file*))
    3562 (defun* user-output-translations-directory-pathname ()
    3563   (in-user-configuration-directory *output-translations-directory*))
    3564 (defun* system-output-translations-directory-pathname ()
    3565   (in-system-configuration-directory *output-translations-directory*))
     3545(defun* user-output-translations-pathname (&key (direction :input))
     3546  (in-user-configuration-directory *output-translations-file* :direction direction))
     3547(defun* system-output-translations-pathname (&key (direction :input))
     3548  (in-system-configuration-directory *output-translations-file* :direction direction))
     3549(defun* user-output-translations-directory-pathname (&key (direction :input))
     3550  (in-user-configuration-directory *output-translations-directory* :direction direction))
     3551(defun* system-output-translations-directory-pathname (&key (direction :input))
     3552  (in-system-configuration-directory *output-translations-directory* :direction direction))
    35663553(defun* environment-output-translations ()
    35673554  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
     
    36863673
    36873674(defun* apply-output-translations (path)
     3675  #+cormanlisp (truenamize path) #-cormanlisp
    36883676  (etypecase path
    3689     #+cormanlisp (t (truenamize path))
    36903677    (logical-pathname
    36913678     path)
     
    37283715(defun* tmpize-pathname (x)
    37293716  (make-pathname
    3730    :name (format nil "ASDF-TMP-~A" (pathname-name x))
     3717   :name (strcat "ASDF-TMP-" (pathname-name x))
    37313718   :defaults x))
    37323719
     
    38593846        :for p = (or (and (typep f 'logical-pathname) f)
    38603847                     (let* ((u (ignore-errors (funcall merger f))))
     3848                       ;; The first u avoids a cumbersome (truename u) error
    38613849                       (and u (equal (ignore-errors (truename u)) f) u)))
    38623850        :when p :collect p)
     
    38723860     directory entries
    38733861     #'(lambda (f)
    3874          (make-pathname :defaults directory :version (pathname-version f)
    3875                         :name (pathname-name f) :type (pathname-type f))))))
     3862         (make-pathname :defaults directory
     3863                        :name (pathname-name f) :type (ununspecific (pathname-type f))
     3864                        :version (ununspecific (pathname-version f)))))))
    38763865
    38773866(defun* directory-asd-files (directory)
     
    38823871         #-(or abcl cormanlisp genera xcl)
    38833872         (wild (merge-pathnames*
    3884                 #-(or abcl allegro cmu lispworks scl xcl)
     3873                #-(or abcl allegro cmu lispworks sbcl scl xcl)
    38853874                *wild-directory*
    3886                 #+(or abcl allegro cmu lispworks scl xcl) "*.*"
     3875                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
    38873876                directory))
    38883877         (dirs
     
    38943883          #+cormanlisp (cl::directory-subdirs directory)
    38953884          #+genera (fs:directory-list directory))
    3896          #+(or abcl allegro cmu genera lispworks scl xcl)
     3885         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
    38973886         (dirs (loop :for x :in dirs
    38983887                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
    38993888                          #+allegro (excl:probe-directory x)
    3900                           #+(or cmu scl) (directory-pathname-p x)
     3889                          #+(or cmu sbcl scl) (directory-pathname-p x)
    39013890                          #+genera (getf (cdr x) :directory)
    39023891                          #+lispworks (lw:file-directory-p x)
    39033892                 :when d :collect #+(or abcl allegro xcl) d
    39043893                                  #+genera (ensure-directory-pathname (first x))
    3905                                   #+(or cmu lispworks scl) x)))
     3894                                  #+(or cmu lispworks sbcl scl) x)))
    39063895    (filter-logical-directory-results
    39073896     directory dirs
     
    40284017(defun* default-source-registry ()
    40294018  `(:source-registry
    4030     #+sbcl (:directory ,(try-subpathname (user-homedir) ".sbcl/systems/"))
     4019    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
    40314020    (:directory ,(default-directory))
    40324021      ,@(loop :for dir :in
    40334022          `(,@(when (os-unix-p)
    40344023                `(,(or (getenv "XDG_DATA_HOME")
    4035                        (try-subpathname (user-homedir) ".local/share/"))
     4024                       (subpathname (user-homedir) ".local/share/"))
    40364025                  ,@(split-string (or (getenv "XDG_DATA_DIRS")
    40374026                                      "/usr/local/share:/usr/share")
     
    40444033                  ,(or #+lispworks (sys:get-folder-path :common-appdata)
    40454034                       (getenv "ALLUSERSAPPDATA")
    4046                        (try-subpathname (getenv "ALLUSERSPROFILE") "Application Data/")))))
    4047           :collect `(:directory ,(try-subpathname dir "common-lisp/systems/"))
    4048           :collect `(:tree ,(try-subpathname dir "common-lisp/source/")))
     4035                       (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")))))
     4036          :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
     4037          :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
    40494038      :inherit-configuration))
    4050 (defun* user-source-registry ()
    4051   (in-user-configuration-directory *source-registry-file*))
    4052 (defun* system-source-registry ()
    4053   (in-system-configuration-directory *source-registry-file*))
    4054 (defun* user-source-registry-directory ()
    4055   (in-user-configuration-directory *source-registry-directory*))
    4056 (defun* system-source-registry-directory ()
    4057   (in-system-configuration-directory *source-registry-directory*))
     4039(defun* user-source-registry (&key (direction :input))
     4040  (in-user-configuration-directory *source-registry-file* :direction direction))
     4041(defun* system-source-registry (&key (direction :input))
     4042  (in-system-configuration-directory *source-registry-file* :direction direction))
     4043(defun* user-source-registry-directory (&key (direction :input))
     4044  (in-user-configuration-directory *source-registry-directory* :direction direction))
     4045(defun* system-source-registry-directory (&key (direction :input))
     4046  (in-system-configuration-directory *source-registry-directory* :direction direction))
    40584047(defun* environment-source-registry ()
    40594048  (getenv "CL_SOURCE_REGISTRY"))
     
    41334122     :test 'equal :from-end t)))
    41344123
    4135 ;; Will read the configuration and initialize all internal variables,
    4136 ;; and return the new configuration.
     4124;; Will read the configuration and initialize all internal variables.
    41374125(defun* compute-source-registry (&optional parameter (registry *source-registry*))
    41384126  (dolist (entry (flatten-source-registry parameter))
Note: See TracChangeset for help on using the changeset viewer.