Changeset 13717
- Timestamp:
- 01/04/12 21:48:45 (12 years ago)
- Location:
- branches/1.0.x/abcl
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/1.0.x/abcl/doc/asdf/asdf.texinfo
r13656 r13717 896 896 system-definition := ( defsystem system-designator @var{system-option}* ) 897 897 898 system-option := :defsystem-depends-on system-list 898 system-option := :defsystem-depends-on system-list 899 | :class class-name (see discussion below) 899 900 | module-option 900 901 | option … … 959 960 the current package @code{my-system-asd} can be specified as 960 961 @code{:my-component-type}, or @code{my-component-type}. 962 963 @subsection System class names 964 965 A system class name will be looked up in the same way as a Component 966 type (see above). Typically, one will not need to specify a system 967 class name, unless using a non-standard system class defined in some 968 ASDF extension, typically loaded through @code{DEFSYSTEM-DEPENDS-ON}, 969 see below. For such class names in the ASDF package, we recommend that 970 the @code{:class} option be specified using a keyword symbol, such as 971 972 @example 973 :class :MY-NEW-SYSTEM-SUBCLASS 974 @end example 975 976 This practice will ensure that package name conflicts are avoided. 977 Otherwise, the symbol @code{MY-NEW-SYSTEM-SUBCLASS} will be read into 978 the current package @emph{before} it has been exported from the ASDF 979 extension loaded by @code{:defsystem-depends-on}, causing a name 980 conflict in the current package. 961 981 962 982 @subsection Defsystem depends on … … 2831 2851 2832 2852 When 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}. 2853 you can specify a keyword argument @code{:around-compile function}. 2854 If left unspecified, 2855 the value will be inherited from the parent component if any, 2856 or with a default of @code{nil} 2857 if no value is specified in any transitive parent. 2858 2859 The argument must be a either @code{nil}, a fbound symbol, 2860 a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk) ...)}) 2861 a function object (e.g. using @code{#.#'} but that's discouraged 2862 because it prevents the introspection done by e.g. asdf-dependency-grovel), 2863 or a string that when read yields a symbol or a lambda-expression. 2838 2864 @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. 2865 A non-nil value designates a function of one argument 2866 that will be called with a thunk for calling 2867 the compile-file function with proper arguments. 2868 2869 Note that by using a string, you may reference 2870 a function, symbol and/or package 2871 that will only be created later during the build, but 2872 isn't yet present at the time the defsystem form is evaluated. 2873 However, if your entire system is using such a hook, you may have to 2874 explicitly override the hook with @code{nil} for all the modules and files 2875 that are compiled before the hook is defined. 2843 2876 2844 2877 Using this hook, you may achieve such effects as: … … 3650 3683 @end lisp 3651 3684 3685 @comment FIXME: Add a FAQ about how to use a new system class... 3686 3652 3687 3653 3688 @node TODO list, Inspiration, FAQ, Top -
branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp
r13656 r13717 1 1 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- 2 ;;; This is ASDF 2.01 7.22: Another System Definition Facility.2 ;;; This is ASDF 2.019: Another System Definition Facility. 3 3 ;;; 4 4 ;;; Feedback, bug reports, and patches are all welcome: … … 57 57 (eval-when (:compile-toplevel :load-toplevel :execute) 58 58 ;;; Implementation-dependent tweaks 59 ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on theimplementation defaults.59 ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults. 60 60 #+allegro 61 61 (setf excl::*autoload-package-name-alist* … … 87 87 ;; Strip out formatting that is not supported on Genera. 88 88 ;; Has to be inside the eval-when to make Lispworks happy (!) 89 (defun strcat (&rest strings) 90 (apply 'concatenate 'string strings)) 89 91 (defmacro compatfmt (format) 90 92 #-(or gcl genera) format … … 98 100 ("~:>" . ""))) :do 99 101 (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))))))) 104 104 format) 105 105 (let* (;; For bug reporting sanity, please always bump this version when you modify this file. … … 111 111 ;; "2.345.0.7" would be your seventh local modification of official release 2.345 112 112 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 113 (asdf-version "2.01 7.22")113 (asdf-version "2.019") 114 114 (existing-asdf (find-class 'component nil)) 115 115 (existing-version *asdf-version*) … … 189 189 (push sym formerly-exported-symbols))) 190 190 (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) 192 192 (push sym newly-exported-symbols))) 193 193 (loop :for user :in (package-used-by-list package) … … 230 230 :unintern 231 231 (#:*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 233 234 #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function 234 235 :export 235 (#:defsystem #:oos #:operate #:find-system #: run-shell-command236 (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command 236 237 #: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 245 242 #:upgrade-asdf 246 243 #:implementation-identifier #:implementation-type 247 248 #:input-files #:output-files #:output-file #:perform ; operation methods 244 #:input-files #:output-files #:output-file #:perform 249 245 #:operation-done-p #:explain 250 246 … … 338 334 #:system-registered-p 339 335 #: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 340 344 341 345 ;; Utilities 342 346 #:absolute-pathname-p 343 347 ;; #:aif #:it 344 ;; #:appendf 348 ;; #:appendf #:orf 345 349 #:coerce-name 346 350 #:directory-pathname-p … … 350 354 ;; #:length=n-p 351 355 ;; #:find-symbol* 352 #:merge-pathnames* 353 #:coerce-pathname 356 #:merge-pathnames* #:coerce-pathname #:subpathname 354 357 #:pathname-directory-pathname 355 358 #:read-file-forms … … 414 417 condition-format condition-location 415 418 coerce-name) 419 (ftype (function (&optional t) (values)) initialize-source-registry) 416 420 #-(or cormanlisp gcl-pre2.7) 417 421 (ftype (function (t t) t) (setf module-components-by-name))) … … 422 426 (progn 423 427 (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) 426 430 (setf p (pathname p)) 427 431 (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) … … 523 527 :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) 524 528 529 (defun* ununspecific (x) 530 (if (eq x :unspecific) nil x)) 531 525 532 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) 526 533 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that … … 541 548 (type (or (pathname-type specified) (pathname-type defaults))) 542 549 (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) 546 551 (if (typep p 'logical-pathname) #'ununspecific #'identity))) 547 552 (multiple-value-bind (host device directory unspecific-handler) … … 894 899 (port (ext:pathname-port pathname)) 895 900 (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)) 914 916 915 917 ;;;; ------------------------------------------------------------------------- … … 1174 1176 :initform nil))) 1175 1177 1176 ;;; I believe that the following could probably be more efficiently done1177 ;;; by a primary method that invokes SHARED-INITIALIZE in a way that would1178 ;;; appropriately pass the slots to have their initforms re-applied, but I1179 ;;; do not know how to write such a method. [2011/09/02:rpg]1180 (defmethod reinitialize-instance :after ((obj component) &rest initargs1181 &key (version nil version-suppliedp)1182 (description nil description-suppliedp)1183 (long-description nil1184 long-description-suppliedp)1185 (load-dependencies nil1186 ld-suppliedp)1187 in-order-to1188 do-first1189 inline-methods1190 parent1191 properties)1192 "We reuse component objects from previously-existing systems, so we need to1193 make sure we clear them thoroughly."1194 (declare (ignore initargs load-dependencies1195 long-description description version))1196 ;; this is a cache and should be cleared1197 (slot-makunbound obj 'absolute-pathname)1198 ;; component operation times are no longer valid when the component changes1199 (clrhash (component-operation-times obj))1200 (unless version-suppliedp (slot-makunbound obj 'version))1201 (unless description-suppliedp1202 (slot-makunbound obj 'description))1203 (unless long-description-suppliedp1204 (slot-makunbound obj 'long-description))1205 ;; replicate the logic of the initforms...1206 (unless ld-suppliedp1207 (setf (component-load-dependencies obj) nil))1208 (setf (component-in-order-to obj) in-order-to1209 (component-do-first obj) do-first1210 (component-inline-methods obj) inline-methods1211 (slot-value obj 'parent) parent1212 (slot-value obj 'properties) properties))1213 1214 1215 1178 (defun* component-find-path (component) 1216 1179 (reverse … … 1285 1248 :accessor module-default-component-class))) 1286 1249 1287 ;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT1288 ;;; [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 the1293 ;; COMPONENT method [2011/09/02:rpg]1294 (loop :for (initarg slot-name default) :in1295 `((:components components nil)1296 (:if-component-dep-fails if-component-dep-fails :fail)1297 (:default-component-class default-component-class1298 ,*default-component-class*))1299 :unless (member initarg initargs)1300 :do (setf (slot-value obj slot-name) default)))1301 1302 1250 (defun* component-parent-pathname (component) 1303 1251 ;; No default anymore (in particular, no *default-pathname-defaults*). … … 1333 1281 new-value) 1334 1282 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) 1336 1289 (;; description and long-description are now available for all component's, 1337 1290 ;; but now also inherited from component, but we add the legacy accessor … … 1345 1298 :writer %set-system-source-file) 1346 1299 (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) 1347 1348 ;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT1349 ;;; [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 and1354 ;; not squash it. SYSTEM COMPONENTS are handled very specially,1355 ;; because they are always, effectively, reused, since the system component1356 ;; is made early in DO-DEFSYSTEM, instead of being made later, in1357 ;; PARSE-COMPONENT-FORM [2011/09/02:rpg]1358 (loop :for (initarg slot-name) :in1359 `((: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)))1365 1300 1366 1301 ;;;; ------------------------------------------------------------------------- … … 1451 1386 network-volume-offset 1452 1387 #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)))))) 1458 1392 1459 1393 (defun* parse-windows-shortcut (pathname) … … 1542 1476 ;;; convention that functions in this list are prefixed SYSDEF- 1543 1477 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)))) 1548 1492 1549 1493 (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*))) 1553 1497 1554 1498 (defvar *central-registry* nil … … 1600 1544 (make-pathname 1601 1545 :defaults defaults :version :newest :case :local 1602 :name ( concatenate 'stringname ".asd")1546 :name (strcat name ".asd") 1603 1547 :type "lnk"))) 1604 1548 (when (probe-file* shortcut) … … 1674 1618 1675 1619 (defmethod find-system ((name null) &optional (error-p t)) 1620 (declare (ignorable name)) 1676 1621 (when error-p 1677 1622 (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) … … 1693 1638 (funcall thunk)))) 1694 1639 1695 (defmacro with-system-definitions (( ) &body body)1640 (defmacro with-system-definitions ((&optional) &body body) 1696 1641 `(call-with-system-definitions #'(lambda () ,@body))) 1697 1642 … … 1709 1654 (*default-pathname-defaults* 1710 1655 (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*))) 1711 1661 (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") 1712 1662 pathname package) … … 1714 1664 (delete-package package))))) 1715 1665 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. 1668 Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME 1669 FOUNDP is true when a new was found, either a new unregistered one or a previously registered one. 1670 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is 1671 PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system. 1672 PREVIOUS when not null is a previously loaded SYSTEM object of same name. 1673 PREVIOUS-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)) 1722 1679 (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 1727 1687 (setf pathname (resolve-symlinks* pathname)) 1728 1688 (when (and pathname (not (absolute-pathname-p pathname))) … … 1734 1694 (%set-system-source-file pathname previous) 1735 1695 (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)))))) 1753 1727 1754 1728 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) … … 1872 1846 :defaults (component-parent-pathname component))) 1873 1847 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 1874 1859 ;;;; ------------------------------------------------------------------------- 1875 1860 ;;;; Operations … … 1974 1959 1975 1960 (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))) 1980 1964 1981 1965 (defmethod input-files ((operation operation) (c component)) … … 2348 2332 (around-compile-hook (component-parent c))))) 2349 2333 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 2350 2342 (defmethod call-with-around-compile-hook ((c component) thunk) 2351 2343 (let ((hook (around-compile-hook c))) 2352 2344 (if hook 2353 (funcall hookthunk)2345 (funcall (ensure-function hook) thunk) 2354 2346 (funcall thunk)))) 2355 2347 … … 2537 2529 (defgeneric* perform-plan (plan &key)) 2538 2530 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 2539 2556 ;;;; Try to upgrade of ASDF. If a different version was used, return T. 2540 2557 ;;;; We need do that before we operate on anything that depends on ASDF. … … 2543 2560 (handler-bind (((or style-warning warning) #'muffle-warning)) 2544 2561 (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))) 2564 2563 2565 2564 (defmethod perform-plan ((steps list) &key) … … 2625 2624 (setf (documentation 'oos 'function) 2626 2625 (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" 2628 2627 operate-docstring)) 2629 2628 (setf (documentation 'operate 'function) … … 2636 2635 (apply 'operate 'load-op system args) 2637 2636 t) 2637 2638 (defun* load-systems (&rest systems) 2639 (map () 'load-system systems)) 2638 2640 2639 2641 (defun* compile-system (system &rest args &key force verbose version … … 2695 2697 (progn 2696 2698 (aif (assoc op2 (cdr first-op-tree)) 2697 (if (find c (cdr it) )2699 (if (find c (cdr it) :test #'equal) 2698 2700 nil 2699 2701 (setf (cdr it) (cons c (cdr it)))) … … 2717 2719 2718 2720 (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~@:>")) 2721 2722 type name value)) 2722 2723 … … 2795 2796 version name parent))) 2796 2797 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))) 2803 2806 (ret (find-component parent name))) 2804 2807 (when weakly-depends-on … … 2806 2809 (when *serial-depends-on* 2807 2810 (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))) 2820 2814 (component-pathname ret) ; eagerly compute the absolute pathname 2821 2815 (when (typep ret 'module) … … 2849 2843 ret))) 2850 2844 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 2851 2849 (defun* do-defsystem (name &rest options 2852 2850 &key (pathname nil pathname-arg-p) (class 'system) … … 2861 2859 (let* ((name (coerce-name name)) 2862 2860 (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))) 2865 2866 (component-options (remove-keys '(:class) options))) 2866 (%set-system-source-file (load-pathname) system)2867 2867 (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) 2871 2869 ;; We change-class (when necessary) AFTER we load the defsystem-dep's 2872 2870 ;; since the class might not be defined as part of those. … … 2953 2951 (cond 2954 2952 ((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! 2956 2954 (t (error "Unsupported OS"))) 2957 2955 (if (os-unix-p) (list "-c" command) '()) … … 2964 2962 (list "-c" command) 2965 2963 :input nil :output *verbose-out*)) 2964 2965 #+cormanlisp 2966 (win32:system command) 2966 2967 2967 2968 #+ecl ;; courtesy of Juan Jose Garcia Ripoll … … 3160 3161 (defun* user-configuration-directories () 3161 3162 (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))) 3177 3180 (defun* system-configuration-directories () 3178 3181 (cond … … 3180 3183 ((os-windows-p) 3181 3184 (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/") 3188 3190 (list it))))) 3189 3191 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)) 3197 3203 3198 3204 (defun* configuration-inheritance-directive-p (x) … … 3548 3554 (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) 3549 3555 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)) 3558 3564 (defun* environment-output-translations () 3559 3565 (getenv "ASDF_OUTPUT_TRANSLATIONS")) … … 3678 3684 3679 3685 (defun* apply-output-translations (path) 3686 #+cormanlisp (truenamize path) #-cormanlisp 3680 3687 (etypecase path 3681 #+cormanlisp (t (truenamize path))3682 3688 (logical-pathname 3683 3689 path) … … 3720 3726 (defun* tmpize-pathname (x) 3721 3727 (make-pathname 3722 :name ( format nil "ASDF-TMP-~A" (pathname-name x))3728 :name (strcat "ASDF-TMP-" (pathname-name x)) 3723 3729 :defaults x)) 3724 3730 … … 3853 3859 :for p = (or (and (typep f 'logical-pathname) f) 3854 3860 (let* ((u (ignore-errors (funcall merger f)))) 3861 ;; The first u avoids a cumbersome (truename u) error 3855 3862 (and u (equal (ignore-errors (truename u)) f) u))) 3856 3863 :when p :collect p) … … 3866 3873 directory entries 3867 3874 #'(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))))))) 3870 3878 3871 3879 (defun* directory-asd-files (directory) … … 3876 3884 #-(or abcl cormanlisp genera xcl) 3877 3885 (wild (merge-pathnames* 3878 #-(or abcl allegro cmu lispworks s cl xcl)3886 #-(or abcl allegro cmu lispworks sbcl scl xcl) 3879 3887 *wild-directory* 3880 #+(or abcl allegro cmu lispworks s cl xcl) "*.*"3888 #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" 3881 3889 directory)) 3882 3890 (dirs … … 3888 3896 #+cormanlisp (cl::directory-subdirs directory) 3889 3897 #+genera (fs:directory-list directory)) 3890 #+(or abcl allegro cmu genera lispworks s cl xcl)3898 #+(or abcl allegro cmu genera lispworks sbcl scl xcl) 3891 3899 (dirs (loop :for x :in dirs 3892 3900 :for d = #+(or abcl xcl) (extensions:probe-directory x) 3893 3901 #+allegro (excl:probe-directory x) 3894 #+(or cmu s cl) (directory-pathname-p x)3902 #+(or cmu sbcl scl) (directory-pathname-p x) 3895 3903 #+genera (getf (cdr x) :directory) 3896 3904 #+lispworks (lw:file-directory-p x) 3897 3905 :when d :collect #+(or abcl allegro xcl) d 3898 3906 #+genera (ensure-directory-pathname (first x)) 3899 #+(or cmu lispworks s cl) x)))3907 #+(or cmu lispworks sbcl scl) x))) 3900 3908 (filter-logical-directory-results 3901 3909 directory dirs … … 4020 4028 #+cmu (:tree #p"modules:"))) 4021 4029 (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)) 4026 4033 ,@(loop :for dir :in 4027 4034 `(,@(when (os-unix-p) 4028 4035 `(,(or (getenv "XDG_DATA_HOME") 4029 ( try(user-homedir) ".local/share/"))4036 (subpathname (user-homedir) ".local/share/")) 4030 4037 ,@(split-string (or (getenv "XDG_DATA_DIRS") 4031 4038 "/usr/local/share:/usr/share") … … 4038 4045 ,(or #+lispworks (sys:get-folder-path :common-appdata) 4039 4046 (getenv "ALLUSERSAPPDATA") 4040 ( try(getenv "ALLUSERSPROFILE") "Application Data/")))))4041 :collect `(:directory ,( trydir "common-lisp/systems/"))4042 :collect `(:tree ,( trydir "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)) 4052 4059 (defun* environment-source-registry () 4053 4060 (getenv "CL_SOURCE_REGISTRY")) … … 4127 4134 :test 'equal :from-end t))) 4128 4135 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. 4131 4137 (defun* compute-source-registry (&optional parameter (registry *source-registry*)) 4132 4138 (dolist (entry (flatten-source-registry parameter))
Note: See TracChangeset
for help on using the changeset viewer.