Changeset 13702
- Timestamp:
- 12/18/11 15:25:19 (12 years ago)
- Location:
- trunk/abcl
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/doc/asdf/asdf.texinfo
r13655 r13702 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 -
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
r13692 r13702 1 1 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- 2 ;;; This is ASDF 2.01 8: 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 … … 95 97 #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do 96 98 (loop :for found = (search unsupported format) :while found :do 97 (setf format 98 (concatenate 'simple-string 99 (subseq format 0 found) replacement 100 (subseq format (+ found (length unsupported))))))) 99 (setf format (strcat (subseq format 0 found) replacement 100 (subseq format (+ found (length unsupported))))))) 101 101 format) 102 102 (let* (;; For bug reporting sanity, please always bump this version when you modify this file. … … 108 108 ;; "2.345.0.7" would be your seventh local modification of official release 2.345 109 109 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 110 (asdf-version "2.01 8")110 (asdf-version "2.019") 111 111 (existing-asdf (find-class 'component nil)) 112 112 (existing-version *asdf-version*) … … 186 186 (push sym formerly-exported-symbols))) 187 187 (loop :for sym :in export :do 188 (unless (member sym bothly-exported-symbols :test ' string-equal)188 (unless (member sym bothly-exported-symbols :test 'equal) 189 189 (push sym newly-exported-symbols))) 190 190 (loop :for user :in (package-used-by-list package) … … 227 227 :unintern 228 228 (#:*asdf-revision* #:around #:asdf-method-combination 229 #:split #:make-collector 229 #:split #:make-collector #:do-dep #:do-one-dep 230 #:resolve-relative-location-component #:resolve-absolute-location-component 230 231 #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function 231 232 :export 232 (#:defsystem #:oos #:operate #:find-system #: run-shell-command233 (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command 233 234 #:system-definition-pathname #:with-system-definitions 234 #:search-for-system-definition #:find-component ; miscellaneous 235 #:compile-system #:load-system #:test-system #:clear-system 236 #:compile-op #:load-op #:load-source-op 237 #:test-op 238 #:operation ; operations 239 #:feature ; sort-of operation 240 #:version ; metaphorically sort-of an operation 241 #:version-satisfies 235 #:search-for-system-definition #:find-component #:component-find-path 236 #:compile-system #:load-system #:load-systems #:test-system #:clear-system 237 #:operation #:compile-op #:load-op #:load-source-op #:test-op 238 #:feature #:version #:version-satisfies 242 239 #:upgrade-asdf 243 240 #:implementation-identifier #:implementation-type 244 245 #:input-files #:output-files #:output-file #:perform ; operation methods 241 #:input-files #:output-files #:output-file #:perform 246 242 #:operation-done-p #:explain 247 243 … … 335 331 #:system-registered-p 336 332 #:asdf-message 333 #:user-output-translations-pathname 334 #:system-output-translations-pathname 335 #:user-output-translations-directory-pathname 336 #:system-output-translations-directory-pathname 337 #:user-source-registry 338 #:system-source-registry 339 #:user-source-registry-directory 340 #:system-source-registry-directory 337 341 338 342 ;; Utilities 339 343 #:absolute-pathname-p 340 344 ;; #:aif #:it 341 ;; #:appendf 345 ;; #:appendf #:orf 342 346 #:coerce-name 343 347 #:directory-pathname-p … … 347 351 ;; #:length=n-p 348 352 ;; #:find-symbol* 349 #:merge-pathnames* 350 #:coerce-pathname 351 #:subpathname 353 #:merge-pathnames* #:coerce-pathname #:subpathname 352 354 #:pathname-directory-pathname 353 355 #:read-file-forms … … 412 414 condition-format condition-location 413 415 coerce-name) 416 (ftype (function (&optional t) (values)) initialize-source-registry) 414 417 #-(or cormanlisp gcl-pre2.7) 415 418 (ftype (function (t t) t) (setf module-components-by-name))) … … 420 423 (progn 421 424 (deftype logical-pathname () nil) 422 (defun *make-broadcast-stream () *error-output*)423 (defun *file-namestring (p)425 (defun make-broadcast-stream () *error-output*) 426 (defun file-namestring (p) 424 427 (setf p (pathname p)) 425 428 (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) … … 521 524 :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) 522 525 526 (defun* ununspecific (x) 527 (if (eq x :unspecific) nil x)) 528 523 529 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) 524 530 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that … … 539 545 (type (or (pathname-type specified) (pathname-type defaults))) 540 546 (version (or (pathname-version specified) (pathname-version defaults)))) 541 (labels ((ununspecific (x) 542 (if (eq x :unspecific) nil x)) 543 (unspecific-handler (p) 547 (labels ((unspecific-handler (p) 544 548 (if (typep p 'logical-pathname) #'ununspecific #'identity))) 545 549 (multiple-value-bind (host device directory unspecific-handler) … … 892 896 (port (ext:pathname-port pathname)) 893 897 (directory (pathname-directory pathname))) 894 (flet ((not-unspecific (component) 895 (and (not (eq component :unspecific)) component))) 896 (cond ((or (not-unspecific port) 897 (and (not-unspecific host) (plusp (length host))) 898 (not-unspecific scheme)) 899 (let ((prefix "")) 900 (when (not-unspecific port) 901 (setf prefix (format nil ":~D" port))) 902 (when (and (not-unspecific host) (plusp (length host))) 903 (setf prefix (concatenate 'string host prefix))) 904 (setf prefix (concatenate 'string ":" prefix)) 905 (when (not-unspecific scheme) 906 (setf prefix (concatenate 'string scheme prefix))) 907 (assert (and directory (eq (first directory) :absolute))) 908 (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) 909 :defaults pathname))) 910 (t 911 pathname))))) 898 (if (or (ununspecific port) 899 (and (ununspecific host) (plusp (length host))) 900 (ununspecific scheme)) 901 (let ((prefix "")) 902 (when (ununspecific port) 903 (setf prefix (format nil ":~D" port))) 904 (when (and (ununspecific host) (plusp (length host))) 905 (setf prefix (strcat host prefix))) 906 (setf prefix (strcat ":" prefix)) 907 (when (ununspecific scheme) 908 (setf prefix (strcat scheme prefix))) 909 (assert (and directory (eq (first directory) :absolute))) 910 (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) 911 :defaults pathname))) 912 pathname)) 912 913 913 914 ;;;; ------------------------------------------------------------------------- … … 1172 1173 :initform nil))) 1173 1174 1174 ;;; I believe that the following could probably be more efficiently done1175 ;;; by a primary method that invokes SHARED-INITIALIZE in a way that would1176 ;;; appropriately pass the slots to have their initforms re-applied, but I1177 ;;; do not know how to write such a method. [2011/09/02:rpg]1178 (defmethod reinitialize-instance :after ((obj component) &rest initargs1179 &key (version nil version-suppliedp)1180 (description nil description-suppliedp)1181 (long-description nil1182 long-description-suppliedp)1183 (load-dependencies nil1184 ld-suppliedp)1185 in-order-to1186 do-first1187 inline-methods1188 parent1189 properties)1190 "We reuse component objects from previously-existing systems, so we need to1191 make sure we clear them thoroughly."1192 (declare (ignore initargs load-dependencies1193 long-description description version))1194 ;; this is a cache and should be cleared1195 (slot-makunbound obj 'absolute-pathname)1196 ;; component operation times are no longer valid when the component changes1197 (clrhash (component-operation-times obj))1198 (unless version-suppliedp (slot-makunbound obj 'version))1199 (unless description-suppliedp1200 (slot-makunbound obj 'description))1201 (unless long-description-suppliedp1202 (slot-makunbound obj 'long-description))1203 ;; replicate the logic of the initforms...1204 (unless ld-suppliedp1205 (setf (component-load-dependencies obj) nil))1206 (setf (component-in-order-to obj) in-order-to1207 (component-do-first obj) do-first1208 (component-inline-methods obj) inline-methods1209 (slot-value obj 'parent) parent1210 (slot-value obj 'properties) properties))1211 1212 1213 1175 (defun* component-find-path (component) 1214 1176 (reverse … … 1283 1245 :accessor module-default-component-class))) 1284 1246 1285 ;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT1286 ;;; [2011/09/02:rpg]1287 (defmethod reinitialize-instance :after ((obj module) &rest initargs &key)1288 "Clear MODULE's slots so it can be reused."1289 (slot-makunbound obj 'components-by-name)1290 ;; this may be a more elegant approach than in the1291 ;; COMPONENT method [2011/09/02:rpg]1292 (loop :for (initarg slot-name default) :in1293 `((:components components nil)1294 (:if-component-dep-fails if-component-dep-fails :fail)1295 (:default-component-class default-component-class1296 ,*default-component-class*))1297 :unless (member initarg initargs)1298 :do (setf (slot-value obj slot-name) default)))1299 1300 1247 (defun* component-parent-pathname (component) 1301 1248 ;; No default anymore (in particular, no *default-pathname-defaults*). … … 1331 1278 new-value) 1332 1279 1333 (defclass system (module) 1280 (defclass proto-system () ; slots to keep when resetting a system 1281 ;; To preserve identity for all objects, we'd need keep the components slots 1282 ;; but also to modify parse-component-form to reset the recycled objects. 1283 ((name) #|(components) (components-by-names)|#)) 1284 1285 (defclass system (module proto-system) 1334 1286 (;; description and long-description are now available for all component's, 1335 1287 ;; but now also inherited from component, but we add the legacy accessor … … 1343 1295 :writer %set-system-source-file) 1344 1296 (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) 1345 1346 ;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT1347 ;;; [2011/09/02:rpg]1348 (defmethod reinitialize-instance :after ((obj system) &rest initargs &key)1349 "Clear SYSTEM's slots so it can be reused."1350 ;; note that SYSTEM-SOURCE-FILE is very specially handled,1351 ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and1352 ;; not squash it. SYSTEM COMPONENTS are handled very specially,1353 ;; because they are always, effectively, reused, since the system component1354 ;; is made early in DO-DEFSYSTEM, instead of being made later, in1355 ;; PARSE-COMPONENT-FORM [2011/09/02:rpg]1356 (loop :for (initarg slot-name) :in1357 `((:author author)1358 (:maintainer maintainer)1359 (:licence licence)1360 (:defsystem-depends-on defsystem-depends-on))1361 :unless (member initarg initargs)1362 :do (slot-makunbound obj slot-name)))1363 1297 1364 1298 ;;;; ------------------------------------------------------------------------- … … 1449 1383 network-volume-offset 1450 1384 #x14)))) 1451 (concatenate 'string 1452 (read-null-terminated-string s) 1453 (progn 1454 (file-position s (+ start remaining-offset)) 1455 (read-null-terminated-string s)))))) 1385 (strcat (read-null-terminated-string s) 1386 (progn 1387 (file-position s (+ start remaining-offset)) 1388 (read-null-terminated-string s)))))) 1456 1389 1457 1390 (defun* parse-windows-shortcut (pathname) … … 1540 1473 ;;; convention that functions in this list are prefixed SYSDEF- 1541 1474 1542 (defparameter *system-definition-search-functions* 1543 '(sysdef-central-registry-search 1544 sysdef-source-registry-search 1545 sysdef-find-asdf)) 1475 (defvar *system-definition-search-functions* '()) 1476 1477 (setf *system-definition-search-functions* 1478 (append 1479 ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. 1480 (remove 'contrib-sysdef-search *system-definition-search-functions*) 1481 ;; Tuck our defaults at the end of the list if they were absent. 1482 ;; This is imperfect, in case they were removed on purpose, 1483 ;; but then it will be the responsibility of whoever does that 1484 ;; to upgrade asdf before he does such a thing rather than after. 1485 (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) 1486 '(sysdef-central-registry-search 1487 sysdef-source-registry-search 1488 sysdef-find-asdf)))) 1546 1489 1547 1490 (defun* search-for-system-definition (system) 1548 ( let ((system-name (coerce-name system)))1549 (some #'(lambda (x) (funcall x system-name))1550 (cons 'find-system-if-being-defined *system-definition-search-functions*))))1491 (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) 1492 (cons 'find-system-if-being-defined 1493 *system-definition-search-functions*))) 1551 1494 1552 1495 (defvar *central-registry* nil … … 1598 1541 (make-pathname 1599 1542 :defaults defaults :version :newest :case :local 1600 :name ( concatenate 'stringname ".asd")1543 :name (strcat name ".asd") 1601 1544 :type "lnk"))) 1602 1545 (when (probe-file* shortcut) … … 1672 1615 1673 1616 (defmethod find-system ((name null) &optional (error-p t)) 1617 (declare (ignorable name)) 1674 1618 (when error-p 1675 1619 (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) … … 1691 1635 (funcall thunk)))) 1692 1636 1693 (defmacro with-system-definitions (( ) &body body)1637 (defmacro with-system-definitions ((&optional) &body body) 1694 1638 `(call-with-system-definitions #'(lambda () ,@body))) 1695 1639 … … 1707 1651 (*default-pathname-defaults* 1708 1652 (pathname-directory-pathname pathname))) 1709 ;;; XXX Under ABCL, if the PATHNAME is a JAR-PATHNAME the 1710 ;;; MERGE-PATHNAMES are perhaps a bit wonky. 1653 ;;; XXX Kludge for ABCL ticket #181 1711 1654 #+abcl 1712 1655 (when (ext:pathname-jar-p pathname) … … 1718 1661 (delete-package package))))) 1719 1662 1720 (defmethod find-system ((name string) &optional (error-p t)) 1721 (with-system-definitions () 1722 (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk 1723 (previous (cdr in-memory)) 1724 (previous (and (typep previous 'system) previous)) 1725 (previous-time (car in-memory)) 1663 (defun* locate-system (name) 1664 "Given a system NAME designator, try to locate where to load the system from. 1665 Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME 1666 FOUNDP is true when a new was found, either a new unregistered one or a previously registered one. 1667 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is 1668 PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system. 1669 PREVIOUS when not null is a previously loaded SYSTEM object of same name. 1670 PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." 1671 (let* ((name (coerce-name name)) 1672 (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk 1673 (previous (cdr in-memory)) 1674 (previous (and (typep previous 'system) previous)) 1675 (previous-time (car in-memory)) 1726 1676 (found (search-for-system-definition name)) 1727 (found-system (and (typep found 'system) found)) 1728 (pathname (or (and (typep found '(or pathname string)) (pathname found)) 1729 (and found-system (system-source-file found-system)) 1730 (and previous (system-source-file previous))))) 1677 (found-system (and (typep found 'system) found)) 1678 (pathname (or (and (typep found '(or pathname string)) (pathname found)) 1679 (and found-system (system-source-file found-system)) 1680 (and previous (system-source-file previous)))) 1681 (foundp (and (or found-system pathname previous) t))) 1682 (check-type found (or null pathname system)) 1683 (when foundp 1731 1684 (setf pathname (resolve-symlinks* pathname)) 1732 1685 (when (and pathname (not (absolute-pathname-p pathname))) … … 1738 1691 (%set-system-source-file pathname previous) 1739 1692 (setf previous-time nil)) 1740 (when (and found-system (not previous)) 1741 (register-system found-system)) 1742 (when (and pathname 1743 (or (not previous-time) 1744 ;; don't reload if it's already been loaded, 1745 ;; or its filestamp is in the future which means some clock is skewed 1746 ;; and trying to load might cause an infinite loop. 1747 (< previous-time (safe-file-write-date pathname) (get-universal-time)))) 1748 (load-sysdef name pathname)) 1749 (let ((in-memory (system-registered-p name))) ; try again after loading from disk 1750 (cond 1751 (in-memory 1752 (when pathname 1753 (setf (car in-memory) (safe-file-write-date pathname))) 1754 (cdr in-memory)) 1755 (error-p 1756 (error 'missing-component :requires name))))))) 1693 (values foundp found-system pathname previous previous-time)))) 1694 1695 (defmethod find-system ((name string) &optional (error-p t)) 1696 (with-system-definitions () 1697 (loop 1698 (restart-case 1699 (multiple-value-bind (foundp found-system pathname previous previous-time) 1700 (locate-system name) 1701 (declare (ignore foundp)) 1702 (when (and found-system (not previous)) 1703 (register-system found-system)) 1704 (when (and pathname 1705 (or (not previous-time) 1706 ;; don't reload if it's already been loaded, 1707 ;; or its filestamp is in the future which means some clock is skewed 1708 ;; and trying to load might cause an infinite loop. 1709 (< previous-time (safe-file-write-date pathname) (get-universal-time)))) 1710 (load-sysdef name pathname)) 1711 (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed 1712 (return 1713 (cond 1714 (in-memory 1715 (when pathname 1716 (setf (car in-memory) (safe-file-write-date pathname))) 1717 (cdr in-memory)) 1718 (error-p 1719 (error 'missing-component :requires name)))))) 1720 (reinitialize-source-registry-and-retry () 1721 :report (lambda (s) 1722 (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name)) 1723 (initialize-source-registry)))))) 1757 1724 1758 1725 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) … … 1880 1847 (pathname-directory-pathname pathname)))) 1881 1848 1882 (defun* try-subpathname (pathname subpath &key type) 1883 (let* ((sp (and pathname (probe-file* pathname) 1884 (subpathname pathname subpath :type type))) 1885 (ts (and sp (probe-file* sp)))) 1886 (and ts (values sp ts)))) 1887 1849 (defun subpathname* (pathname subpath &key type) 1850 (and pathname 1851 (subpathname (ensure-directory-pathname pathname) subpath :type type))) 1888 1852 1889 1853 ;;;; ------------------------------------------------------------------------- … … 1989 1953 1990 1954 (defmethod component-self-dependencies ((o operation) (c component)) 1991 (let ((all-deps (component-depends-on o c))) 1992 (remove-if-not #'(lambda (x) 1993 (member (component-name c) (cdr x) :test #'string=)) 1994 all-deps))) 1955 (remove-if-not 1956 #'(lambda (x) (member (component-name c) (cdr x) :test #'string=)) 1957 (component-depends-on o c))) 1995 1958 1996 1959 (defmethod input-files ((operation operation) (c component)) … … 2364 2327 (around-compile-hook (component-parent c))))) 2365 2328 2329 (defun ensure-function (fun &key (package :asdf)) 2330 (etypecase fun 2331 ((or symbol function) fun) 2332 (cons (eval `(function ,fun))) 2333 (string (eval `(function ,(with-standard-io-syntax 2334 (let ((*package* (find-package package))) 2335 (read-from-string fun)))))))) 2336 2366 2337 (defmethod call-with-around-compile-hook ((c component) thunk) 2367 2338 (let ((hook (around-compile-hook c))) 2368 2339 (if hook 2369 (funcall hookthunk)2340 (funcall (ensure-function hook) thunk) 2370 2341 (funcall thunk)))) 2371 2342 … … 2553 2524 (defgeneric* perform-plan (plan &key)) 2554 2525 2526 ;;;; Separating this into a different function makes it more forward-compatible 2527 (defun* cleanup-upgraded-asdf (old-version) 2528 (let ((new-version (asdf:asdf-version))) 2529 (unless (equal old-version new-version) 2530 (cond 2531 ((version-satisfies new-version old-version) 2532 (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") 2533 old-version new-version)) 2534 ((version-satisfies old-version new-version) 2535 (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") 2536 old-version new-version)) 2537 (t 2538 (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") 2539 old-version new-version))) 2540 (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) 2541 ;; Invalidate all systems but ASDF itself. 2542 (setf *defined-systems* (make-defined-systems-table)) 2543 (register-system asdf) 2544 ;; If we're in the middle of something, restart it. 2545 (when *systems-being-defined* 2546 (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) 2547 (clrhash *systems-being-defined*) 2548 (dolist (s l) (find-system s nil)))) 2549 t)))) 2550 2555 2551 ;;;; Try to upgrade of ASDF. If a different version was used, return T. 2556 2552 ;;;; We need do that before we operate on anything that depends on ASDF. … … 2559 2555 (handler-bind (((or style-warning warning) #'muffle-warning)) 2560 2556 (operate 'load-op :asdf :verbose nil)) 2561 (let ((new-version (asdf:asdf-version))) 2562 (block nil 2563 (cond 2564 ((equal version new-version) 2565 (return nil)) 2566 ((version-satisfies new-version version) 2567 (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") 2568 version new-version)) 2569 ((version-satisfies version new-version) 2570 (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%") 2571 version new-version)) 2572 (t 2573 (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") 2574 version new-version))) 2575 (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) 2576 ;; invalidate all systems but ASDF itself 2577 (setf *defined-systems* (make-defined-systems-table)) 2578 (register-system asdf) 2579 t))))) 2557 (cleanup-upgraded-asdf version))) 2580 2558 2581 2559 (defmethod perform-plan ((steps list) &key) … … 2641 2619 (setf (documentation 'oos 'function) 2642 2620 (format nil 2643 "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"2621 "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" 2644 2622 operate-docstring)) 2645 2623 (setf (documentation 'operate 'function) … … 2652 2630 (apply 'operate 'load-op system args) 2653 2631 t) 2632 2633 (defun* load-systems (&rest systems) 2634 (map () 'load-system systems)) 2654 2635 2655 2636 (defun* compile-system (system &rest args &key force verbose version … … 2709 2690 (progn 2710 2691 (aif (assoc op2 (cdr first-op-tree)) 2711 (if (find c (cdr it) )2692 (if (find c (cdr it) :test #'equal) 2712 2693 nil 2713 2694 (setf (cdr it) (cons c (cdr it)))) … … 2731 2712 2732 2713 (defun* sysdef-error-component (msg type name value) 2733 (sysdef-error (concatenate 'string msg 2734 (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) 2714 (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) 2735 2715 type name value)) 2736 2716 … … 2809 2789 version name parent))) 2810 2790 2811 (let* ((other-args (remove-keys 2812 '(components pathname default-component-class 2813 perform explain output-files operation-done-p 2814 weakly-depends-on 2815 depends-on serial in-order-to) 2816 rest)) 2791 (let* ((args (list* :name (coerce-name name) 2792 :pathname pathname 2793 :parent parent 2794 (remove-keys 2795 '(components pathname default-component-class 2796 perform explain output-files operation-done-p 2797 weakly-depends-on depends-on serial in-order-to) 2798 rest))) 2817 2799 (ret (find-component parent name))) 2818 2800 (when weakly-depends-on … … 2820 2802 (when *serial-depends-on* 2821 2803 (push *serial-depends-on* depends-on)) 2822 (if ret 2823 (apply 'reinitialize-instance ret 2824 :name (coerce-name name) 2825 :pathname pathname 2826 :parent parent 2827 other-args) 2828 (setf ret 2829 (apply 'make-instance (class-for-type parent type) 2830 :name (coerce-name name) 2831 :pathname pathname 2832 :parent parent 2833 other-args))) 2804 (if ret ; preserve identity 2805 (apply 'reinitialize-instance ret args) 2806 (setf ret (apply 'make-instance (class-for-type parent type) args))) 2834 2807 (component-pathname ret) ; eagerly compute the absolute pathname 2835 2808 (when (typep ret 'module) … … 2863 2836 ret))) 2864 2837 2838 (defun* reset-system (system &rest keys &key &allow-other-keys) 2839 (change-class (change-class system 'proto-system) 'system) 2840 (apply 'reinitialize-instance system keys)) 2841 2865 2842 (defun* do-defsystem (name &rest options 2866 2843 &key pathname (class 'system) … … 2875 2852 (let* ((name (coerce-name name)) 2876 2853 (registered (system-registered-p name)) 2877 (system (cdr (or registered 2878 (register-system (make-instance 'system :name name))))) 2854 (registered! (if registered 2855 (rplaca registered (get-universal-time)) 2856 (register-system (make-instance 'system :name name)))) 2857 (system (reset-system (cdr registered!) 2858 :name name :source-file (load-pathname))) 2879 2859 (component-options (remove-keys '(:class) options))) 2880 (%set-system-source-file (load-pathname) system)2881 2860 (setf (gethash name *systems-being-defined*) system) 2882 (when registered 2883 (setf (car registered) (get-universal-time))) 2884 (map () 'load-system defsystem-depends-on) 2861 (apply 'load-systems defsystem-depends-on) 2885 2862 ;; We change-class (when necessary) AFTER we load the defsystem-dep's 2886 2863 ;; since the class might not be defined as part of those. … … 2967 2944 (cond 2968 2945 ((os-unix-p) "/bin/sh") 2969 ((os-windows-p) ( format nil "CMD /C ~A" command)) ; BEWARE!2946 ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE! 2970 2947 (t (error "Unsupported OS"))) 2971 2948 (if (os-unix-p) (list "-c" command) '()) … … 2978 2955 (list "-c" command) 2979 2956 :input nil :output *verbose-out*)) 2957 2958 #+cormanlisp 2959 (win32:system command) 2980 2960 2981 2961 #+ecl ;; courtesy of Juan Jose Garcia Ripoll … … 3169 3149 (defun* user-configuration-directories () 3170 3150 (let ((dirs 3171 `(,(try-subpathname (getenv "XDG_CONFIG_HOME") "common-lisp/") 3172 ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") 3173 :for dir :in (split-string dirs :separator ":") 3174 :collect (try-subpathname dir "common-lisp/")) 3151 `(,@(when (os-unix-p) 3152 (cons 3153 (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/") 3154 (loop :with dirs = (getenv "XDG_CONFIG_DIRS") 3155 :for dir :in (split-string dirs :separator ":") 3156 :collect (subpathname* dir "common-lisp/")))) 3175 3157 ,@(when (os-windows-p) 3176 `(,( try-subpathname(or #+lispworks (sys:get-folder-path :local-appdata)3177 3178 3158 `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata) 3159 (getenv "LOCALAPPDATA")) 3160 "common-lisp/config/") 3179 3161 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData 3180 ,(try-subpathname (or #+lispworks (sys:get-folder-path :appdata) 3181 (getenv "APPDATA")) 3182 "common-lisp/config/"))) 3183 ,(try-subpathname (user-homedir) ".config/common-lisp/")))) 3184 (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) 3162 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata) 3163 (getenv "APPDATA")) 3164 "common-lisp/config/"))) 3165 ,(subpathname (user-homedir) ".config/common-lisp/")))) 3166 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) 3167 :from-end t :test 'equal))) 3185 3168 3186 3169 (defun* system-configuration-directories () … … 3190 3173 (aif 3191 3174 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData 3192 ( try-subpathname(or #+lispworks (sys:get-folder-path :common-appdata)3193 3194 (subpathname(getenv "ALLUSERSPROFILE") "Application Data/"))3195 3175 (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata) 3176 (getenv "ALLUSERSAPPDATA") 3177 (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")) 3178 "common-lisp/config/") 3196 3179 (list it))))) 3197 3180 3198 (defun* in-first-directory (dirs x) 3199 (loop :for dir :in dirs 3200 :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) 3201 (defun* in-user-configuration-directory (x) 3202 (in-first-directory (user-configuration-directories) x)) 3203 (defun* in-system-configuration-directory (x) 3204 (in-first-directory (system-configuration-directories) x)) 3181 (defun* in-first-directory (dirs x &key (direction :input)) 3182 (loop :with fun = (ecase direction 3183 ((nil :input :probe) 'probe-file*) 3184 ((:output :io) 'identity)) 3185 :for dir :in dirs 3186 :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir)))))) 3187 3188 (defun* in-user-configuration-directory (x &key (direction :input)) 3189 (in-first-directory (user-configuration-directories) x :direction direction)) 3190 (defun* in-system-configuration-directory (x &key (direction :input)) 3191 (in-first-directory (system-configuration-directories) x :direction direction)) 3205 3192 3206 3193 (defun* configuration-inheritance-directive-p (x) … … 3556 3543 (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) 3557 3544 3558 (defun* user-output-translations-pathname ( )3559 (in-user-configuration-directory *output-translations-file* ))3560 (defun* system-output-translations-pathname ( )3561 (in-system-configuration-directory *output-translations-file* ))3562 (defun* user-output-translations-directory-pathname ( )3563 (in-user-configuration-directory *output-translations-directory* ))3564 (defun* system-output-translations-directory-pathname ( )3565 (in-system-configuration-directory *output-translations-directory* ))3545 (defun* user-output-translations-pathname (&key (direction :input)) 3546 (in-user-configuration-directory *output-translations-file* :direction direction)) 3547 (defun* system-output-translations-pathname (&key (direction :input)) 3548 (in-system-configuration-directory *output-translations-file* :direction direction)) 3549 (defun* user-output-translations-directory-pathname (&key (direction :input)) 3550 (in-user-configuration-directory *output-translations-directory* :direction direction)) 3551 (defun* system-output-translations-directory-pathname (&key (direction :input)) 3552 (in-system-configuration-directory *output-translations-directory* :direction direction)) 3566 3553 (defun* environment-output-translations () 3567 3554 (getenv "ASDF_OUTPUT_TRANSLATIONS")) … … 3686 3673 3687 3674 (defun* apply-output-translations (path) 3675 #+cormanlisp (truenamize path) #-cormanlisp 3688 3676 (etypecase path 3689 #+cormanlisp (t (truenamize path))3690 3677 (logical-pathname 3691 3678 path) … … 3728 3715 (defun* tmpize-pathname (x) 3729 3716 (make-pathname 3730 :name ( format nil "ASDF-TMP-~A" (pathname-name x))3717 :name (strcat "ASDF-TMP-" (pathname-name x)) 3731 3718 :defaults x)) 3732 3719 … … 3859 3846 :for p = (or (and (typep f 'logical-pathname) f) 3860 3847 (let* ((u (ignore-errors (funcall merger f)))) 3848 ;; The first u avoids a cumbersome (truename u) error 3861 3849 (and u (equal (ignore-errors (truename u)) f) u))) 3862 3850 :when p :collect p) … … 3872 3860 directory entries 3873 3861 #'(lambda (f) 3874 (make-pathname :defaults directory :version (pathname-version f) 3875 :name (pathname-name f) :type (pathname-type f)))))) 3862 (make-pathname :defaults directory 3863 :name (pathname-name f) :type (ununspecific (pathname-type f)) 3864 :version (ununspecific (pathname-version f))))))) 3876 3865 3877 3866 (defun* directory-asd-files (directory) … … 3882 3871 #-(or abcl cormanlisp genera xcl) 3883 3872 (wild (merge-pathnames* 3884 #-(or abcl allegro cmu lispworks s cl xcl)3873 #-(or abcl allegro cmu lispworks sbcl scl xcl) 3885 3874 *wild-directory* 3886 #+(or abcl allegro cmu lispworks s cl xcl) "*.*"3875 #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" 3887 3876 directory)) 3888 3877 (dirs … … 3894 3883 #+cormanlisp (cl::directory-subdirs directory) 3895 3884 #+genera (fs:directory-list directory)) 3896 #+(or abcl allegro cmu genera lispworks s cl xcl)3885 #+(or abcl allegro cmu genera lispworks sbcl scl xcl) 3897 3886 (dirs (loop :for x :in dirs 3898 3887 :for d = #+(or abcl xcl) (extensions:probe-directory x) 3899 3888 #+allegro (excl:probe-directory x) 3900 #+(or cmu s cl) (directory-pathname-p x)3889 #+(or cmu sbcl scl) (directory-pathname-p x) 3901 3890 #+genera (getf (cdr x) :directory) 3902 3891 #+lispworks (lw:file-directory-p x) 3903 3892 :when d :collect #+(or abcl allegro xcl) d 3904 3893 #+genera (ensure-directory-pathname (first x)) 3905 #+(or cmu lispworks s cl) x)))3894 #+(or cmu lispworks sbcl scl) x))) 3906 3895 (filter-logical-directory-results 3907 3896 directory dirs … … 4028 4017 (defun* default-source-registry () 4029 4018 `(:source-registry 4030 #+sbcl (:directory ,( try-subpathname (user-homedir) ".sbcl/systems/"))4019 #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) 4031 4020 (:directory ,(default-directory)) 4032 4021 ,@(loop :for dir :in 4033 4022 `(,@(when (os-unix-p) 4034 4023 `(,(or (getenv "XDG_DATA_HOME") 4035 ( try-subpathname (user-homedir) ".local/share/"))4024 (subpathname (user-homedir) ".local/share/")) 4036 4025 ,@(split-string (or (getenv "XDG_DATA_DIRS") 4037 4026 "/usr/local/share:/usr/share") … … 4044 4033 ,(or #+lispworks (sys:get-folder-path :common-appdata) 4045 4034 (getenv "ALLUSERSAPPDATA") 4046 ( try-subpathname(getenv "ALLUSERSPROFILE") "Application Data/")))))4047 :collect `(:directory ,( try-subpathnamedir "common-lisp/systems/"))4048 :collect `(:tree ,( try-subpathnamedir "common-lisp/source/")))4035 (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))))) 4036 :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) 4037 :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) 4049 4038 :inherit-configuration)) 4050 (defun* user-source-registry ( )4051 (in-user-configuration-directory *source-registry-file* ))4052 (defun* system-source-registry ( )4053 (in-system-configuration-directory *source-registry-file* ))4054 (defun* user-source-registry-directory ( )4055 (in-user-configuration-directory *source-registry-directory* ))4056 (defun* system-source-registry-directory ( )4057 (in-system-configuration-directory *source-registry-directory* ))4039 (defun* user-source-registry (&key (direction :input)) 4040 (in-user-configuration-directory *source-registry-file* :direction direction)) 4041 (defun* system-source-registry (&key (direction :input)) 4042 (in-system-configuration-directory *source-registry-file* :direction direction)) 4043 (defun* user-source-registry-directory (&key (direction :input)) 4044 (in-user-configuration-directory *source-registry-directory* :direction direction)) 4045 (defun* system-source-registry-directory (&key (direction :input)) 4046 (in-system-configuration-directory *source-registry-directory* :direction direction)) 4058 4047 (defun* environment-source-registry () 4059 4048 (getenv "CL_SOURCE_REGISTRY")) … … 4133 4122 :test 'equal :from-end t))) 4134 4123 4135 ;; Will read the configuration and initialize all internal variables, 4136 ;; and return the new configuration. 4124 ;; Will read the configuration and initialize all internal variables. 4137 4125 (defun* compute-source-registry (&optional parameter (registry *source-registry*)) 4138 4126 (dolist (entry (flatten-source-registry parameter))
Note: See TracChangeset
for help on using the changeset viewer.