Changeset 13717


Ignore:
Timestamp:
01/04/12 21:48:45 (12 years ago)
Author:
Mark Evenson
Message:

Backport r13702: update to asdf-2.019 with ABCL patch.

Location:
branches/1.0.x/abcl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/1.0.x/abcl/doc/asdf/asdf.texinfo

    r13656 r13717  
    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
  • branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp

    r13656 r13717  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.017.22: 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
     
    98100           ("~:>" . ""))) :do
    99101      (loop :for found = (search unsupported format) :while found :do
    100         (setf format
    101               (concatenate 'simple-string
    102                            (subseq format 0 found) replacement
    103                            (subseq format (+ found (length unsupported)))))))
     102        (setf format (strcat (subseq format 0 found) replacement
     103                             (subseq format (+ found (length unsupported)))))))
    104104    format)
    105105  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
     
    111111         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    112112         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    113          (asdf-version "2.017.22")
     113         (asdf-version "2.019")
    114114         (existing-asdf (find-class 'component nil))
    115115         (existing-version *asdf-version*)
     
    189189                     (push sym formerly-exported-symbols)))
    190190               (loop :for sym :in export :do
    191                  (unless (member sym bothly-exported-symbols :test 'string-equal)
     191                 (unless (member sym bothly-exported-symbols :test 'equal)
    192192                   (push sym newly-exported-symbols)))
    193193               (loop :for user :in (package-used-by-list package)
     
    230230           :unintern
    231231           (#:*asdf-revision* #:around #:asdf-method-combination
    232             #:split #:make-collector
     232            #:split #:make-collector #:do-dep #:do-one-dep
     233            #:resolve-relative-location-component #:resolve-absolute-location-component
    233234            #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
    234235           :export
    235            (#:defsystem #:oos #:operate #:find-system #:run-shell-command
     236           (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
    236237            #:system-definition-pathname #:with-system-definitions
    237             #:search-for-system-definition #:find-component ; miscellaneous
    238             #:compile-system #:load-system #:test-system #:clear-system
    239             #:compile-op #:load-op #:load-source-op
    240             #:test-op
    241             #:operation               ; operations
    242             #:feature                 ; sort-of operation
    243             #:version                 ; metaphorically sort-of an operation
    244             #:version-satisfies
     238            #:search-for-system-definition #:find-component #:component-find-path
     239            #:compile-system #:load-system #:load-systems #:test-system #:clear-system
     240            #:operation #:compile-op #:load-op #:load-source-op #:test-op
     241            #:feature #:version #:version-satisfies
    245242            #:upgrade-asdf
    246243            #:implementation-identifier #:implementation-type
    247 
    248             #:input-files #:output-files #:output-file #:perform ; operation methods
     244            #:input-files #:output-files #:output-file #:perform
    249245            #:operation-done-p #:explain
    250246
     
    338334            #:system-registered-p
    339335            #:asdf-message
     336            #:user-output-translations-pathname
     337            #:system-output-translations-pathname
     338            #:user-output-translations-directory-pathname
     339            #:system-output-translations-directory-pathname
     340            #:user-source-registry
     341            #:system-source-registry
     342            #:user-source-registry-directory
     343            #:system-source-registry-directory
    340344
    341345            ;; Utilities
    342346            #:absolute-pathname-p
    343347            ;; #:aif #:it
    344             ;; #:appendf
     348            ;; #:appendf #:orf
    345349            #:coerce-name
    346350            #:directory-pathname-p
     
    350354            ;; #:length=n-p
    351355            ;; #:find-symbol*
    352             #:merge-pathnames*
    353             #:coerce-pathname
     356            #:merge-pathnames* #:coerce-pathname #:subpathname
    354357            #:pathname-directory-pathname
    355358            #:read-file-forms
     
    414417                condition-format condition-location
    415418                coerce-name)
     419         (ftype (function (&optional t) (values)) initialize-source-registry)
    416420         #-(or cormanlisp gcl-pre2.7)
    417421         (ftype (function (t t) t) (setf module-components-by-name)))
     
    422426(progn
    423427  (deftype logical-pathname () nil)
    424   (defun* make-broadcast-stream () *error-output*)
    425   (defun* file-namestring (p)
     428  (defun make-broadcast-stream () *error-output*)
     429  (defun file-namestring (p)
    426430    (setf p (pathname p))
    427431    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
     
    523527              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
    524528
     529(defun* ununspecific (x)
     530  (if (eq x :unspecific) nil x))
     531
    525532(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    526533  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
     
    541548         (type (or (pathname-type specified) (pathname-type defaults)))
    542549         (version (or (pathname-version specified) (pathname-version defaults))))
    543     (labels ((ununspecific (x)
    544                (if (eq x :unspecific) nil x))
    545              (unspecific-handler (p)
     550    (labels ((unspecific-handler (p)
    546551               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
    547552      (multiple-value-bind (host device directory unspecific-handler)
     
    894899        (port (ext:pathname-port pathname))
    895900        (directory (pathname-directory pathname)))
    896     (flet ((not-unspecific (component)
    897              (and (not (eq component :unspecific)) component)))
    898       (cond ((or (not-unspecific port)
    899                  (and (not-unspecific host) (plusp (length host)))
    900                  (not-unspecific scheme))
    901              (let ((prefix ""))
    902                (when (not-unspecific port)
    903                  (setf prefix (format nil ":~D" port)))
    904                (when (and (not-unspecific host) (plusp (length host)))
    905                  (setf prefix (concatenate 'string host prefix)))
    906                (setf prefix (concatenate 'string ":" prefix))
    907                (when (not-unspecific scheme)
    908                (setf prefix (concatenate 'string scheme prefix)))
    909                (assert (and directory (eq (first directory) :absolute)))
    910                (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
    911                               :defaults pathname)))
    912             (t
    913              pathname)))))
     901    (if (or (ununspecific port)
     902            (and (ununspecific host) (plusp (length host)))
     903            (ununspecific scheme))
     904        (let ((prefix ""))
     905          (when (ununspecific port)
     906            (setf prefix (format nil ":~D" port)))
     907          (when (and (ununspecific host) (plusp (length host)))
     908            (setf prefix (strcat host prefix)))
     909          (setf prefix (strcat ":" prefix))
     910          (when (ununspecific scheme)
     911            (setf prefix (strcat scheme prefix)))
     912          (assert (and directory (eq (first directory) :absolute)))
     913          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
     914                         :defaults pathname)))
     915    pathname))
    914916
    915917;;;; -------------------------------------------------------------------------
     
    11741176               :initform nil)))
    11751177
    1176 ;;; I believe that the following could probably be more efficiently done
    1177 ;;; by a primary method that invokes SHARED-INITIALIZE in a way that would
    1178 ;;; appropriately pass the slots to have their initforms re-applied, but I
    1179 ;;; do not know how to write such a method. [2011/09/02:rpg]
    1180 (defmethod reinitialize-instance :after ((obj component) &rest initargs
    1181                                          &key (version nil version-suppliedp)
    1182                                               (description nil description-suppliedp)
    1183                                               (long-description nil
    1184                                                                 long-description-suppliedp)
    1185                                               (load-dependencies nil
    1186                                                                  ld-suppliedp)
    1187                                               in-order-to
    1188                                               do-first
    1189                                               inline-methods
    1190                                               parent
    1191                                               properties)
    1192   "We reuse component objects from previously-existing systems, so we need to
    1193 make sure we clear them thoroughly."
    1194   (declare (ignore initargs load-dependencies
    1195                    long-description description version))
    1196   ;; this is a cache and should be cleared
    1197   (slot-makunbound obj 'absolute-pathname)
    1198   ;; component operation times are no longer valid when the component changes
    1199   (clrhash (component-operation-times obj))
    1200   (unless version-suppliedp (slot-makunbound obj 'version))
    1201   (unless description-suppliedp
    1202     (slot-makunbound obj 'description))
    1203   (unless long-description-suppliedp
    1204     (slot-makunbound obj 'long-description))
    1205   ;; replicate the logic of the initforms...
    1206   (unless ld-suppliedp
    1207     (setf (component-load-dependencies obj) nil))
    1208   (setf (component-in-order-to obj) in-order-to
    1209         (component-do-first obj) do-first
    1210         (component-inline-methods obj) inline-methods
    1211         (slot-value obj 'parent) parent
    1212         (slot-value obj 'properties) properties))
    1213 
    1214 
    12151178(defun* component-find-path (component)
    12161179  (reverse
     
    12851248    :accessor module-default-component-class)))
    12861249
    1287 ;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
    1288 ;;; [2011/09/02:rpg]
    1289 (defmethod reinitialize-instance :after ((obj module) &rest initargs &key)
    1290   "Clear MODULE's slots so it can be reused."
    1291   (slot-makunbound obj 'components-by-name)
    1292   ;; this may be a more elegant approach than in the
    1293   ;; COMPONENT method [2011/09/02:rpg]
    1294   (loop :for (initarg slot-name default) :in
    1295         `((:components components nil)
    1296           (:if-component-dep-fails if-component-dep-fails :fail)
    1297           (:default-component-class default-component-class
    1298               ,*default-component-class*))
    1299         :unless (member initarg initargs)
    1300         :do (setf (slot-value obj slot-name) default)))
    1301 
    13021250(defun* component-parent-pathname (component)
    13031251  ;; No default anymore (in particular, no *default-pathname-defaults*).
     
    13331281  new-value)
    13341282
    1335 (defclass system (module)
     1283(defclass proto-system () ; slots to keep when resetting a system
     1284  ;; To preserve identity for all objects, we'd need keep the components slots
     1285  ;; but also to modify parse-component-form to reset the recycled objects.
     1286  ((name) #|(components) (components-by-names)|#))
     1287
     1288(defclass system (module proto-system)
    13361289  (;; description and long-description are now available for all component's,
    13371290   ;; but now also inherited from component, but we add the legacy accessor
     
    13451298                :writer %set-system-source-file)
    13461299   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
    1347 
    1348 ;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
    1349 ;;; [2011/09/02:rpg]
    1350 (defmethod reinitialize-instance :after ((obj system) &rest initargs &key)
    1351   "Clear SYSTEM's slots so it can be reused."
    1352   ;; note that SYSTEM-SOURCE-FILE is very specially handled,
    1353   ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and
    1354   ;; not squash it.  SYSTEM COMPONENTS are handled very specially,
    1355   ;; because they are always, effectively, reused, since the system component
    1356   ;; is made early in DO-DEFSYSTEM, instead of being made later, in
    1357   ;; PARSE-COMPONENT-FORM [2011/09/02:rpg]
    1358   (loop :for (initarg slot-name) :in
    1359         `((:author author)
    1360           (:maintainer maintainer)
    1361           (:licence licence)
    1362           (:defsystem-depends-on defsystem-depends-on))
    1363         :unless (member initarg initargs)
    1364         :do (slot-makunbound obj slot-name)))
    13651300
    13661301;;;; -------------------------------------------------------------------------
     
    14511386                              network-volume-offset
    14521387                              #x14))))
    1453       (concatenate 'string
    1454         (read-null-terminated-string s)
    1455         (progn
    1456           (file-position s (+ start remaining-offset))
    1457           (read-null-terminated-string s))))))
     1388      (strcat (read-null-terminated-string s)
     1389              (progn
     1390                (file-position s (+ start remaining-offset))
     1391                (read-null-terminated-string s))))))
    14581392
    14591393(defun* parse-windows-shortcut (pathname)
     
    15421476;;; convention that functions in this list are prefixed SYSDEF-
    15431477
    1544 (defparameter *system-definition-search-functions*
    1545   '(sysdef-central-registry-search
    1546     sysdef-source-registry-search
    1547     sysdef-find-asdf))
     1478(defvar *system-definition-search-functions* '())
     1479
     1480(setf *system-definition-search-functions*
     1481      (append
     1482       ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
     1483       (remove 'contrib-sysdef-search *system-definition-search-functions*)
     1484       ;; Tuck our defaults at the end of the list if they were absent.
     1485       ;; This is imperfect, in case they were removed on purpose,
     1486       ;; but then it will be the responsibility of whoever does that
     1487       ;; to upgrade asdf before he does such a thing rather than after.
     1488       (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
     1489                  '(sysdef-central-registry-search
     1490                    sysdef-source-registry-search
     1491                    sysdef-find-asdf))))
    15481492
    15491493(defun* search-for-system-definition (system)
    1550   (let ((system-name (coerce-name system)))
    1551     (some #'(lambda (x) (funcall x system-name))
    1552           (cons 'find-system-if-being-defined *system-definition-search-functions*))))
     1494  (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
     1495        (cons 'find-system-if-being-defined
     1496              *system-definition-search-functions*)))
    15531497
    15541498(defvar *central-registry* nil
     
    16001544               (make-pathname
    16011545                :defaults defaults :version :newest :case :local
    1602                 :name (concatenate 'string name ".asd")
     1546                :name (strcat name ".asd")
    16031547                :type "lnk")))
    16041548          (when (probe-file* shortcut)
     
    16741618
    16751619(defmethod find-system ((name null) &optional (error-p t))
     1620  (declare (ignorable name))
    16761621  (when error-p
    16771622    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
     
    16931638        (funcall thunk))))
    16941639
    1695 (defmacro with-system-definitions (() &body body)
     1640(defmacro with-system-definitions ((&optional) &body body)
    16961641  `(call-with-system-definitions #'(lambda () ,@body)))
    16971642
     
    17091654                   (*default-pathname-defaults*
    17101655                    (pathname-directory-pathname pathname)))
     1656               ;;; XXX Kludge for ABCL ticket #181
     1657               #+abcl
     1658               (when (ext:pathname-jar-p pathname)
     1659                 (setf *default-pathname-defaults*
     1660                       (make-pathname :device nil :defaults *default-pathname-defaults*)))
    17111661               (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
    17121662                             pathname package)
     
    17141664        (delete-package package)))))
    17151665
    1716 (defmethod find-system ((name string) &optional (error-p t))
    1717   (with-system-definitions ()
    1718     (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    1719            (previous (cdr in-memory))
    1720            (previous (and (typep previous 'system) previous))
    1721            (previous-time (car in-memory))
     1666(defun* locate-system (name)
     1667  "Given a system NAME designator, try to locate where to load the system from.
     1668Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
     1669FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
     1670FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
     1671PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system.
     1672PREVIOUS when not null is a previously loaded SYSTEM object of same name.
     1673PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
     1674  (let* ((name (coerce-name name))
     1675         (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
     1676         (previous (cdr in-memory))
     1677         (previous (and (typep previous 'system) previous))
     1678         (previous-time (car in-memory))
    17221679           (found (search-for-system-definition name))
    1723            (found-system (and (typep found 'system) found))
    1724            (pathname (or (and (typep found '(or pathname string)) (pathname found))
    1725                          (and found-system (system-source-file found-system))
    1726                          (and previous (system-source-file previous)))))
     1680         (found-system (and (typep found 'system) found))
     1681         (pathname (or (and (typep found '(or pathname string)) (pathname found))
     1682                       (and found-system (system-source-file found-system))
     1683                       (and previous (system-source-file previous))))
     1684         (foundp (and (or found-system pathname previous) t)))
     1685    (check-type found (or null pathname system))
     1686    (when foundp
    17271687      (setf pathname (resolve-symlinks* pathname))
    17281688      (when (and pathname (not (absolute-pathname-p pathname)))
     
    17341694        (%set-system-source-file pathname previous)
    17351695        (setf previous-time nil))
    1736       (when (and found-system (not previous))
    1737         (register-system found-system))
    1738       (when (and pathname
    1739                  (or (not previous-time)
    1740                      ;; don't reload if it's already been loaded,
    1741                      ;; or its filestamp is in the future which means some clock is skewed
    1742                      ;; and trying to load might cause an infinite loop.
    1743                      (< previous-time (safe-file-write-date pathname) (get-universal-time))))
    1744         (load-sysdef name pathname))
    1745       (let ((in-memory (system-registered-p name))) ; try again after loading from disk
    1746         (cond
    1747           (in-memory
    1748            (when pathname
    1749              (setf (car in-memory) (safe-file-write-date pathname)))
    1750            (cdr in-memory))
    1751           (error-p
    1752            (error 'missing-component :requires name)))))))
     1696      (values foundp found-system pathname previous previous-time))))
     1697
     1698(defmethod find-system ((name string) &optional (error-p t))
     1699  (with-system-definitions ()
     1700    (loop
     1701      (restart-case
     1702          (multiple-value-bind (foundp found-system pathname previous previous-time)
     1703              (locate-system name)
     1704            (declare (ignore foundp))
     1705            (when (and found-system (not previous))
     1706              (register-system found-system))
     1707            (when (and pathname
     1708                       (or (not previous-time)
     1709                           ;; don't reload if it's already been loaded,
     1710                           ;; or its filestamp is in the future which means some clock is skewed
     1711                           ;; and trying to load might cause an infinite loop.
     1712                           (< previous-time (safe-file-write-date pathname) (get-universal-time))))
     1713              (load-sysdef name pathname))
     1714            (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
     1715              (return
     1716                (cond
     1717                  (in-memory
     1718                   (when pathname
     1719                     (setf (car in-memory) (safe-file-write-date pathname)))
     1720                   (cdr in-memory))
     1721                  (error-p
     1722                   (error 'missing-component :requires name))))))
     1723        (reinitialize-source-registry-and-retry ()
     1724          :report (lambda (s)
     1725                    (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
     1726          (initialize-source-registry))))))
    17531727
    17541728(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
     
    18721846   :defaults (component-parent-pathname component)))
    18731847
     1848<<<<<<< .working
     1849=======
     1850(defun* subpathname (pathname subpath &key type)
     1851  (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
     1852                                  (pathname-directory-pathname pathname))))
     1853
     1854(defun subpathname* (pathname subpath &key type)
     1855  (and pathname
     1856       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
     1857
     1858>>>>>>> .merge-right.r13702
    18741859;;;; -------------------------------------------------------------------------
    18751860;;;; Operations
     
    19741959
    19751960(defmethod component-self-dependencies ((o operation) (c component))
    1976   (let ((all-deps (component-depends-on o c)))
    1977     (remove-if-not #'(lambda (x)
    1978                        (member (component-name c) (cdr x) :test #'string=))
    1979                    all-deps)))
     1961  (remove-if-not
     1962   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
     1963   (component-depends-on o c)))
    19801964
    19811965(defmethod input-files ((operation operation) (c component))
     
    23482332     (around-compile-hook (component-parent c)))))
    23492333
     2334(defun ensure-function (fun &key (package :asdf))
     2335  (etypecase fun
     2336    ((or symbol function) fun)
     2337    (cons (eval `(function ,fun)))
     2338    (string (eval `(function ,(with-standard-io-syntax
     2339                               (let ((*package* (find-package package)))
     2340                                 (read-from-string fun))))))))
     2341
    23502342(defmethod call-with-around-compile-hook ((c component) thunk)
    23512343  (let ((hook (around-compile-hook c)))
    23522344    (if hook
    2353         (funcall hook thunk)
     2345        (funcall (ensure-function hook) thunk)
    23542346        (funcall thunk))))
    23552347
     
    25372529(defgeneric* perform-plan (plan &key))
    25382530
     2531;;;; Separating this into a different function makes it more forward-compatible
     2532(defun* cleanup-upgraded-asdf (old-version)
     2533  (let ((new-version (asdf:asdf-version)))
     2534    (unless (equal old-version new-version)
     2535      (cond
     2536        ((version-satisfies new-version old-version)
     2537         (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
     2538                       old-version new-version))
     2539        ((version-satisfies old-version new-version)
     2540         (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
     2541               old-version new-version))
     2542        (t
     2543         (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
     2544                       old-version new-version)))
     2545      (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
     2546        ;; Invalidate all systems but ASDF itself.
     2547        (setf *defined-systems* (make-defined-systems-table))
     2548        (register-system asdf)
     2549        ;; If we're in the middle of something, restart it.
     2550        (when *systems-being-defined*
     2551          (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
     2552            (clrhash *systems-being-defined*)
     2553            (dolist (s l) (find-system s nil))))
     2554        t))))
     2555
    25392556;;;; Try to upgrade of ASDF. If a different version was used, return T.
    25402557;;;; We need do that before we operate on anything that depends on ASDF.
     
    25432560    (handler-bind (((or style-warning warning) #'muffle-warning))
    25442561      (operate 'load-op :asdf :verbose nil))
    2545     (let ((new-version (asdf:asdf-version)))
    2546       (block nil
    2547         (cond
    2548           ((equal version new-version)
    2549            (return nil))
    2550           ((version-satisfies new-version version)
    2551            (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
    2552                          version new-version))
    2553           ((version-satisfies version new-version)
    2554            (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
    2555                  version new-version))
    2556           (t
    2557            (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
    2558                          version new-version)))
    2559         (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
    2560           ;; invalidate all systems but ASDF itself
    2561           (setf *defined-systems* (make-defined-systems-table))
    2562           (register-system asdf)
    2563           t)))))
     2562    (cleanup-upgraded-asdf version)))
    25642563
    25652564(defmethod perform-plan ((steps list) &key)
     
    26252624  (setf (documentation 'oos 'function)
    26262625        (format nil
    2627                 "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
     2626                "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
    26282627                operate-docstring))
    26292628  (setf (documentation 'operate 'function)
     
    26362635  (apply 'operate 'load-op system args)
    26372636  t)
     2637
     2638(defun* load-systems (&rest systems)
     2639  (map () 'load-system systems))
    26382640
    26392641(defun* compile-system (system &rest args &key force verbose version
     
    26952697        (progn
    26962698          (aif (assoc op2 (cdr first-op-tree))
    2697                (if (find c (cdr it))
     2699               (if (find c (cdr it) :test #'equal)
    26982700                   nil
    26992701                   (setf (cdr it) (cons c (cdr it))))
     
    27172719
    27182720(defun* sysdef-error-component (msg type name value)
    2719   (sysdef-error (concatenate 'string msg
    2720                              (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
     2721  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
    27212722                type name value))
    27222723
     
    27952796              version name parent)))
    27962797
    2797     (let* ((other-args (remove-keys
    2798                         '(components pathname default-component-class
    2799                           perform explain output-files operation-done-p
    2800                           weakly-depends-on
    2801                           depends-on serial in-order-to)
    2802                         rest))
     2798    (let* ((args (list* :name (coerce-name name)
     2799                        :pathname pathname
     2800                        :parent parent
     2801                        (remove-keys
     2802                         '(components pathname default-component-class
     2803                           perform explain output-files operation-done-p
     2804                           weakly-depends-on depends-on serial in-order-to)
     2805                         rest)))
    28032806           (ret (find-component parent name)))
    28042807      (when weakly-depends-on
     
    28062809      (when *serial-depends-on*
    28072810        (push *serial-depends-on* depends-on))
    2808       (if ret
    2809           (apply 'reinitialize-instance ret
    2810                  :name (coerce-name name)
    2811                  :pathname pathname
    2812                  :parent parent
    2813                  other-args)
    2814           (setf ret
    2815                 (apply 'make-instance (class-for-type parent type)
    2816                        :name (coerce-name name)
    2817                        :pathname pathname
    2818                        :parent parent
    2819                        other-args)))
     2811      (if ret ; preserve identity
     2812          (apply 'reinitialize-instance ret args)
     2813          (setf ret (apply 'make-instance (class-for-type parent type) args)))
    28202814      (component-pathname ret) ; eagerly compute the absolute pathname
    28212815      (when (typep ret 'module)
     
    28492843      ret)))
    28502844
     2845(defun* reset-system (system &rest keys &key &allow-other-keys)
     2846  (change-class (change-class system 'proto-system) 'system)
     2847  (apply 'reinitialize-instance system keys))
     2848
    28512849(defun* do-defsystem (name &rest options
    28522850                           &key (pathname nil pathname-arg-p) (class 'system)
     
    28612859    (let* ((name (coerce-name name))
    28622860           (registered (system-registered-p name))
    2863            (system (cdr (or registered
    2864                             (register-system (make-instance 'system :name name)))))
     2861           (registered! (if registered
     2862                            (rplaca registered (get-universal-time))
     2863                            (register-system (make-instance 'system :name name))))
     2864           (system (reset-system (cdr registered!)
     2865                                :name name :source-file (load-pathname)))
    28652866           (component-options (remove-keys '(:class) options)))
    2866       (%set-system-source-file (load-pathname) system)
    28672867      (setf (gethash name *systems-being-defined*) system)
    2868       (when registered
    2869         (setf (car registered) (get-universal-time)))
    2870       (map () 'load-system defsystem-depends-on)
     2868      (apply 'load-systems defsystem-depends-on)
    28712869      ;; We change-class (when necessary) AFTER we load the defsystem-dep's
    28722870      ;; since the class might not be defined as part of those.
     
    29532951                 (cond
    29542952                   ((os-unix-p) "/bin/sh")
    2955                    ((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE!
     2953                   ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
    29562954                   (t (error "Unsupported OS")))
    29572955                 (if (os-unix-p) (list "-c" command) '())
     
    29642962      (list "-c" command)
    29652963      :input nil :output *verbose-out*))
     2964
     2965    #+cormanlisp
     2966    (win32:system command)
    29662967
    29672968    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
     
    31603161(defun* user-configuration-directories ()
    31613162  (let ((dirs
    3162          (flet ((try (x sub) (try-directory-subpath x sub)))
    3163            `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
    3164              ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
    3165                  :for dir :in (split-string dirs :separator ":")
    3166                  :collect (try dir "common-lisp/"))
    3167              ,@(when (os-windows-p)
    3168                  `(,(try (or #+lispworks (sys:get-folder-path :local-appdata)
    3169                              (getenv "LOCALAPPDATA"))
    3170                          "common-lisp/config/")
    3171                     ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    3172                    ,(try (or #+lispworks (sys:get-folder-path :appdata)
    3173                              (getenv "APPDATA"))
    3174                          "common-lisp/config/")))
    3175              ,(try (user-homedir) ".config/common-lisp/")))))
    3176     (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
     3163         `(,@(when (os-unix-p)
     3164               (cons
     3165                (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/")
     3166                (loop :with dirs = (getenv "XDG_CONFIG_DIRS")
     3167                  :for dir :in (split-string dirs :separator ":")
     3168                  :collect (subpathname* dir "common-lisp/"))))
     3169           ,@(when (os-windows-p)
     3170               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
     3171                                    (getenv "LOCALAPPDATA"))
     3172                               "common-lisp/config/")
     3173                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
     3174                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
     3175                                    (getenv "APPDATA"))
     3176                                "common-lisp/config/")))
     3177           ,(subpathname (user-homedir) ".config/common-lisp/"))))
     3178    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
     3179                       :from-end t :test 'equal)))
    31773180(defun* system-configuration-directories ()
    31783181  (cond
     
    31803183    ((os-windows-p)
    31813184     (aif
    3182       (flet ((try (x sub) (try-directory-subpath x sub)))
    3183         ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    3184         (try (or #+lispworks (sys:get-folder-path :common-appdata)
    3185                  (getenv "ALLUSERSAPPDATA")
    3186                  (try (getenv "ALLUSERSPROFILE") "Application Data/"))
    3187              "common-lisp/config/"))
     3185      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
     3186      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
     3187                        (getenv "ALLUSERSAPPDATA")
     3188                        (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))
     3189                    "common-lisp/config/")
    31883190      (list it)))))
    31893191
    3190 (defun* in-first-directory (dirs x)
    3191   (loop :for dir :in dirs
    3192     :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
    3193 (defun* in-user-configuration-directory (x)
    3194   (in-first-directory (user-configuration-directories) x))
    3195 (defun* in-system-configuration-directory (x)
    3196   (in-first-directory (system-configuration-directories) x))
     3192(defun* in-first-directory (dirs x &key (direction :input))
     3193  (loop :with fun = (ecase direction
     3194                      ((nil :input :probe) 'probe-file*)
     3195                      ((:output :io) 'identity))
     3196    :for dir :in dirs
     3197    :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
     3198
     3199(defun* in-user-configuration-directory (x &key (direction :input))
     3200  (in-first-directory (user-configuration-directories) x :direction direction))
     3201(defun* in-system-configuration-directory (x &key (direction :input))
     3202  (in-first-directory (system-configuration-directories) x :direction direction))
    31973203
    31983204(defun* configuration-inheritance-directive-p (x)
     
    35483554(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
    35493555
    3550 (defun* user-output-translations-pathname ()
    3551   (in-user-configuration-directory *output-translations-file*))
    3552 (defun* system-output-translations-pathname ()
    3553   (in-system-configuration-directory *output-translations-file*))
    3554 (defun* user-output-translations-directory-pathname ()
    3555   (in-user-configuration-directory *output-translations-directory*))
    3556 (defun* system-output-translations-directory-pathname ()
    3557   (in-system-configuration-directory *output-translations-directory*))
     3556(defun* user-output-translations-pathname (&key (direction :input))
     3557  (in-user-configuration-directory *output-translations-file* :direction direction))
     3558(defun* system-output-translations-pathname (&key (direction :input))
     3559  (in-system-configuration-directory *output-translations-file* :direction direction))
     3560(defun* user-output-translations-directory-pathname (&key (direction :input))
     3561  (in-user-configuration-directory *output-translations-directory* :direction direction))
     3562(defun* system-output-translations-directory-pathname (&key (direction :input))
     3563  (in-system-configuration-directory *output-translations-directory* :direction direction))
    35583564(defun* environment-output-translations ()
    35593565  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
     
    36783684
    36793685(defun* apply-output-translations (path)
     3686  #+cormanlisp (truenamize path) #-cormanlisp
    36803687  (etypecase path
    3681     #+cormanlisp (t (truenamize path))
    36823688    (logical-pathname
    36833689     path)
     
    37203726(defun* tmpize-pathname (x)
    37213727  (make-pathname
    3722    :name (format nil "ASDF-TMP-~A" (pathname-name x))
     3728   :name (strcat "ASDF-TMP-" (pathname-name x))
    37233729   :defaults x))
    37243730
     
    38533859        :for p = (or (and (typep f 'logical-pathname) f)
    38543860                     (let* ((u (ignore-errors (funcall merger f))))
     3861                       ;; The first u avoids a cumbersome (truename u) error
    38553862                       (and u (equal (ignore-errors (truename u)) f) u)))
    38563863        :when p :collect p)
     
    38663873     directory entries
    38673874     #'(lambda (f)
    3868          (make-pathname :defaults directory :version (pathname-version f)
    3869                         :name (pathname-name f) :type (pathname-type f))))))
     3875         (make-pathname :defaults directory
     3876                        :name (pathname-name f) :type (ununspecific (pathname-type f))
     3877                        :version (ununspecific (pathname-version f)))))))
    38703878
    38713879(defun* directory-asd-files (directory)
     
    38763884         #-(or abcl cormanlisp genera xcl)
    38773885         (wild (merge-pathnames*
    3878                 #-(or abcl allegro cmu lispworks scl xcl)
     3886                #-(or abcl allegro cmu lispworks sbcl scl xcl)
    38793887                *wild-directory*
    3880                 #+(or abcl allegro cmu lispworks scl xcl) "*.*"
     3888                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
    38813889                directory))
    38823890         (dirs
     
    38883896          #+cormanlisp (cl::directory-subdirs directory)
    38893897          #+genera (fs:directory-list directory))
    3890          #+(or abcl allegro cmu genera lispworks scl xcl)
     3898         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
    38913899         (dirs (loop :for x :in dirs
    38923900                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
    38933901                          #+allegro (excl:probe-directory x)
    3894                           #+(or cmu scl) (directory-pathname-p x)
     3902                          #+(or cmu sbcl scl) (directory-pathname-p x)
    38953903                          #+genera (getf (cdr x) :directory)
    38963904                          #+lispworks (lw:file-directory-p x)
    38973905                 :when d :collect #+(or abcl allegro xcl) d
    38983906                                  #+genera (ensure-directory-pathname (first x))
    3899                                   #+(or cmu lispworks scl) x)))
     3907                                  #+(or cmu lispworks sbcl scl) x)))
    39003908    (filter-logical-directory-results
    39013909     directory dirs
     
    40204028    #+cmu (:tree #p"modules:")))
    40214029(defun* default-source-registry ()
    4022   (flet ((try (x sub) (try-directory-subpath x sub)))
    4023     `(:source-registry
    4024       #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
    4025       (:directory ,(default-directory))
     4030  `(:source-registry
     4031    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
     4032    (:directory ,(default-directory))
    40264033      ,@(loop :for dir :in
    40274034          `(,@(when (os-unix-p)
    40284035                `(,(or (getenv "XDG_DATA_HOME")
    4029                        (try (user-homedir) ".local/share/"))
     4036                       (subpathname (user-homedir) ".local/share/"))
    40304037                  ,@(split-string (or (getenv "XDG_DATA_DIRS")
    40314038                                      "/usr/local/share:/usr/share")
     
    40384045                  ,(or #+lispworks (sys:get-folder-path :common-appdata)
    40394046                       (getenv "ALLUSERSAPPDATA")
    4040                        (try (getenv "ALLUSERSPROFILE") "Application Data/")))))
    4041           :collect `(:directory ,(try dir "common-lisp/systems/"))
    4042           :collect `(:tree ,(try dir "common-lisp/source/")))
    4043       :inherit-configuration)))
    4044 (defun* user-source-registry ()
    4045   (in-user-configuration-directory *source-registry-file*))
    4046 (defun* system-source-registry ()
    4047   (in-system-configuration-directory *source-registry-file*))
    4048 (defun* user-source-registry-directory ()
    4049   (in-user-configuration-directory *source-registry-directory*))
    4050 (defun* system-source-registry-directory ()
    4051   (in-system-configuration-directory *source-registry-directory*))
     4047                       (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")))))
     4048          :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
     4049          :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
     4050      :inherit-configuration))
     4051(defun* user-source-registry (&key (direction :input))
     4052  (in-user-configuration-directory *source-registry-file* :direction direction))
     4053(defun* system-source-registry (&key (direction :input))
     4054  (in-system-configuration-directory *source-registry-file* :direction direction))
     4055(defun* user-source-registry-directory (&key (direction :input))
     4056  (in-user-configuration-directory *source-registry-directory* :direction direction))
     4057(defun* system-source-registry-directory (&key (direction :input))
     4058  (in-system-configuration-directory *source-registry-directory* :direction direction))
    40524059(defun* environment-source-registry ()
    40534060  (getenv "CL_SOURCE_REGISTRY"))
     
    41274134     :test 'equal :from-end t)))
    41284135
    4129 ;; Will read the configuration and initialize all internal variables,
    4130 ;; and return the new configuration.
     4136;; Will read the configuration and initialize all internal variables.
    41314137(defun* compute-source-registry (&optional parameter (registry *source-registry*))
    41324138  (dolist (entry (flatten-source-registry parameter))
Note: See TracChangeset for help on using the changeset viewer.