Changeset 15207
- Timestamp:
- Feb 13, 2012, 6:09:49 PM (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/tools/asdf.lisp
r15098 r15207 1 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-2 ;;; This is ASDF 2. 017: Another System Definition Facility.1 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- 2 ;;; This is ASDF 2.20: Another System Definition Facility. 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* 62 62 (remove "asdf" excl::*autoload-package-name-alist* 63 63 :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below 64 #+(and ecl (not ecl-bytecmp)) (require :cmp) 64 #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) 65 #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp)) 65 66 #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 66 67 (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all … … 68 69 (< system::*gcl-minor-version* 7))) 69 70 (pushnew :gcl-pre2.7 *features*)) 70 #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)71 #+(or unix cygwin) (pushnew :asdf-unix *features*)72 71 ;;; make package if it doesn't exist yet. 73 72 ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. … … 89 88 ;; Strip out formatting that is not supported on Genera. 90 89 ;; Has to be inside the eval-when to make Lispworks happy (!) 90 (defun strcat (&rest strings) 91 (apply 'concatenate 'string strings)) 91 92 (defmacro compatfmt (format) 92 93 #-(or gcl genera) format 93 94 #+(or gcl genera) 94 95 (loop :for (unsupported . replacement) :in 95 `(("~3i~_" . "") 96 #+genera 97 ,@(("~@<" . "") 98 ("; ~@;" . "; ") 99 ("~@:>" . "") 100 ("~:>" . ""))) :do 96 (append 97 '(("~3i~_" . "")) 98 #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do 101 99 (loop :for found = (search unsupported format) :while found :do 102 (setf format 103 (concatenate 'simple-string 104 (subseq format 0 found) replacement 105 (subseq format (+ found (length unsupported))))))) 100 (setf format (strcat (subseq format 0 found) replacement 101 (subseq format (+ found (length unsupported))))))) 106 102 format) 107 103 (let* (;; For bug reporting sanity, please always bump this version when you modify this file. … … 113 109 ;; "2.345.0.7" would be your seventh local modification of official release 2.345 114 110 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 115 (asdf-version "2. 017")111 (asdf-version "2.20") 116 112 (existing-asdf (find-class 'component nil)) 117 113 (existing-version *asdf-version*) … … 191 187 (push sym formerly-exported-symbols))) 192 188 (loop :for sym :in export :do 193 (unless (member sym bothly-exported-symbols :test ' string-equal)189 (unless (member sym bothly-exported-symbols :test 'equal) 194 190 (push sym newly-exported-symbols))) 195 191 (loop :for user :in (package-used-by-list package) … … 201 197 (loop :for x :in newly-exported-symbols :do 202 198 (export (intern* x package))))) 203 (ensure-package (name &key nicknames use unintern fmakunbound204 199 (ensure-package (name &key nicknames use unintern 200 shadow export redefined-functions) 205 201 (let* ((p (ensure-exists name nicknames use))) 206 202 (ensure-unintern p unintern) 207 203 (ensure-shadow p shadow) 208 204 (ensure-export p export) 209 (ensure-fmakunbound p (append fmakunbound redefined-functions))205 (ensure-fmakunbound p redefined-functions) 210 206 p))) 211 207 (macrolet 212 208 ((pkgdcl (name &key nicknames use export 213 redefined-functions unintern fmakunboundshadow)209 redefined-functions unintern shadow) 214 210 `(ensure-package 215 211 ',name :nicknames ',nicknames :use ',use :export ',export 216 212 :shadow ',shadow 217 213 :unintern ',unintern 218 :redefined-functions ',redefined-functions 219 :fmakunbound ',fmakunbound))) 214 :redefined-functions ',redefined-functions))) 220 215 (pkgdcl 221 216 :asdf … … 227 222 #:system-source-file #:operate #:find-component #:find-system 228 223 #:apply-output-translations #:translate-pathname* #:resolve-location 224 #:system-relative-pathname 225 #:inherit-source-registry #:process-source-registry 226 #:process-source-registry-directive 229 227 #:compile-file* #:source-file-type) 230 228 :unintern 231 229 (#:*asdf-revision* #:around #:asdf-method-combination 232 #:split #:make-collector 230 #:split #:make-collector #:do-dep #:do-one-dep 231 #:resolve-relative-location-component #:resolve-absolute-location-component 233 232 #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function 234 :fmakunbound235 (#:system-source-file236 #:component-relative-pathname #:system-relative-pathname237 #:process-source-registry238 #:inherit-source-registry #:process-source-registry-directive)239 233 :export 240 (#:defsystem #:oos #:operate #:find-system #: run-shell-command234 (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command 241 235 #:system-definition-pathname #:with-system-definitions 242 #:search-for-system-definition #:find-component ; miscellaneous 243 #:compile-system #:load-system #:test-system #:clear-system 244 #:compile-op #:load-op #:load-source-op 245 #:test-op 246 #:operation ; operations 247 #:feature ; sort-of operation 248 #:version ; metaphorically sort-of an operation 249 #:version-satisfies 236 #:search-for-system-definition #:find-component #:component-find-path 237 #:compile-system #:load-system #:load-systems #:test-system #:clear-system 238 #:operation #:compile-op #:load-op #:load-source-op #:test-op 239 #:feature #:version #:version-satisfies 250 240 #:upgrade-asdf 251 241 #:implementation-identifier #:implementation-type 252 253 #:input-files #:output-files #:output-file #:perform ; operation methods 242 #:input-files #:output-files #:output-file #:perform 254 243 #:operation-done-p #:explain 255 244 … … 299 288 #:*compile-file-failure-behaviour* 300 289 #:*resolve-symlinks* 290 #:*require-asdf-operator* 301 291 #:*asdf-verbose* 292 #:*verbose-out* 302 293 303 294 #:asdf-version … … 341 332 #:system-registered-p 342 333 #:asdf-message 334 #:user-output-translations-pathname 335 #:system-output-translations-pathname 336 #:user-output-translations-directory-pathname 337 #:system-output-translations-directory-pathname 338 #:user-source-registry 339 #:system-source-registry 340 #:user-source-registry-directory 341 #:system-source-registry-directory 343 342 344 343 ;; Utilities 345 344 #:absolute-pathname-p 346 345 ;; #:aif #:it 347 ;; #:appendf 346 ;; #:appendf #:orf 348 347 #:coerce-name 349 348 #:directory-pathname-p … … 353 352 ;; #:length=n-p 354 353 ;; #:find-symbol* 355 #:merge-pathnames* 356 #:coerce-pathname 354 #:merge-pathnames* #:coerce-pathname #:subpathname 357 355 #:pathname-directory-pathname 358 356 #:read-file-forms … … 417 415 condition-format condition-location 418 416 coerce-name) 417 (ftype (function (&optional t) (values)) initialize-source-registry) 419 418 #-(or cormanlisp gcl-pre2.7) 420 419 (ftype (function (t t) t) (setf module-components-by-name))) … … 425 424 (progn 426 425 (deftype logical-pathname () nil) 427 (defun *make-broadcast-stream () *error-output*)428 (defun *file-namestring (p)426 (defun make-broadcast-stream () *error-output*) 427 (defun file-namestring (p) 429 428 (setf p (pathname p)) 430 429 (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) … … 526 525 :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) 527 526 527 (defun* ununspecific (x) 528 (if (eq x :unspecific) nil x)) 529 528 530 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) 529 531 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that … … 544 546 (type (or (pathname-type specified) (pathname-type defaults))) 545 547 (version (or (pathname-version specified) (pathname-version defaults)))) 546 (labels ((ununspecific (x) 547 (if (eq x :unspecific) nil x)) 548 (unspecific-handler (p) 548 (labels ((unspecific-handler (p) 549 549 (if (typep p 'logical-pathname) #'ununspecific #'identity))) 550 550 (multiple-value-bind (host device directory unspecific-handler) … … 676 676 (defun* getenv (x) 677 677 (declare (ignorable x)) 678 #+(or abcl clisp xcl) (ext:getenv x)678 #+(or abcl clisp ecl xcl) (ext:getenv x) 679 679 #+allegro (sys:getenv x) 680 680 #+clozure (ccl:getenv x) … … 690 690 (ct:free buffer) 691 691 (ct:free buffer1))) 692 #+ecl (si:getenv x)693 692 #+gcl (system:getenv x) 694 693 #+genera nil … … 898 897 (port (ext:pathname-port pathname)) 899 898 (directory (pathname-directory pathname))) 900 (flet ((not-unspecific (component) 901 (and (not (eq component :unspecific)) component))) 902 (cond ((or (not-unspecific port) 903 (and (not-unspecific host) (plusp (length host))) 904 (not-unspecific scheme)) 905 (let ((prefix "")) 906 (when (not-unspecific port) 907 (setf prefix (format nil ":~D" port))) 908 (when (and (not-unspecific host) (plusp (length host))) 909 (setf prefix (concatenate 'string host prefix))) 910 (setf prefix (concatenate 'string ":" prefix)) 911 (when (not-unspecific scheme) 912 (setf prefix (concatenate 'string scheme prefix))) 913 (assert (and directory (eq (first directory) :absolute))) 914 (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) 915 :defaults pathname))) 916 (t 917 pathname))))) 899 (if (or (ununspecific port) 900 (and (ununspecific host) (plusp (length host))) 901 (ununspecific scheme)) 902 (let ((prefix "")) 903 (when (ununspecific port) 904 (setf prefix (format nil ":~D" port))) 905 (when (and (ununspecific host) (plusp (length host))) 906 (setf prefix (strcat host prefix))) 907 (setf prefix (strcat ":" prefix)) 908 (when (ununspecific scheme) 909 (setf prefix (strcat scheme prefix))) 910 (assert (and directory (eq (first directory) :absolute))) 911 (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) 912 :defaults pathname))) 913 pathname)) 918 914 919 915 ;;;; ------------------------------------------------------------------------- … … 923 919 (defgeneric* perform (operation component)) 924 920 (defgeneric* operation-done-p (operation component)) 921 (defgeneric* mark-operation-done (operation component)) 925 922 (defgeneric* explain (operation component)) 926 923 (defgeneric* output-files (operation component)) … … 1167 1164 ;; it to default in funky ways if not supplied 1168 1165 (relative-pathname :initarg :pathname) 1166 ;; the absolute-pathname is computed based on relative-pathname... 1169 1167 (absolute-pathname) 1170 1168 (operation-times :initform (make-hash-table) 1171 1169 :accessor component-operation-times) 1170 (around-compile :initarg :around-compile) 1172 1171 ;; XXX we should provide some atomic interface for updating the 1173 1172 ;; component properties … … 1280 1279 new-value) 1281 1280 1282 (defclass system (module) 1281 (defclass proto-system () ; slots to keep when resetting a system 1282 ;; To preserve identity for all objects, we'd need keep the components slots 1283 ;; but also to modify parse-component-form to reset the recycled objects. 1284 ((name) #|(components) (components-by-names)|#)) 1285 1286 (defclass system (module proto-system) 1283 1287 (;; description and long-description are now available for all component's, 1284 1288 ;; but now also inherited from component, but we add the legacy accessor … … 1289 1293 (licence :accessor system-licence :initarg :licence 1290 1294 :accessor system-license :initarg :license) 1291 (source-file :reader system-source-file :initarg :source-file1295 (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade 1292 1296 :writer %set-system-source-file) 1293 1297 (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) … … 1341 1345 (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) 1342 1346 1347 ;;;; ----------------------------------------------------------------- 1348 ;;;; Windows shortcut support. Based on: 1349 ;;;; 1350 ;;;; Jesse Hager: The Windows Shortcut File Format. 1351 ;;;; http://www.wotsit.org/list.asp?fc=13 1352 1353 #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. 1354 (progn 1355 (defparameter *link-initial-dword* 76) 1356 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) 1357 1358 (defun* read-null-terminated-string (s) 1359 (with-output-to-string (out) 1360 (loop :for code = (read-byte s) 1361 :until (zerop code) 1362 :do (write-char (code-char code) out)))) 1363 1364 (defun* read-little-endian (s &optional (bytes 4)) 1365 (loop :for i :from 0 :below bytes 1366 :sum (ash (read-byte s) (* 8 i)))) 1367 1368 (defun* parse-file-location-info (s) 1369 (let ((start (file-position s)) 1370 (total-length (read-little-endian s)) 1371 (end-of-header (read-little-endian s)) 1372 (fli-flags (read-little-endian s)) 1373 (local-volume-offset (read-little-endian s)) 1374 (local-offset (read-little-endian s)) 1375 (network-volume-offset (read-little-endian s)) 1376 (remaining-offset (read-little-endian s))) 1377 (declare (ignore total-length end-of-header local-volume-offset)) 1378 (unless (zerop fli-flags) 1379 (cond 1380 ((logbitp 0 fli-flags) 1381 (file-position s (+ start local-offset))) 1382 ((logbitp 1 fli-flags) 1383 (file-position s (+ start 1384 network-volume-offset 1385 #x14)))) 1386 (strcat (read-null-terminated-string s) 1387 (progn 1388 (file-position s (+ start remaining-offset)) 1389 (read-null-terminated-string s)))))) 1390 1391 (defun* parse-windows-shortcut (pathname) 1392 (with-open-file (s pathname :element-type '(unsigned-byte 8)) 1393 (handler-case 1394 (when (and (= (read-little-endian s) *link-initial-dword*) 1395 (let ((header (make-array (length *link-guid*)))) 1396 (read-sequence header s) 1397 (equalp header *link-guid*))) 1398 (let ((flags (read-little-endian s))) 1399 (file-position s 76) ;skip rest of header 1400 (when (logbitp 0 flags) 1401 ;; skip shell item id list 1402 (let ((length (read-little-endian s 2))) 1403 (file-position s (+ length (file-position s))))) 1404 (cond 1405 ((logbitp 1 flags) 1406 (parse-file-location-info s)) 1407 (t 1408 (when (logbitp 2 flags) 1409 ;; skip description string 1410 (let ((length (read-little-endian s 2))) 1411 (file-position s (+ length (file-position s))))) 1412 (when (logbitp 3 flags) 1413 ;; finally, our pathname 1414 (let* ((length (read-little-endian s 2)) 1415 (buffer (make-array length))) 1416 (read-sequence buffer s) 1417 (map 'string #'code-char buffer))))))) 1418 (end-of-file () 1419 nil))))) 1420 1343 1421 ;;;; ------------------------------------------------------------------------- 1344 1422 ;;;; Finding systems … … 1396 1474 ;;; convention that functions in this list are prefixed SYSDEF- 1397 1475 1398 (defparameter *system-definition-search-functions* 1399 '(sysdef-central-registry-search 1400 sysdef-source-registry-search 1401 sysdef-find-asdf)) 1476 (defvar *system-definition-search-functions* '()) 1477 1478 (setf *system-definition-search-functions* 1479 (append 1480 ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. 1481 (remove 'contrib-sysdef-search *system-definition-search-functions*) 1482 ;; Tuck our defaults at the end of the list if they were absent. 1483 ;; This is imperfect, in case they were removed on purpose, 1484 ;; but then it will be the responsibility of whoever does that 1485 ;; to upgrade asdf before he does such a thing rather than after. 1486 (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) 1487 '(sysdef-central-registry-search 1488 sysdef-source-registry-search 1489 sysdef-find-asdf)))) 1402 1490 1403 1491 (defun* search-for-system-definition (system) 1404 ( let ((system-name (coerce-name system)))1405 (some #'(lambda (x) (funcall x system-name))1406 (cons 'find-system-if-being-defined *system-definition-search-functions*))))1492 (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) 1493 (cons 'find-system-if-being-defined 1494 *system-definition-search-functions*))) 1407 1495 1408 1496 (defvar *central-registry* nil … … 1420 1508 Going forward, we recommend new users should be using the source-registry. 1421 1509 ") 1510 1511 (defun* featurep (x &optional (features *features*)) 1512 (cond 1513 ((atom x) 1514 (and (member x features) t)) 1515 ((eq :not (car x)) 1516 (assert (null (cddr x))) 1517 (not (featurep (cadr x) features))) 1518 ((eq :or (car x)) 1519 (some #'(lambda (x) (featurep x features)) (cdr x))) 1520 ((eq :and (car x)) 1521 (every #'(lambda (x) (featurep x features)) (cdr x))) 1522 (t 1523 (error "Malformed feature specification ~S" x)))) 1524 1525 (defun* os-unix-p () 1526 (featurep '(:or :unix :cygwin :darwin))) 1527 1528 (defun* os-windows-p () 1529 (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) 1422 1530 1423 1531 (defun* probe-asd (name defaults) … … 1429 1537 (when (probe-file* file) 1430 1538 (return file))) 1431 #+(and asdf-windows (not clisp)) 1432 (let ((shortcut 1433 (make-pathname 1434 :defaults defaults :version :newest :case :local 1435 :name (concatenate 'string name ".asd") 1436 :type "lnk"))) 1437 (when (probe-file* shortcut) 1438 (let ((target (parse-windows-shortcut shortcut))) 1439 (when target 1440 (return (pathname target))))))))) 1539 #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) 1540 (when (os-windows-p) 1541 (let ((shortcut 1542 (make-pathname 1543 :defaults defaults :version :newest :case :local 1544 :name (strcat name ".asd") 1545 :type "lnk"))) 1546 (when (probe-file* shortcut) 1547 (let ((target (parse-windows-shortcut shortcut))) 1548 (when target 1549 (return (pathname target)))))))))) 1441 1550 1442 1551 (defun* sysdef-central-registry-search (system) … … 1507 1616 1508 1617 (defmethod find-system ((name null) &optional (error-p t)) 1618 (declare (ignorable name)) 1509 1619 (when error-p 1510 1620 (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) … … 1526 1636 (funcall thunk)))) 1527 1637 1528 (defmacro with-system-definitions (( ) &body body)1638 (defmacro with-system-definitions ((&optional) &body body) 1529 1639 `(call-with-system-definitions #'(lambda () ,@body))) 1530 1640 … … 1539 1649 :name name :pathname pathname 1540 1650 :condition condition)))) 1541 (let ((*package* package)) 1651 (let ((*package* package) 1652 (*default-pathname-defaults* 1653 (pathname-directory-pathname pathname))) 1542 1654 (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") 1543 1655 pathname package) … … 1545 1657 (delete-package package))))) 1546 1658 1547 (defmethod find-system ((name string) &optional (error-p t)) 1548 (with-system-definitions () 1549 (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk 1550 (previous (cdr in-memory)) 1551 (previous (and (typep previous 'system) previous)) 1552 (previous-time (car in-memory)) 1659 (defun* locate-system (name) 1660 "Given a system NAME designator, try to locate where to load the system from. 1661 Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME 1662 FOUNDP is true when a new was found, either a new unregistered one or a previously registered one. 1663 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is 1664 PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system. 1665 PREVIOUS when not null is a previously loaded SYSTEM object of same name. 1666 PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." 1667 (let* ((name (coerce-name name)) 1668 (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk 1669 (previous (cdr in-memory)) 1670 (previous (and (typep previous 'system) previous)) 1671 (previous-time (car in-memory)) 1553 1672 (found (search-for-system-definition name)) 1554 (found-system (and (typep found 'system) found)) 1555 (pathname (or (and (typep found '(or pathname string)) (pathname found)) 1556 (and found-system (system-source-file found-system)) 1557 (and previous (system-source-file previous))))) 1673 (found-system (and (typep found 'system) found)) 1674 (pathname (or (and (typep found '(or pathname string)) (pathname found)) 1675 (and found-system (system-source-file found-system)) 1676 (and previous (system-source-file previous)))) 1677 (foundp (and (or found-system pathname previous) t))) 1678 (check-type found (or null pathname system)) 1679 (when foundp 1558 1680 (setf pathname (resolve-symlinks* pathname)) 1559 1681 (when (and pathname (not (absolute-pathname-p pathname))) … … 1565 1687 (%set-system-source-file pathname previous) 1566 1688 (setf previous-time nil)) 1567 (when (and found-system (not previous)) 1568 (register-system found-system)) 1569 (when (and pathname 1570 (or (not previous-time) 1571 ;; don't reload if it's already been loaded, 1572 ;; or its filestamp is in the future which means some clock is skewed 1573 ;; and trying to load might cause an infinite loop. 1574 (< previous-time (safe-file-write-date pathname) (get-universal-time)))) 1575 (load-sysdef name pathname)) 1576 (let ((in-memory (system-registered-p name))) ; try again after loading from disk 1577 (cond 1578 (in-memory 1579 (when pathname 1580 (setf (car in-memory) (safe-file-write-date pathname))) 1581 (cdr in-memory)) 1582 (error-p 1583 (error 'missing-component :requires name))))))) 1689 (values foundp found-system pathname previous previous-time)))) 1690 1691 (defmethod find-system ((name string) &optional (error-p t)) 1692 (with-system-definitions () 1693 (loop 1694 (restart-case 1695 (multiple-value-bind (foundp found-system pathname previous previous-time) 1696 (locate-system name) 1697 (declare (ignore foundp)) 1698 (when (and found-system (not previous)) 1699 (register-system found-system)) 1700 (when (and pathname 1701 (or (not previous-time) 1702 ;; don't reload if it's already been loaded, 1703 ;; or its filestamp is in the future which means some clock is skewed 1704 ;; and trying to load might cause an infinite loop. 1705 (< previous-time (safe-file-write-date pathname) (get-universal-time)))) 1706 (load-sysdef name pathname)) 1707 (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed 1708 (return 1709 (cond 1710 (in-memory 1711 (when pathname 1712 (setf (car in-memory) (safe-file-write-date pathname))) 1713 (cdr in-memory)) 1714 (error-p 1715 (error 'missing-component :requires name)))))) 1716 (reinitialize-source-registry-and-retry () 1717 :report (lambda (s) 1718 (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name)) 1719 (initialize-source-registry)))))) 1584 1720 1585 1721 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) … … 1703 1839 :defaults (component-parent-pathname component))) 1704 1840 1841 (defun* subpathname (pathname subpath &key type) 1842 (and pathname (merge-pathnames* (coerce-pathname subpath :type type) 1843 (pathname-directory-pathname pathname)))) 1844 1845 (defun subpathname* (pathname subpath &key type) 1846 (and pathname 1847 (subpathname (ensure-directory-pathname pathname) subpath :type type))) 1848 1705 1849 ;;;; ------------------------------------------------------------------------- 1706 1850 ;;;; Operations … … 1805 1949 1806 1950 (defmethod component-self-dependencies ((o operation) (c component)) 1807 (let ((all-deps (component-depends-on o c))) 1808 (remove-if-not #'(lambda (x) 1809 (member (component-name c) (cdr x) :test #'string=)) 1810 all-deps))) 1951 (remove-if-not 1952 #'(lambda (x) (member (component-name c) (cdr x) :test #'string=)) 1953 (component-depends-on o c))) 1811 1954 1812 1955 (defmethod input-files ((operation operation) (c component)) … … 1852 1995 (and op-time (>= op-time (latest-in)))) 1853 1996 ((not in-files) 1854 ;; an operation with outoutput-files and no input-files1997 ;; an operation with output-files and no input-files 1855 1998 ;; is probably meant for its side-effects on the file-system, 1856 1999 ;; assumed to have to be done everytime. … … 1894 2037 (defgeneric* do-traverse (operation component collect)) 1895 2038 1896 (defun* %do-one-dep (operation c collect required-op required-c required-v) 1897 ;; collects a partial plan that results from performing required-op 1898 ;; on required-c, possibly with a required-vERSION 1899 (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c))) 1900 (and d (version-satisfies d required-v) d)) 1901 (if required-v 1902 (error 'missing-dependency-of-version 1903 :required-by c 1904 :version required-v 1905 :requires required-c) 1906 (error 'missing-dependency 1907 :required-by c 1908 :requires required-c)))) 1909 (op (make-sub-operation c operation dep-c required-op))) 1910 (do-traverse op dep-c collect))) 1911 1912 (defun* do-one-dep (operation c collect required-op required-c required-v) 1913 ;; this function is a thin, error-handling wrapper around %do-one-dep. 1914 ;; Collects a partial plan per that function. 2039 (defun* resolve-dependency-name (component name &optional version) 1915 2040 (loop 1916 2041 (restart-case 1917 (return (%do-one-dep operation c collect 1918 required-op required-c required-v)) 2042 (return 2043 (let ((comp (find-component (component-parent component) name))) 2044 (unless comp 2045 (error 'missing-dependency 2046 :required-by component 2047 :requires name)) 2048 (when version 2049 (unless (version-satisfies comp version) 2050 (error 'missing-dependency-of-version 2051 :required-by component 2052 :version version 2053 :requires name))) 2054 comp)) 1919 2055 (retry () 1920 2056 :report (lambda (s) 1921 (format s "~@<Retry loading ~3i~_~A.~@:>" required-c))2057 (format s "~@<Retry loading ~3i~_~A.~@:>" name)) 1922 2058 :test 1923 2059 (lambda (c) 1924 2060 (or (null c) 1925 2061 (and (typep c 'missing-dependency) 1926 (equalp (missing-requires c) 1927 required-c)))))))) 1928 1929 (defun* do-dep (operation c collect op dep) 1930 ;; type of arguments uncertain: 1931 ;; op seems to at least potentially be a symbol, rather than an operation 1932 ;; dep is a list of component names 1933 (cond ((eq op 'feature) 1934 (if (member (car dep) *features*) 2062 (eq (missing-required-by c) component) 2063 (equal (missing-requires c) name)))))))) 2064 2065 (defun* resolve-dependency-spec (component dep-spec) 2066 (cond 2067 ((atom dep-spec) 2068 (resolve-dependency-name component dep-spec)) 2069 ;; Structured dependencies --- this parses keywords. 2070 ;; The keywords could conceivably be broken out and cleanly (extensibly) 2071 ;; processed by EQL methods. But for now, here's what we've got. 2072 ((eq :version (first dep-spec)) 2073 ;; https://bugs.launchpad.net/asdf/+bug/527788 2074 (resolve-dependency-name component (second dep-spec) (third dep-spec))) 2075 ((eq :feature (first dep-spec)) 2076 ;; This particular subform is not documented and 2077 ;; has always been broken in the past. 2078 ;; Therefore no one uses it, and I'm cerroring it out, 2079 ;; after fixing it 2080 ;; See https://bugs.launchpad.net/asdf/+bug/518467 2081 (cerror "Continue nonetheless." 2082 "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") 2083 (when (find (second dep-spec) *features* :test 'string-equal) 2084 (resolve-dependency-name component (third dep-spec)))) 2085 (t 2086 (error (compatfmt "~@<Bad dependency ~s. Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec)))) 2087 2088 (defun* do-one-dep (op c collect dep-op dep-c) 2089 ;; Collects a partial plan for performing dep-op on dep-c 2090 ;; as dependencies of a larger plan involving op and c. 2091 ;; Returns t if this should force recompilation of those who depend on us. 2092 ;; dep-op is an operation class name (not an operation object), 2093 ;; whereas dep-c is a component object.n 2094 (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect)) 2095 2096 (defun* do-dep (op c collect dep-op-spec dep-c-specs) 2097 ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs 2098 ;; as dependencies of a larger plan involving op and c. 2099 ;; Returns t if this should force recompilation of those who depend on us. 2100 ;; dep-op-spec is either an operation class name (not an operation object), 2101 ;; or the magic symbol asdf:feature. 2102 ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword, 2103 ;; and the plan will succeed if that keyword is present in *feature*, 2104 ;; or fail if it isn't 2105 ;; (at which point c's :if-component-dep-fails will kick in). 2106 ;; If dep-op-spec is an operation class name, 2107 ;; then dep-c-specs specifies a list of sibling component of c, 2108 ;; as per resolve-dependency-spec, such that operating op on c 2109 ;; depends on operating dep-op-spec on each of them. 2110 (cond ((eq dep-op-spec 'feature) 2111 (if (member (car dep-c-specs) *features*) 1935 2112 nil 1936 2113 (error 'missing-dependency 1937 2114 :required-by c 1938 :requires ( car dep))))2115 :requires (list :feature (car dep-c-specs))))) 1939 2116 (t 1940 2117 (let ((flag nil)) 1941 (flet ((dep (op comp ver) 1942 (when (do-one-dep operation c collect 1943 op comp ver) 1944 (setf flag t)))) 1945 (dolist (d dep) 1946 (if (atom d) 1947 (dep op d nil) 1948 ;; structured dependencies --- this parses keywords 1949 ;; the keywords could be broken out and cleanly (extensibly) 1950 ;; processed by EQL methods 1951 (cond ((eq :version (first d)) 1952 ;; https://bugs.launchpad.net/asdf/+bug/527788 1953 (dep op (second d) (third d))) 1954 ;; This particular subform is not documented and 1955 ;; has always been broken in the past. 1956 ;; Therefore no one uses it, and I'm cerroring it out, 1957 ;; after fixing it 1958 ;; See https://bugs.launchpad.net/asdf/+bug/518467 1959 ((eq :feature (first d)) 1960 (cerror "Continue nonetheless." 1961 "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") 1962 (when (find (second d) *features* :test 'string-equal) 1963 (dep op (third d) nil))) 1964 (t 1965 (error (compatfmt "~@<Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name.~@:>") d)))))) 2118 (dolist (d dep-c-specs) 2119 (when (do-one-dep op c collect dep-op-spec 2120 (resolve-dependency-spec c d)) 2121 (setf flag t))) 1966 2122 flag)))) 1967 2123 … … 2024 2180 (update-flag 2025 2181 (do-traverse operation kid #'internal-collect)) 2182 #-genera 2026 2183 (missing-dependency (condition) 2027 2184 (when (eq (module-if-component-dep-fails c) … … 2088 2245 nil) 2089 2246 2247 (defmethod mark-operation-done ((operation operation) (c component)) 2248 (setf (gethash (type-of operation) (component-operation-times c)) 2249 (reduce #'max 2250 (cons (get-universal-time) 2251 (mapcar #'safe-file-write-date (input-files operation c)))))) 2252 2253 (defmethod perform-with-restarts (operation component) 2254 ;; TOO verbose, especially as the default. Add your own :before method 2255 ;; to perform-with-restart or perform if you want that: 2256 #|(when *asdf-verbose* (explain operation component))|# 2257 (perform operation component)) 2258 2259 (defmethod perform-with-restarts :around (operation component) 2260 (loop 2261 (restart-case 2262 (return (call-next-method)) 2263 (retry () 2264 :report 2265 (lambda (s) 2266 (format s (compatfmt "~@<Retry ~A.~@:>") 2267 (operation-description operation component)))) 2268 (accept () 2269 :report 2270 (lambda (s) 2271 (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") 2272 (operation-description operation component))) 2273 (mark-operation-done operation component) 2274 (return))))) 2275 2090 2276 (defmethod explain ((operation operation) (component component)) 2091 2277 (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") … … 2114 2300 (first files))) 2115 2301 2302 (defun* ensure-all-directories-exist (pathnames) 2303 (loop :for pn :in pathnames 2304 :for pathname = (if (typep pn 'logical-pathname) 2305 (translate-logical-pathname pn) 2306 pn) 2307 :do (ensure-directories-exist pathname))) 2308 2116 2309 (defmethod perform :before ((operation compile-op) (c source-file)) 2117 (loop :for file :in (asdf:output-files operation c) 2118 :for pathname = (if (typep file 'logical-pathname) 2119 (translate-logical-pathname file) 2120 file) 2121 :do (ensure-directories-exist pathname))) 2310 (ensure-all-directories-exist (asdf:output-files operation c))) 2122 2311 2123 2312 (defmethod perform :after ((operation operation) (c component)) 2124 (setf (gethash (type-of operation) (component-operation-times c)) 2125 (get-universal-time))) 2313 (mark-operation-done operation c)) 2314 2315 (defgeneric* around-compile-hook (component)) 2316 (defgeneric* call-with-around-compile-hook (component thunk)) 2317 2318 (defmethod around-compile-hook ((c component)) 2319 (cond 2320 ((slot-boundp c 'around-compile) 2321 (slot-value c 'around-compile)) 2322 ((component-parent c) 2323 (around-compile-hook (component-parent c))))) 2324 2325 (defun ensure-function (fun &key (package :asdf)) 2326 (etypecase fun 2327 ((or symbol function) fun) 2328 (cons (eval `(function ,fun))) 2329 (string (eval `(function ,(with-standard-io-syntax 2330 (let ((*package* (find-package package))) 2331 (read-from-string fun)))))))) 2332 2333 (defmethod call-with-around-compile-hook ((c component) thunk) 2334 (let ((hook (around-compile-hook c))) 2335 (if hook 2336 (funcall (ensure-function hook) thunk) 2337 (funcall thunk)))) 2126 2338 2127 2339 (defvar *compile-op-compile-file-function* 'compile-file* … … 2139 2351 (*compile-file-failure-behaviour* (operation-on-failure operation))) 2140 2352 (multiple-value-bind (output warnings-p failure-p) 2141 (apply *compile-op-compile-file-function* source-file 2142 :output-file output-file (compile-op-flags operation)) 2353 (call-with-around-compile-hook 2354 c #'(lambda () 2355 (apply *compile-op-compile-file-function* source-file 2356 :output-file output-file (compile-op-flags operation)))) 2143 2357 (unless output 2144 2358 (error 'compile-error :component c :operation operation)) … … 2192 2406 (defclass load-op (basic-load-op) ()) 2193 2407 2408 (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) 2409 (loop 2410 (restart-case 2411 (return (call-next-method)) 2412 (try-recompiling () 2413 :report (lambda (s) 2414 (format s "Recompile ~a and try loading it again" 2415 (component-name c))) 2416 (perform (make-sub-operation c o c 'compile-op) c))))) 2417 2194 2418 (defmethod perform ((o load-op) (c cl-source-file)) 2195 2419 (map () #'load (input-files o c))) 2196 2197 (defmethod perform-with-restarts (operation component)2198 ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default.2199 (perform operation component))2200 2201 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))2202 (declare (ignorable o))2203 (loop :with state = :initial2204 :until (or (eq state :success)2205 (eq state :failure)) :do2206 (case state2207 (:recompiled2208 (setf state :failure)2209 (call-next-method)2210 (setf state :success))2211 (:failed-load2212 (setf state :recompiled)2213 (perform (make-sub-operation c o c 'compile-op) c))2214 (t2215 (with-simple-restart2216 (try-recompiling "Recompile ~a and try loading it again"2217 (component-name c))2218 (setf state :failed-load)2219 (call-next-method)2220 (setf state :success))))))2221 2222 (defmethod perform-with-restarts ((o compile-op) (c cl-source-file))2223 (loop :with state = :initial2224 :until (or (eq state :success)2225 (eq state :failure)) :do2226 (case state2227 (:recompiled2228 (setf state :failure)2229 (call-next-method)2230 (setf state :success))2231 (:failed-compile2232 (setf state :recompiled)2233 (perform-with-restarts o c))2234 (t2235 (with-simple-restart2236 (try-recompiling "Try recompiling ~a"2237 (component-name c))2238 (setf state :failed-compile)2239 (call-next-method)2240 (setf state :success))))))2241 2420 2242 2421 (defmethod perform ((operation load-op) (c static-file)) … … 2281 2460 (let ((source (component-pathname c))) 2282 2461 (setf (component-property c 'last-loaded-as-source) 2283 (and ( load source)2462 (and (call-with-around-compile-hook c #'(lambda () (load source))) 2284 2463 (get-universal-time))))) 2285 2464 … … 2341 2520 (defgeneric* perform-plan (plan &key)) 2342 2521 2522 ;;;; Separating this into a different function makes it more forward-compatible 2523 (defun* cleanup-upgraded-asdf (old-version) 2524 (let ((new-version (asdf:asdf-version))) 2525 (unless (equal old-version new-version) 2526 (cond 2527 ((version-satisfies new-version old-version) 2528 (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") 2529 old-version new-version)) 2530 ((version-satisfies old-version new-version) 2531 (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") 2532 old-version new-version)) 2533 (t 2534 (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") 2535 old-version new-version))) 2536 (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) 2537 ;; Invalidate all systems but ASDF itself. 2538 (setf *defined-systems* (make-defined-systems-table)) 2539 (register-system asdf) 2540 ;; If we're in the middle of something, restart it. 2541 (when *systems-being-defined* 2542 (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) 2543 (clrhash *systems-being-defined*) 2544 (dolist (s l) (find-system s nil)))) 2545 t)))) 2546 2343 2547 ;;;; Try to upgrade of ASDF. If a different version was used, return T. 2344 2548 ;;;; We need do that before we operate on anything that depends on ASDF. … … 2347 2551 (handler-bind (((or style-warning warning) #'muffle-warning)) 2348 2552 (operate 'load-op :asdf :verbose nil)) 2349 (let ((new-version (asdf:asdf-version))) 2350 (block nil 2351 (cond 2352 ((equal version new-version) 2353 (return nil)) 2354 ((version-satisfies new-version version) 2355 (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") 2356 version new-version)) 2357 ((version-satisfies version new-version) 2358 (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%") 2359 version new-version)) 2360 (t 2361 (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") 2362 version new-version))) 2363 (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) 2364 ;; invalidate all systems but ASDF itself 2365 (setf *defined-systems* (make-defined-systems-table)) 2366 (register-system asdf) 2367 t))))) 2553 (cleanup-upgraded-asdf version))) 2368 2554 2369 2555 (defmethod perform-plan ((steps list) &key) … … 2372 2558 (with-compilation-unit () 2373 2559 (loop :for (op . component) :in steps :do 2374 (loop 2375 (restart-case 2376 (progn 2377 (perform-with-restarts op component) 2378 (return)) 2379 (retry () 2380 :report 2381 (lambda (s) 2382 (format s (compatfmt "~@<Retry ~A.~@:>") 2383 (operation-description op component)))) 2384 (accept () 2385 :report 2386 (lambda (s) 2387 (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") 2388 (operation-description op component))) 2389 (setf (gethash (type-of op) 2390 (component-operation-times component)) 2391 (get-universal-time)) 2392 (return)))))))) 2560 (perform-with-restarts op component))))) 2393 2561 2394 2562 (defmethod operate (operation-class system &rest args … … 2447 2615 (setf (documentation 'oos 'function) 2448 2616 (format nil 2449 "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"2617 "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" 2450 2618 operate-docstring)) 2451 2619 (setf (documentation 'operate 'function) … … 2458 2626 (apply 'operate 'load-op system args) 2459 2627 t) 2628 2629 (defun* load-systems (&rest systems) 2630 (map () 'load-system systems)) 2460 2631 2461 2632 (defun* compile-system (system &rest args &key force verbose version … … 2481 2652 (resolve-symlinks* (or *load-pathname* *compile-file-pathname*))) 2482 2653 2483 (defun* determine-system-pathname (pathname pathname-supplied-p)2654 (defun* determine-system-pathname (pathname) 2484 2655 ;; The defsystem macro calls us to determine 2485 2656 ;; the pathname of a system as follows: … … 2489 2660 (let* ((file-pathname (load-pathname)) 2490 2661 (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) 2491 (or (and pathname-supplied-p 2492 (merge-pathnames* (coerce-pathname pathname :type :directory) 2493 directory-pathname)) 2662 (or (and pathname (subpathname directory-pathname pathname :type :directory)) 2494 2663 directory-pathname 2495 2664 (default-directory)))) … … 2517 2686 (progn 2518 2687 (aif (assoc op2 (cdr first-op-tree)) 2519 (if (find c (cdr it) )2688 (if (find c (cdr it) :test #'equal) 2520 2689 nil 2521 2690 (setf (cdr it) (cons c (cdr it)))) … … 2539 2708 2540 2709 (defun* sysdef-error-component (msg type name value) 2541 (sysdef-error (concatenate 'string msg 2542 (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) 2710 (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) 2543 2711 type name value)) 2544 2712 … … 2617 2785 version name parent))) 2618 2786 2619 (let* (( other-args (remove-keys2620 '(components pathname default-component-class2621 perform explain output-files operation-done-p2622 weakly-depends-on2623 depends-on serial in-order-to)2624 rest))2625 (ret2626 (or (find-component parent name)2627 (make-instance (class-for-type parent type)))))2787 (let* ((args (list* :name (coerce-name name) 2788 :pathname pathname 2789 :parent parent 2790 (remove-keys 2791 '(components pathname default-component-class 2792 perform explain output-files operation-done-p 2793 weakly-depends-on depends-on serial in-order-to) 2794 rest))) 2795 (ret (find-component parent name))) 2628 2796 (when weakly-depends-on 2629 (appendf depends-on (remove-if (complement #' find-system) weakly-depends-on)))2797 (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) 2630 2798 (when *serial-depends-on* 2631 2799 (push *serial-depends-on* depends-on)) 2632 (apply 'reinitialize-instance ret 2633 :name (coerce-name name) 2634 :pathname pathname 2635 :parent parent 2636 other-args) 2800 (if ret ; preserve identity 2801 (apply 'reinitialize-instance ret args) 2802 (setf ret (apply 'make-instance (class-for-type parent type) args))) 2637 2803 (component-pathname ret) ; eagerly compute the absolute pathname 2638 2804 (when (typep ret 'module) … … 2661 2827 (union-of-dependencies 2662 2828 do-first 2663 2829 `((compile-op (load-op ,@depends-on))))) 2664 2830 2665 2831 (%refresh-component-inline-methods ret rest) 2666 2832 ret))) 2667 2833 2834 (defun* reset-system (system &rest keys &key &allow-other-keys) 2835 (change-class (change-class system 'proto-system) 'system) 2836 (apply 'reinitialize-instance system keys)) 2837 2668 2838 (defun* do-defsystem (name &rest options 2669 &key (pathname nil pathname-arg-p)(class 'system)2839 &key pathname (class 'system) 2670 2840 defsystem-depends-on &allow-other-keys) 2671 2841 ;; The system must be registered before we parse the body, … … 2678 2848 (let* ((name (coerce-name name)) 2679 2849 (registered (system-registered-p name)) 2680 (system (cdr (or registered 2681 (register-system (make-instance 'system :name name))))) 2850 (registered! (if registered 2851 (rplaca registered (get-universal-time)) 2852 (register-system (make-instance 'system :name name)))) 2853 (system (reset-system (cdr registered!) 2854 :name name :source-file (load-pathname))) 2682 2855 (component-options (remove-keys '(:class) options))) 2683 (%set-system-source-file (load-pathname) system)2684 2856 (setf (gethash name *systems-being-defined*) system) 2685 (when registered 2686 (setf (car registered) (get-universal-time))) 2687 (map () 'load-system defsystem-depends-on) 2857 (apply 'load-systems defsystem-depends-on) 2688 2858 ;; We change-class (when necessary) AFTER we load the defsystem-dep's 2689 2859 ;; since the class might not be defined as part of those. … … 2694 2864 nil (list* 2695 2865 :module name 2696 :pathname (determine-system-pathname pathname pathname-arg-p)2866 :pathname (determine-system-pathname pathname) 2697 2867 component-options))))) 2698 2868 … … 2707 2877 ;;;; If the docstring is ambiguous, send a bug report. 2708 2878 ;;;; 2879 ;;;; WARNING! The function below is mostly dysfunctional. 2880 ;;;; For instance, it will probably run fine on most implementations on Unix, 2881 ;;;; which will hopefully use the shell /bin/sh (which we force in some cases) 2882 ;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell. 2883 ;;;; But behavior on Windows may vary wildly between implementations, 2884 ;;;; either relying on your having installed a POSIX sh, or going through 2885 ;;;; the CMD.EXE interpreter, for a totally different meaning, depending on 2886 ;;;; what is easily expressible in said implementation. 2887 ;;;; 2709 2888 ;;;; We probably should move this functionality to its own system and deprecate 2710 2889 ;;;; use of it from the asdf package. However, this would break unspecified … … 2712 2891 ;;;; it, and even after it's been deprecated, we will support it for a few 2713 2892 ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 2893 ;;;; 2894 ;;;; As a suggested replacement which is portable to all ASDF-supported 2895 ;;;; implementations and operating systems except Genera, I recommend 2896 ;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its 2897 ;;;; derivatives such as xcvb-driver:run-program/for-side-effects. 2714 2898 2715 2899 (defun* run-shell-command (control-string &rest args) … … 2727 2911 (multiple-value-bind (stdout stderr exit-code) 2728 2912 (excl.osi:command-output 2729 (format nil "~a -c \"~a\""2730 #+mswindows "sh" #-mswindows "/bin/sh" command)2913 #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command) 2914 #+mswindows command ; BEWARE! 2731 2915 :input nil :whole nil 2732 2916 #+mswindows :show-window #+mswindows :hide) 2733 (asdf-message "~{~& ;~a~%~}~%" stderr)2734 (asdf-message "~{~& ;~a~%~}~%" stdout)2917 (asdf-message "~{~&~a~%~}~%" stderr) 2918 (asdf-message "~{~&~a~%~}~%" stdout) 2735 2919 exit-code) 2736 2920 2737 #+clisp ;XXX not exactly *verbose-out*, I know 2738 (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0) 2921 #+clisp 2922 ;; CLISP returns NIL for exit status zero. 2923 (if *verbose-out* 2924 (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r" 2925 command)) 2926 (outstream (ext:run-shell-command new-command :output :stream :wait t))) 2927 (multiple-value-bind (retval out-lines) 2928 (unwind-protect 2929 (parse-clisp-shell-output outstream) 2930 (ignore-errors (close outstream))) 2931 (asdf-message "~{~&~a~%~}~%" out-lines) 2932 retval)) 2933 ;; there will be no output, just grab up the exit status 2934 (or (ext:run-shell-command command :output nil :wait t) 0)) 2739 2935 2740 2936 #+clozure 2741 2937 (nth-value 1 2742 2938 (ccl:external-process-status 2743 (ccl:run-program "/bin/sh" (list "-c" command) 2744 :input nil :output *verbose-out* 2745 :wait t))) 2939 (ccl:run-program 2940 (cond 2941 ((os-unix-p) "/bin/sh") 2942 ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE! 2943 (t (error "Unsupported OS"))) 2944 (if (os-unix-p) (list "-c" command) '()) 2945 :input nil :output *verbose-out* :wait t))) 2746 2946 2747 2947 #+(or cmu scl) … … 2749 2949 (ext:run-program 2750 2950 "/bin/sh" 2751 (list 2951 (list "-c" command) 2752 2952 :input nil :output *verbose-out*)) 2753 2953 2954 #+cormanlisp 2955 (win32:system command) 2956 2754 2957 #+ecl ;; courtesy of Juan Jose Garcia Ripoll 2755 ( si:system command)2958 (ext:system command) 2756 2959 2757 2960 #+gcl … … 2759 2962 2760 2963 #+lispworks 2761 (system:call-system-showing-output 2762 command 2763 :shell-type "/bin/sh" 2764 :show-cmd nil 2765 :prefix "" 2766 :output-stream *verbose-out*) 2964 (apply 'system:call-system-showing-output command 2965 :show-cmd nil :prefix "" :output-stream *verbose-out* 2966 (when (os-unix-p) '(:shell-type "/bin/sh"))) 2767 2967 2768 2968 #+mcl … … 2782 2982 #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl) 2783 2983 (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) 2984 2985 #+clisp 2986 (defun* parse-clisp-shell-output (stream) 2987 "Helper function for running shell commands under clisp. Parses a specially- 2988 crafted output string to recover the exit status of the shell command and a 2989 list of lines of output." 2990 (loop :with status-prefix = "ASDF-EXIT-STATUS " 2991 :with prefix-length = (length status-prefix) 2992 :with exit-status = -1 :with lines = () 2993 :for line = (read-line stream nil nil) 2994 :while line :do (push line lines) :finally 2995 (let* ((last (car lines)) 2996 (status (and last (>= (length last) prefix-length) 2997 (string-equal last status-prefix :end1 prefix-length) 2998 (parse-integer last :start prefix-length :junk-allowed t)))) 2999 (when status 3000 (setf exit-status status) 3001 (pop lines) (when (equal "" (car lines)) (pop lines))) 3002 (return (values exit-status (reverse lines)))))) 2784 3003 2785 3004 ;;;; --------------------------------------------------------------------------- … … 2799 3018 (system-source-file x)) 2800 3019 3020 (defmethod system-source-file ((system system)) 3021 (%system-source-file system)) 2801 3022 (defmethod system-source-file ((system-name string)) 2802 ( system-source-file (find-system system-name)))3023 (%system-source-file (find-system system-name))) 2803 3024 (defmethod system-source-file ((system-name symbol)) 2804 ( system-source-file (find-system system-name)))3025 (%system-source-file (find-system system-name))) 2805 3026 2806 3027 (defun* system-source-directory (system-designator) … … 2826 3047 2827 3048 (defun* system-relative-pathname (system name &key type) 2828 (merge-pathnames* 2829 (coerce-pathname name :type type) 2830 (system-source-directory system))) 3049 (subpathname (system-source-directory system) name :type type)) 2831 3050 2832 3051 … … 2836 3055 ;;; produce a string to identify current implementation. 2837 3056 ;;; Initially stolen from SLIME's SWANK, rewritten since. 2838 ;;; The (car '(...)) idiom avoids unreachable code warnings. 2839 2840 (defparameter *implementation-type* 2841 (car '(#+abcl :abcl #+allegro :acl 2842 #+clozure :ccl #+clisp :clisp #+cormanlisp :corman #+cmu :cmu 2843 #+ecl :ecl #+gcl :gcl #+lispworks :lw #+mcl :mcl 2844 #+sbcl :sbcl #+scl :scl #+symbolics :symbolic #+xcl :xcl))) 2845 2846 (defparameter *operating-system* 2847 (car '(#+cygwin :cygwin #+(or windows mswindows win32 mingw32) :win 2848 #+(or linux linux-target) :linux ;; for GCL at least, must appear before :bsd. 2849 #+(or macosx darwin darwin-target apple) :macosx ; also before :bsd 2850 #+(or solaris sunos) :solaris 2851 #+(or freebsd netbsd openbsd bsd) :bsd 2852 #+unix :unix 2853 #+genera :genera))) 2854 2855 (defparameter *architecture* 2856 (car '(#+(or amd64 x86-64 x86_64 x8664-target (and word-size=64 pc386)) :x64 2857 #+(or x86 i386 i486 i586 i686 pentium3 pentium4 pc386 iapx386 x8632-target) :x86 2858 #+hppa64 :hppa64 #+hppa :hppa 2859 #+(or ppc64 ppc64-target) :ppc64 2860 #+(or ppc32 ppc32-target ppc powerpc) :ppc32 2861 #+sparc64 :sparc64 #+(or sparc32 sparc) :sparc32 2862 #+(or arm arm-target) :arm 2863 #+(or java java-1.4 java-1.5 java-1.6 java-1.7) :java 2864 #+mipsel :mispel #+mipseb :mipseb #+mips :mips 2865 #+alpha :alpha #+imach :imach))) 2866 2867 (defparameter *lisp-version-string* 3057 ;;; We're back to runtime checking, for the sake of e.g. ABCL. 3058 3059 (defun* first-feature (features) 3060 (dolist (x features) 3061 (multiple-value-bind (val feature) 3062 (if (consp x) (values (first x) (cons :or (rest x))) (values x x)) 3063 (when (featurep feature) (return val))))) 3064 3065 (defun implementation-type () 3066 (first-feature 3067 '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu 3068 :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl))) 3069 3070 (defun operating-system () 3071 (first-feature 3072 '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! 3073 (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd 3074 (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd 3075 (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix 3076 :genera))) 3077 3078 (defun architecture () 3079 (first-feature 3080 '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386)) 3081 (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) 3082 (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) 3083 :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) 3084 :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach 3085 ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, 3086 ;; we may have to segregate the code still by architecture. 3087 (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) 3088 3089 #+clozure 3090 (defun* ccl-fasl-version () 3091 ;; the fasl version is target-dependent from CCL 1.8 on. 3092 (or (and (fboundp 'ccl::target-fasl-version) 3093 (funcall 'ccl::target-fasl-version)) 3094 (and (boundp 'ccl::fasl-version) 3095 (symbol-value 'ccl::fasl-version)) 3096 (error "Can't determine fasl version."))) 3097 3098 (defun lisp-version-string () 2868 3099 (let ((s (lisp-implementation-version))) 2869 (or 2870 #+allegro 2871 (format nil "~A~A~@[~A~]" 2872 excl::*common-lisp-version-number* 2873 ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox 2874 (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A") 2875 ;; Note if not using International ACL 2876 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm 2877 (excl:ics-target-case (:-ics "8"))) 2878 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) 2879 #+clisp 2880 (subseq s 0 (position #\space s)) ; strip build information (date, etc.) 2881 #+clozure 2882 (format nil "~d.~d-f~d" ; shorten for windows 2883 ccl::*openmcl-major-version* 2884 ccl::*openmcl-minor-version* 2885 (logand (ccl:target-fasl-version) #xFF)) 2886 #+cmu (substitute #\- #\/ s) 2887 #+ecl (format nil "~A~@[-~A~]" s 2888 (let ((vcs-id (ext:lisp-implementation-vcs-id))) 2889 (subseq vcs-id 0 (min (length vcs-id) 8)))) 2890 #+gcl (subseq s (1+ (position #\space s))) 2891 #+genera 2892 (multiple-value-bind (major minor) (sct:get-system-version "System") 2893 (format nil "~D.~D" major minor)) 2894 #+mcl (subseq s 8) ; strip the leading "Version " 2895 s))) 2896 2897 (defun* implementation-type () 2898 *implementation-type*) 3100 (car ; as opposed to OR, this idiom prevents some unreachable code warning 3101 (list 3102 #+allegro 3103 (format nil "~A~A~@[~A~]" 3104 excl::*common-lisp-version-number* 3105 ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox 3106 (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A") 3107 ;; Note if not using International ACL 3108 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm 3109 (excl:ics-target-case (:-ics "8"))) 3110 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) 3111 #+clisp 3112 (subseq s 0 (position #\space s)) ; strip build information (date, etc.) 3113 #+clozure 3114 (format nil "~d.~d-f~d" ; shorten for windows 3115 ccl::*openmcl-major-version* 3116 ccl::*openmcl-minor-version* 3117 (logand (ccl-fasl-version) #xFF)) 3118 #+cmu (substitute #\- #\/ s) 3119 #+scl (format nil "~A~A" s 3120 ;; ANSI upper case vs lower case. 3121 (ecase ext:*case-mode* (:upper "") (:lower "l"))) 3122 #+ecl (format nil "~A~@[-~A~]" s 3123 (let ((vcs-id (ext:lisp-implementation-vcs-id))) 3124 (subseq vcs-id 0 (min (length vcs-id) 8)))) 3125 #+gcl (subseq s (1+ (position #\space s))) 3126 #+genera 3127 (multiple-value-bind (major minor) (sct:get-system-version "System") 3128 (format nil "~D.~D" major minor)) 3129 #+mcl (subseq s 8) ; strip the leading "Version " 3130 s)))) 2899 3131 2900 3132 (defun* implementation-identifier () … … 2902 3134 #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) 2903 3135 (format nil "~(~a~@{~@[-~a~]~}~)" 2904 (or *implementation-type*(lisp-implementation-type))2905 (or *lisp-version-string*(lisp-implementation-version))2906 (or *operating-system*(software-type))2907 (or *architecture*(machine-type)))))3136 (or (implementation-type) (lisp-implementation-type)) 3137 (or (lisp-version-string) (lisp-implementation-version)) 3138 (or (operating-system) (software-type)) 3139 (or (architecture) (machine-type))))) 2908 3140 2909 3141 … … 2911 3143 ;;; Generic support for configuration files 2912 3144 2913 (defparameter *inter-directory-separator* 2914 #+asdf-unix #\: 2915 #-asdf-unix #\;) 3145 (defun inter-directory-separator () 3146 (if (os-unix-p) #\: #\;)) 2916 3147 2917 3148 (defun* user-homedir () … … 2921 3152 #-mcl (user-homedir-pathname)))) 2922 3153 2923 (defun* try-directory-subpath (x sub &key type) 2924 (let* ((p (and x (ensure-directory-pathname x))) 2925 (tp (and p (probe-file* p))) 2926 (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p))) 2927 (ts (and sp (probe-file* sp)))) 2928 (and ts (values sp ts)))) 3154 (defun* ensure-absolute-pathname* (x fmt &rest args) 3155 (and (plusp (length x)) 3156 (or (absolute-pathname-p x) 3157 (cerror "ignore relative pathname" 3158 "Invalid relative pathname ~A~@[ ~?~]" x fmt args)) 3159 x)) 3160 (defun* split-absolute-pathnames (x fmt &rest args) 3161 (loop :for dir :in (split-string 3162 x :separator (string (inter-directory-separator))) 3163 :do (apply 'ensure-absolute-pathname* dir fmt args) 3164 :collect dir)) 3165 (defun getenv-absolute-pathname (x &aux (s (getenv x))) 3166 (ensure-absolute-pathname* s "from (getenv ~S)" x)) 3167 (defun getenv-absolute-pathnames (x &aux (s (getenv x))) 3168 (split-absolute-pathnames s "from (getenv ~S) = ~S" x s)) 3169 2929 3170 (defun* user-configuration-directories () 2930 3171 (let ((dirs 2931 (flet ((try (x sub) (try-directory-subpath x sub)))2932 `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")2933 ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")2934 :for dir :in (split-string dirs :separator ":")2935 :collect (try dir "common-lisp/"))2936 #+asdf-windows2937 ,@`(,(try(or #+lispworks (sys:get-folder-path :local-appdata)2938 (getenv"LOCALAPPDATA"))2939 "common-lisp/config/")3172 `(,@(when (os-unix-p) 3173 (cons 3174 (subpathname* (getenv-absolute-pathname "XDG_CONFIG_HOME") "common-lisp/") 3175 (loop :for dir :in (getenv-absolute-pathnames "XDG_CONFIG_DIRS") 3176 :collect (subpathname* dir "common-lisp/")))) 3177 ,@(when (os-windows-p) 3178 `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata) 3179 (getenv-absolute-pathname "LOCALAPPDATA")) 3180 "common-lisp/config/") 2940 3181 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData 2941 ,(try (or #+lispworks (sys:get-folder-path :appdata) 2942 (getenv "APPDATA")) 2943 "common-lisp/config/")) 2944 ,(try (user-homedir) ".config/common-lisp/"))))) 2945 (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) 3182 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata) 3183 (getenv-absolute-pathname "APPDATA")) 3184 "common-lisp/config/"))) 3185 ,(subpathname (user-homedir) ".config/common-lisp/")))) 3186 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) 3187 :from-end t :test 'equal))) 3188 2946 3189 (defun* system-configuration-directories () 2947 (remove-if 2948 #'null 2949 `(#+asdf-windows 2950 ,(flet ((try (x sub) (try-directory-subpath x sub))) 2951 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData 2952 (try (or #+lispworks (sys:get-folder-path :common-appdata) 2953 (getenv "ALLUSERSAPPDATA") 2954 (try (getenv "ALLUSERSPROFILE") "Application Data/")) 2955 "common-lisp/config/")) 2956 #+asdf-unix #p"/etc/common-lisp/"))) 2957 2958 (defun* in-first-directory (dirs x) 2959 (loop :for dir :in dirs 2960 :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) 2961 (defun* in-user-configuration-directory (x) 2962 (in-first-directory (user-configuration-directories) x)) 2963 (defun* in-system-configuration-directory (x) 2964 (in-first-directory (system-configuration-directories) x)) 3190 (cond 3191 ((os-unix-p) '(#p"/etc/common-lisp/")) 3192 ((os-windows-p) 3193 (aif 3194 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData 3195 (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata) 3196 (getenv-absolute-pathname "ALLUSERSAPPDATA") 3197 (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/")) 3198 "common-lisp/config/") 3199 (list it))))) 3200 3201 (defun* in-first-directory (dirs x &key (direction :input)) 3202 (loop :with fun = (ecase direction 3203 ((nil :input :probe) 'probe-file*) 3204 ((:output :io) 'identity)) 3205 :for dir :in dirs 3206 :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir)))))) 3207 3208 (defun* in-user-configuration-directory (x &key (direction :input)) 3209 (in-first-directory (user-configuration-directories) x :direction direction)) 3210 (defun* in-system-configuration-directory (x &key (direction :input)) 3211 (in-first-directory (system-configuration-directories) x :direction direction)) 2965 3212 2966 3213 (defun* configuration-inheritance-directive-p (x) … … 3072 3319 (flet ((try (x &rest sub) (and x `(,x ,@sub)))) 3073 3320 (or 3074 (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)3075 #+asdf-windows3076 (try (or #+lispworks (sys:get-folder-path :local-appdata)3077 (getenv"LOCALAPPDATA")3078 #+lispworks (sys:get-folder-path :appdata)3079 (getenv"APPDATA"))3080 "common-lisp" "cache" :implementation)3321 (try (getenv-absolute-pathname "XDG_CACHE_HOME") "common-lisp" :implementation) 3322 (when (os-windows-p) 3323 (try (or #+lispworks (sys:get-folder-path :local-appdata) 3324 (getenv-absolute-pathname "LOCALAPPDATA") 3325 #+lispworks (sys:get-folder-path :appdata) 3326 (getenv-absolute-pathname "APPDATA")) 3327 "common-lisp" "cache" :implementation)) 3081 3328 '(:home ".cache" "common-lisp" :implementation)))) 3082 3329 … … 3205 3452 (typep c '(or string pathname 3206 3453 (member :default-directory :*/ :**/ :*.*.* 3207 :implementation :implementation-type 3208 #+asdf-unix :uid))))) 3454 :implementation :implementation-type))))) 3209 3455 (or (typep x 'boolean) 3210 3456 (absolute-component-p x) … … 3213 3459 (defun* location-function-p (x) 3214 3460 (and 3215 (consp x)3216 3461 (length=n-p x 2) 3217 ( or (and (equal (firstx) :function)3218 (typep (second x) 'symbol))3219 (and ( equal (first x) 'lambda)3220 ( cddr x)3221 (length=n-p ( secondx) 2)))))3462 (eq (car x) :function) 3463 (or (symbolp (cadr x)) 3464 (and (consp (cadr x)) 3465 (eq (caadr x) 'lambda) 3466 (length=n-p (cadadr x) 2))))) 3222 3467 3223 3468 (defun* validate-output-translations-directive (directive) … … 3266 3511 :with end = (length string) 3267 3512 :with source = nil 3268 :for i = (or (position *inter-directory-separator* string :start start) end) :do 3513 :with separator = (inter-directory-separator) 3514 :for i = (or (position separator string :start start) end) :do 3269 3515 (let ((s (subseq string start i))) 3270 3516 (cond … … 3316 3562 (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) 3317 3563 3318 (defun* user-output-translations-pathname ( )3319 (in-user-configuration-directory *output-translations-file* ))3320 (defun* system-output-translations-pathname ( )3321 (in-system-configuration-directory *output-translations-file* ))3322 (defun* user-output-translations-directory-pathname ( )3323 (in-user-configuration-directory *output-translations-directory* ))3324 (defun* system-output-translations-directory-pathname ( )3325 (in-system-configuration-directory *output-translations-directory* ))3564 (defun* user-output-translations-pathname (&key (direction :input)) 3565 (in-user-configuration-directory *output-translations-file* :direction direction)) 3566 (defun* system-output-translations-pathname (&key (direction :input)) 3567 (in-system-configuration-directory *output-translations-file* :direction direction)) 3568 (defun* user-output-translations-directory-pathname (&key (direction :input)) 3569 (in-user-configuration-directory *output-translations-directory* :direction direction)) 3570 (defun* system-output-translations-directory-pathname (&key (direction :input)) 3571 (in-system-configuration-directory *output-translations-directory* :direction direction)) 3326 3572 (defun* environment-output-translations () 3327 3573 (getenv "ASDF_OUTPUT_TRANSLATIONS")) … … 3446 3692 3447 3693 (defun* apply-output-translations (path) 3694 #+cormanlisp (truenamize path) #-cormanlisp 3448 3695 (etypecase path 3449 #+cormanlisp (t (truenamize path))3450 3696 (logical-pathname 3451 3697 path) … … 3468 3714 (defmethod output-files :around (operation component) 3469 3715 "Translate output files, unless asked not to" 3470 (declare (ignorable operation component))3716 operation component ;; hush genera, not convinced by declare ignorable(!) 3471 3717 (values 3472 3718 (multiple-value-bind (files fixedp) (call-next-method) … … 3488 3734 (defun* tmpize-pathname (x) 3489 3735 (make-pathname 3490 :name ( format nil "ASDF-TMP-~A" (pathname-name x))3736 :name (strcat "ASDF-TMP-" (pathname-name x)) 3491 3737 :defaults x)) 3492 3738 … … 3552 3798 (centralize-lisp-binaries nil) 3553 3799 (default-toplevel-directory 3554 ;; Use ".cache/common-lisp" instead ??? 3555 (merge-pathnames* (make-pathname :directory '(:relative ".fasls")) 3556 (user-homedir))) 3800 (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? 3557 3801 (include-per-user-information nil) 3558 3802 (map-all-source-files (or #+(or ecl clisp) t nil)) … … 3580 3824 3581 3825 ;;;; ----------------------------------------------------------------- 3582 ;;;; Windows shortcut support. Based on:3583 ;;;;3584 ;;;; Jesse Hager: The Windows Shortcut File Format.3585 ;;;; http://www.wotsit.org/list.asp?fc=133586 3587 #+(and asdf-windows (not clisp))3588 (progn3589 (defparameter *link-initial-dword* 76)3590 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))3591 3592 (defun* read-null-terminated-string (s)3593 (with-output-to-string (out)3594 (loop :for code = (read-byte s)3595 :until (zerop code)3596 :do (write-char (code-char code) out))))3597 3598 (defun* read-little-endian (s &optional (bytes 4))3599 (loop :for i :from 0 :below bytes3600 :sum (ash (read-byte s) (* 8 i))))3601 3602 (defun* parse-file-location-info (s)3603 (let ((start (file-position s))3604 (total-length (read-little-endian s))3605 (end-of-header (read-little-endian s))3606 (fli-flags (read-little-endian s))3607 (local-volume-offset (read-little-endian s))3608 (local-offset (read-little-endian s))3609 (network-volume-offset (read-little-endian s))3610 (remaining-offset (read-little-endian s)))3611 (declare (ignore total-length end-of-header local-volume-offset))3612 (unless (zerop fli-flags)3613 (cond3614 ((logbitp 0 fli-flags)3615 (file-position s (+ start local-offset)))3616 ((logbitp 1 fli-flags)3617 (file-position s (+ start3618 network-volume-offset3619 #x14))))3620 (concatenate 'string3621 (read-null-terminated-string s)3622 (progn3623 (file-position s (+ start remaining-offset))3624 (read-null-terminated-string s))))))3625 3626 (defun* parse-windows-shortcut (pathname)3627 (with-open-file (s pathname :element-type '(unsigned-byte 8))3628 (handler-case3629 (when (and (= (read-little-endian s) *link-initial-dword*)3630 (let ((header (make-array (length *link-guid*))))3631 (read-sequence header s)3632 (equalp header *link-guid*)))3633 (let ((flags (read-little-endian s)))3634 (file-position s 76) ;skip rest of header3635 (when (logbitp 0 flags)3636 ;; skip shell item id list3637 (let ((length (read-little-endian s 2)))3638 (file-position s (+ length (file-position s)))))3639 (cond3640 ((logbitp 1 flags)3641 (parse-file-location-info s))3642 (t3643 (when (logbitp 2 flags)3644 ;; skip description string3645 (let ((length (read-little-endian s 2)))3646 (file-position s (+ length (file-position s)))))3647 (when (logbitp 3 flags)3648 ;; finally, our pathname3649 (let* ((length (read-little-endian s 2))3650 (buffer (make-array length)))3651 (read-sequence buffer s)3652 (map 'string #'code-char buffer)))))))3653 (end-of-file ()3654 nil)))))3655 3656 ;;;; -----------------------------------------------------------------3657 3826 ;;;; Source Registry Configuration, by Francois-Rene Rideau 3658 3827 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 … … 3696 3865 :for p = (or (and (typep f 'logical-pathname) f) 3697 3866 (let* ((u (ignore-errors (funcall merger f)))) 3867 ;; The first u avoids a cumbersome (truename u) error 3698 3868 (and u (equal (ignore-errors (truename u)) f) u))) 3699 3869 :when p :collect p) … … 3709 3879 directory entries 3710 3880 #'(lambda (f) 3711 (make-pathname :defaults directory :version (pathname-version f) 3712 :name (pathname-name f) :type (pathname-type f)))))) 3881 (make-pathname :defaults directory 3882 :name (pathname-name f) :type (ununspecific (pathname-type f)) 3883 :version (ununspecific (pathname-version f))))))) 3713 3884 3714 3885 (defun* directory-asd-files (directory) … … 3719 3890 #-(or abcl cormanlisp genera xcl) 3720 3891 (wild (merge-pathnames* 3721 #-(or abcl allegro cmu lispworks s cl xcl)3892 #-(or abcl allegro cmu lispworks sbcl scl xcl) 3722 3893 *wild-directory* 3723 #+(or abcl allegro cmu lispworks s cl xcl) "*.*"3894 #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" 3724 3895 directory)) 3725 3896 (dirs … … 3731 3902 #+cormanlisp (cl::directory-subdirs directory) 3732 3903 #+genera (fs:directory-list directory)) 3733 #+(or abcl allegro cmu genera lispworks s cl xcl)3904 #+(or abcl allegro cmu genera lispworks sbcl scl xcl) 3734 3905 (dirs (loop :for x :in dirs 3735 3906 :for d = #+(or abcl xcl) (extensions:probe-directory x) 3736 3907 #+allegro (excl:probe-directory x) 3737 #+(or cmu s cl) (directory-pathname-p x)3908 #+(or cmu sbcl scl) (directory-pathname-p x) 3738 3909 #+genera (getf (cdr x) :directory) 3739 3910 #+lispworks (lw:file-directory-p x) 3740 3911 :when d :collect #+(or abcl allegro xcl) d 3741 3912 #+genera (ensure-directory-pathname (first x)) 3742 #+(or cmu lispworks s cl) x)))3913 #+(or cmu lispworks sbcl scl) x))) 3743 3914 (filter-logical-directory-results 3744 3915 directory dirs … … 3814 3985 :with start = 0 3815 3986 :with end = (length string) 3816 :for pos = (position *inter-directory-separator* string :start start) :do 3987 :with separator = (inter-directory-separator) 3988 :for pos = (position separator string :start start) :do 3817 3989 (let ((s (subseq string start (or pos end)))) 3818 3990 (flet ((check (dir) … … 3860 4032 #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME"))) 3861 4033 :inherit-configuration 3862 #+cmu (:tree #p"modules:"))) 4034 #+cmu (:tree #p"modules:") 4035 #+scl (:tree #p"file://modules/"))) 3863 4036 (defun* default-source-registry () 3864 (flet ((try (x sub) (try-directory-subpath x sub))) 3865 `(:source-registry 3866 #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/")) 3867 (:directory ,(default-directory)) 4037 `(:source-registry 4038 #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) 4039 (:directory ,(default-directory)) 3868 4040 ,@(loop :for dir :in 3869 `(#+asdf-unix 3870 ,@`(,(or (getenv "XDG_DATA_HOME") 3871 (try (user-homedir) ".local/share/")) 3872 ,@(split-string (or (getenv "XDG_DATA_DIRS") 3873 "/usr/local/share:/usr/share") 3874 :separator ":")) 3875 #+asdf-windows 3876 ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata) 3877 (getenv "LOCALAPPDATA")) 3878 ,(or #+lispworks (sys:get-folder-path :appdata) 3879 (getenv "APPDATA")) 3880 ,(or #+lispworks (sys:get-folder-path :common-appdata) 3881 (getenv "ALLUSERSAPPDATA") 3882 (try (getenv "ALLUSERSPROFILE") "Application Data/")))) 3883 :collect `(:directory ,(try dir "common-lisp/systems/")) 3884 :collect `(:tree ,(try dir "common-lisp/source/"))) 3885 :inherit-configuration))) 3886 (defun* user-source-registry () 3887 (in-user-configuration-directory *source-registry-file*)) 3888 (defun* system-source-registry () 3889 (in-system-configuration-directory *source-registry-file*)) 3890 (defun* user-source-registry-directory () 3891 (in-user-configuration-directory *source-registry-directory*)) 3892 (defun* system-source-registry-directory () 3893 (in-system-configuration-directory *source-registry-directory*)) 4041 `(,@(when (os-unix-p) 4042 `(,(or (getenv-absolute-pathname "XDG_DATA_HOME") 4043 (subpathname (user-homedir) ".local/share/")) 4044 ,@(or (getenv-absolute-pathnames "XDG_DATA_DIRS") 4045 '("/usr/local/share" "/usr/share")))) 4046 ,@(when (os-windows-p) 4047 `(,(or #+lispworks (sys:get-folder-path :local-appdata) 4048 (getenv-absolute-pathname "LOCALAPPDATA")) 4049 ,(or #+lispworks (sys:get-folder-path :appdata) 4050 (getenv-absolute-pathname "APPDATA")) 4051 ,(or #+lispworks (sys:get-folder-path :common-appdata) 4052 (getenv-absolute-pathname "ALLUSERSAPPDATA") 4053 (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/"))))) 4054 :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) 4055 :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) 4056 :inherit-configuration)) 4057 (defun* user-source-registry (&key (direction :input)) 4058 (in-user-configuration-directory *source-registry-file* :direction direction)) 4059 (defun* system-source-registry (&key (direction :input)) 4060 (in-system-configuration-directory *source-registry-file* :direction direction)) 4061 (defun* user-source-registry-directory (&key (direction :input)) 4062 (in-user-configuration-directory *source-registry-directory* :direction direction)) 4063 (defun* system-source-registry-directory (&key (direction :input)) 4064 (in-system-configuration-directory *source-registry-directory* :direction direction)) 3894 4065 (defun* environment-source-registry () 3895 4066 (getenv "CL_SOURCE_REGISTRY")) … … 3966 4137 ,@*default-source-registries*) 3967 4138 :register #'(lambda (directory &key recurse exclude) 3968 (collect (list directory :recurse recurse :exclude exclude))))) 3969 :test 'equal :from-end t))) 3970 3971 ;; Will read the configuration and initialize all internal variables, 3972 ;; and return the new configuration. 4139 (collect (list directory :recurse recurse :exclude exclude)))))) 4140 :test 'equal :from-end t)) 4141 4142 ;; Will read the configuration and initialize all internal variables. 3973 4143 (defun* compute-source-registry (&optional parameter (registry *source-registry*)) 3974 4144 (dolist (entry (flatten-source-registry parameter)) … … 4042 4212 #+ecl 4043 4213 (progn 4044 (setf *compile-op-compile-file-function* 4045 (lambda (input-file &rest keys &key output-file &allow-other-keys) 4046 (declare (ignore output-file)) 4047 (multiple-value-bind (object-file flags1 flags2) 4048 (apply 'compile-file* input-file :system-p t keys) 4049 (values (and object-file 4050 (c::build-fasl (compile-file-pathname object-file :type :fasl) 4051 :lisp-files (list object-file)) 4052 object-file) 4053 flags1 4054 flags2)))) 4214 (setf *compile-op-compile-file-function* 'ecl-compile-file) 4215 4216 (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys) 4217 (if (use-ecl-byte-compiler-p) 4218 (apply 'compile-file* input-file keys) 4219 (multiple-value-bind (object-file flags1 flags2) 4220 (apply 'compile-file* input-file :system-p t keys) 4221 (values (and object-file 4222 (c::build-fasl (compile-file-pathname object-file :type :fasl) 4223 :lisp-files (list object-file)) 4224 object-file) 4225 flags1 4226 flags2)))) 4055 4227 4056 4228 (defmethod output-files ((operation compile-op) (c cl-source-file)) 4057 4229 (declare (ignorable operation)) 4058 (let ((p (lispize-pathname (component-pathname c)))) 4059 (list (compile-file-pathname p :type :object) 4060 (compile-file-pathname p :type :fasl)))) 4230 (let* ((p (lispize-pathname (component-pathname c))) 4231 (f (compile-file-pathname p :type :fasl))) 4232 (if (use-ecl-byte-compiler-p) 4233 (list f) 4234 (list (compile-file-pathname p :type :object) f)))) 4061 4235 4062 4236 (defmethod perform ((o load-op) (c cl-source-file)) … … 4064 4238 (loop :for i :in (input-files o c) 4065 4239 :unless (string= (pathname-type i) "fas") 4066 :collect (compile-file-pathname (lispize-pathname i))))))4240 :collect (compile-file-pathname (lispize-pathname i)))))) 4067 4241 4068 4242 ;;;; ----------------------------------------------------------------- … … 4074 4248 (handler-bind 4075 4249 ((style-warning #'muffle-warning) 4250 #-genera 4076 4251 (missing-component (constantly nil)) 4077 4252 (error #'(lambda (e) … … 4091 4266 #+clisp ,x 4092 4267 #+clozure ccl:*module-provider-functions* 4093 #+cmu ext:*module-provider-functions* 4094 #+ecl si:*module-provider-functions* 4268 #+(or cmu ecl) ext:*module-provider-functions* 4095 4269 #+sbcl sb-ext:*module-provider-functions*)))) 4096 4270
Note: See TracChangeset
for help on using the changeset viewer.