Changeset 14688
- Timestamp:
- Mar 21, 2011, 1:25:16 PM (14 years ago)
- File:
-
- 1 edited
-
trunk/source/tools/asdf.lisp (modified) (105 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/tools/asdf.lisp
r14687 r14688 1 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp-*-2 ;;; This is ASDF 2.013: Another System Definition Facility.1 ;;; -*- mode: common-lisp; package: asdf; -*- 2 ;;; This is ASDF: Another System Definition Facility. 3 3 ;;; 4 4 ;;; Feedback, bug reports, and patches are all welcome: … … 11 11 ;;; location above for a more recent version (and for documentation 12 12 ;;; and test files, if your copy came without them) before reporting 13 ;;; bugs. There are usually two "supported" revisions - the git master14 ;;; branch is the latest development version, whereas the git release15 ;;; branchmay be slightly older but is considered `stable'13 ;;; bugs. There are usually two "supported" revisions - the git HEAD 14 ;;; is the latest development version, whereas the revision tagged 15 ;;; RELEASE may be slightly older but is considered `stable' 16 16 17 17 ;;; -- LICENSE START … … 48 48 #+xcvb (module ()) 49 49 50 (cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)50 (cl:in-package :cl-user) 51 51 52 52 #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this … … 56 56 ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. 57 57 (unless (find-package :asdf) 58 (make-package :asdf :use '(:c ommon-lisp)))58 (make-package :asdf :use '(:cl))) 59 59 ;;; Implementation-dependent tweaks 60 60 ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. … … 63 63 (remove "asdf" excl::*autoload-package-name-alist* 64 64 :test 'equalp :key 'car)) 65 #+(and ecl (not ecl-bytecmp)) (require :cmp) 66 #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*) 67 #+(or unix cygwin) (pushnew :asdf-unix *features*)) 65 #+ecl (require :cmp)) 68 66 69 67 (in-package :asdf) … … 79 77 ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version 80 78 ;; can help you do these changes in synch (look at the source for documentation). 81 ;; Relying on its automation, the version is now redundantly present on top of this file.82 79 ;; "2.345" would be an official release 83 80 ;; "2.345.6" would be a development version in the official upstream 84 81 ;; "2.345.0.7" would be your seventh local modification of official release 2.345 85 82 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 86 (asdf-version "2.01 3")83 (asdf-version "2.012") 87 84 (existing-asdf (fboundp 'find-system)) 88 85 (existing-version *asdf-version*) … … 91 88 (when existing-asdf 92 89 (format *trace-output* 93 "~& ; Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"90 "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%" 94 91 existing-version asdf-version)) 95 92 (labels 96 ((present-symbol-p (symbol package) 97 (member (nth-value 1 (find-symbol symbol package)) '(:internal :external))) 98 (present-symbols (package) 99 ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera 100 (let (l) 101 (do-symbols (s package) 102 (when (present-symbol-p s package) (push s l))) 103 (reverse l))) 104 (unlink-package (package) 93 ((unlink-package (package) 105 94 (let ((u (find-package package))) 106 95 (when u 107 (ensure-unintern u (present-symbols u)) 96 (ensure-unintern u 97 (loop :for s :being :each :present-symbol :in u :collect s)) 108 98 (loop :for p :in (package-used-by-list u) :do 109 99 (unuse-package u p)) … … 159 149 (bothly-exported-symbols nil) 160 150 (newly-exported-symbols nil)) 161 ( do-external-symbols (sym package)151 (loop :for sym :being :each :external-symbol :in package :do 162 152 (if (member sym export :test 'string-equal) 163 153 (push sym bothly-exported-symbols) … … 197 187 #:perform-with-restarts #:component-relative-pathname 198 188 #:system-source-file #:operate #:find-component #:find-system 199 #:apply-output-translations #:translate-pathname* #:resolve-location 200 #:compile-file*) 189 #:apply-output-translations #:translate-pathname* #:resolve-location) 201 190 :unintern 202 191 (#:*asdf-revision* #:around #:asdf-method-combination … … 290 279 291 280 #:clear-configuration 292 #:*output-translations-parameter*293 281 #:initialize-output-translations 294 282 #:disable-output-translations … … 300 288 #:enable-asdf-binary-locations-compatibility 301 289 #:*default-source-registries* 302 #:*source-registry-parameter*303 290 #:initialize-source-registry 304 291 #:compute-source-registry … … 322 309 ;; #:find-symbol* 323 310 #:merge-pathnames* 324 #:coerce-pathname325 311 #:pathname-directory-pathname 326 312 #:read-file-forms … … 334 320 #:truenamize 335 321 #:while-collecting))) 336 #+genera (import 'scl:boolean :asdf)337 322 (setf *asdf-version* asdf-version 338 323 *upgraded-p* (if existing-version … … 346 331 "Exported interface to the version of ASDF currently installed. A string. 347 332 You can compare this string with e.g.: 348 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.0 13\")."333 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")." 349 334 *asdf-version*) 350 335 … … 421 406 (make-pathname :name nil :type nil :version nil :defaults pathname))) 422 407 423 (defun* normalize-pathname-directory-component (directory)424 (cond425 #-(or sbcl cmu)426 ((stringp directory) `(:absolute ,directory) directory)427 #+gcl428 ((and (consp directory) (stringp (first directory)))429 `(:absolute ,@directory))430 ((or (null directory)431 (and (consp directory) (member (first directory) '(:absolute :relative))))432 directory)433 (t434 (error "Unrecognized pathname directory component ~S" directory))))435 436 (defun* merge-pathname-directory-components (specified defaults)437 (let ((directory (normalize-pathname-directory-component specified)))438 (ecase (first directory)439 ((nil) defaults)440 (:absolute specified)441 (:relative442 (let ((defdir (normalize-pathname-directory-component defaults))443 (reldir (cdr directory)))444 (cond445 ((null defdir)446 directory)447 ((not (eq :back (first reldir)))448 (append defdir reldir))449 (t450 (loop :with defabs = (first defdir)451 :with defrev = (reverse (rest defdir))452 :while (and (eq :back (car reldir))453 (or (and (eq :absolute defabs) (null defrev))454 (stringp (car defrev))))455 :do (pop reldir) (pop defrev)456 :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))457 458 408 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) 459 409 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname … … 464 414 (let* ((specified (pathname specified)) 465 415 (defaults (pathname defaults)) 466 (directory (normalize-pathname-directory-component (pathname-directory specified))) 416 (directory (pathname-directory specified)) 417 (directory 418 (cond 419 #-(or sbcl cmu scl) 420 ((stringp directory) `(:absolute ,directory) directory) 421 #+gcl 422 ((and (consp directory) (not (member (first directory) '(:absolute :relative)))) 423 `(:relative ,@directory)) 424 ((or (null directory) 425 (and (consp directory) (member (first directory) '(:absolute :relative)))) 426 directory) 427 (t 428 (error "Unrecognized directory component ~S in pathname ~S" directory specified)))) 467 429 (name (or (pathname-name specified) (pathname-name defaults))) 468 430 (type (or (pathname-type specified) (pathname-type defaults))) … … 474 436 (multiple-value-bind (host device directory unspecific-handler) 475 437 (ecase (first directory) 438 ((nil) 439 (values (pathname-host defaults) 440 (pathname-device defaults) 441 (pathname-directory defaults) 442 (unspecific-handler defaults))) 476 443 ((:absolute) 477 444 (values (pathname-host specified) … … 479 446 directory 480 447 (unspecific-handler specified))) 481 (( nil:relative)448 ((:relative) 482 449 (values (pathname-host defaults) 483 450 (pathname-device defaults) 484 (merge-pathname-directory-components directory (pathname-directory defaults)) 451 (if (pathname-directory defaults) 452 (append (pathname-directory defaults) (cdr directory)) 453 directory) 485 454 (unspecific-handler defaults)))) 486 455 (make-pathname :host host :device device :directory directory … … 489 458 :version (funcall unspecific-handler version)))))) 490 459 491 (defun* pathname-parent-directory-pathname (pathname)492 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,493 and NIL NAME, TYPE and VERSION components"494 (when pathname495 (make-pathname :name nil :type nil :version nil496 :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))497 :defaults pathname)))498 499 500 460 (define-modify-macro appendf (&rest args) 501 461 append "Append onto list") ;; only to be used on short lists. … … 510 470 (and (stringp s) (plusp (length s)) (char s (1- (length s))))) 511 471 512 (defun* errfmt (out format-string &rest format-args)513 (declare (dynamic-extent format-args))514 (apply #'format out515 #-genera (format nil "~~@<~A~~:>" format-string) #+genera format-string516 format-args))517 518 472 (defun* asdf-message (format-string &rest format-args) 519 473 (declare (dynamic-extent format-args)) 520 (apply #' errfmt *verbose-out* format-string format-args))474 (apply #'format *verbose-out* format-string format-args)) 521 475 522 476 (defun* split-string (string &key max (separator '(#\Space #\Tab))) … … 545 499 ;; See CLHS make-pathname and 19.2.2.2.3. 546 500 ;; We only use it on implementations that support it. 547 (or #+(or c lozuregcl lispworks sbcl) :unspecific)))501 (or #+(or ccl gcl lispworks sbcl) :unspecific))) 548 502 (destructuring-bind (name &optional (type unspecific)) 549 503 (split-string filename :max 2 :separator ".") … … 582 536 (values :relative nil)) 583 537 (values :relative components)) 584 (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components)) 585 (setf components (substitute :back ".." components :test #'equal)) 538 (setf components (remove "" components :test #'equal)) 586 539 (cond 587 540 ((equal last-comp "") … … 603 556 :append (list k v))) 604 557 605 #+mcl606 (eval-when (:compile-toplevel :load-toplevel :execute)607 (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))608 609 558 (defun* getenv (x) 610 (declare (ignorable x)) 611 #+(or abcl clisp) (ext:getenv x) 612 #+allegro (sys:getenv x) 613 #+clozure (ccl:getenv x) 614 #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) 615 #+ecl (si:getenv x) 616 #+gcl (system:getenv x) 617 #+genera nil 618 #+lispworks (lispworks:environment-variable x) 619 #+mcl (ccl:with-cstrs ((name x)) 620 (let ((value (_getenv name))) 621 (unless (ccl:%null-ptr-p value) 622 (ccl:%get-cstring value)))) 623 #+sbcl (sb-ext:posix-getenv x) 624 #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl) 625 (error "getenv not available on your implementation")) 559 (#+(or abcl clisp) ext:getenv 560 #+allegro sys:getenv 561 #+clozure ccl:getenv 562 #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=))) 563 #+ecl si:getenv 564 #+gcl system:getenv 565 #+lispworks lispworks:environment-variable 566 #+sbcl sb-ext:posix-getenv 567 x)) 626 568 627 569 (defun* directory-pathname-p (pathname) … … 661 603 :defaults pathspec)))) 662 604 663 #+genera664 (unless (fboundp 'ensure-directories-exist)665 (defun ensure-directories-exist (path)666 (fs:create-directories-recursively (pathname path))))667 668 605 (defun* absolute-pathname-p (pathspec) 669 606 (and (typep pathspec '(or pathname string)) … … 693 630 :collect form))) 694 631 695 # +asdf-unix632 #-(and (or win32 windows mswindows mingw32) (not cygwin)) 696 633 (progn 697 634 #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601) … … 733 670 (pathname (unless (wild-pathname-p p) 734 671 #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p) 735 736 672 #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p))) 673 '(ignore-errors (truename p))))))) 737 674 738 675 (defun* truenamize (p) 739 676 "Resolve as much of a pathname as possible" 740 677 (block nil 741 (when (typep p ' (or null logical-pathname)) (return p))678 (when (typep p 'logical-pathname) (return p)) 742 679 (let* ((p (merge-pathnames* p)) 743 680 (directory (pathname-directory p))) … … 771 708 (defun* resolve-symlinks (path) 772 709 #-allegro (truenamize path) 773 #+allegro (if (typep path 'logical-pathname) 774 path 775 (excl:pathname-resolve-symbolic-links path))) 710 #+allegro (excl:pathname-resolve-symbolic-links path)) 776 711 777 712 (defun* default-directory () … … 793 728 (merge-pathnames* *wild-path* path)) 794 729 795 (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))796 (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))797 (last-char (namestring foo))))798 799 730 (defun* directorize-pathname-host-device (pathname) 800 731 (let* ((root (pathname-root pathname)) 801 732 (wild-root (wilden root)) 802 733 (absolute-pathname (merge-pathnames* pathname root)) 803 (separator (directory-separator-for-host root)) 734 (foo (make-pathname :directory '(:absolute "FOO") :defaults root)) 735 (separator (last-char (namestring foo))) 804 736 (root-namestring (namestring root)) 805 737 (root-string 806 738 (substitute-if #\/ 807 #'(lambda (x) (or (eql x #\:)808 739 (lambda (x) (or (eql x #\:) 740 (eql x separator))) 809 741 root-namestring))) 810 742 (multiple-value-bind (relative path filename) … … 925 857 ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 926 858 (when *upgraded-p* 859 #+ecl 860 (when (find-class 'compile-op nil) 861 (defmethod update-instance-for-redefined-class :after 862 ((c compile-op) added deleted plist &key) 863 (declare (ignore added deleted)) 864 (let ((system-p (getf plist 'system-p))) 865 (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) 927 866 (when (find-class 'module nil) 928 867 (eval … … 931 870 (declare (ignorable deleted plist)) 932 871 (when (or *asdf-verbose* *load-verbose*) 933 (asdf-message "~& ; Updating ~A for ASDF ~A~%" m ,(asdf-version)))872 (asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version))) 934 873 (when (member 'components-by-name added) 935 874 (compute-module-components-by-name m)) … … 959 898 error-component error-operation 960 899 module-components module-components-by-name 961 circular-dependency-components 962 condition-arguments condition-form 963 condition-format condition-location 964 coerce-name) 900 circular-dependency-components) 965 901 (ftype (function (t t) t) (setf module-components-by-name))) 966 902 … … 970 906 (format-arguments :initarg :format-arguments :reader format-arguments)) 971 907 (:report (lambda (c s) 972 (apply #'errfmt s (format-control c) (format-arguments c)))))908 (apply #'format s (format-control c) (format-arguments c))))) 973 909 974 910 (define-condition load-system-definition-error (system-definition-error) … … 977 913 (condition :initarg :condition :reader error-condition)) 978 914 (:report (lambda (c s) 979 (errfmt s "Error while trying to load definition for system ~A from pathname ~A: ~A"980 915 (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>" 916 (error-name c) (error-pathname c) (error-condition c))))) 981 917 982 918 (define-condition circular-dependency (system-definition-error) 983 919 ((components :initarg :components :reader circular-dependency-components)) 984 920 (:report (lambda (c s) 985 (errfmt s "Circular dependency: ~S" (circular-dependency-components c)))))921 (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c))))) 986 922 987 923 (define-condition duplicate-names (system-definition-error) 988 924 ((name :initarg :name :reader duplicate-names-name)) 989 925 (:report (lambda (c s) 990 (errfmt s "Error while defining system: multiple components are given same name ~A"991 926 (format s "~@<Error while defining system: multiple components are given same name ~A~@:>" 927 (duplicate-names-name c))))) 992 928 993 929 (define-condition missing-component (system-definition-error) … … 1009 945 (operation :reader error-operation :initarg :operation)) 1010 946 (:report (lambda (c s) 1011 (errfmt s "erred while invoking ~A on ~A"1012 947 (format s "~@<erred while invoking ~A on ~A~@:>" 948 (error-operation c) (error-component c))))) 1013 949 (define-condition compile-error (operation-error) ()) 1014 950 (define-condition compile-failed (compile-error) ()) … … 1021 957 (arguments :reader condition-arguments :initarg :arguments :initform nil)) 1022 958 (:report (lambda (c s) 1023 (errfmt s "~? (will be skipped)"1024 1025 1026 959 (format s "~@<~? (will be skipped)~@:>" 960 (condition-format c) 961 (list* (condition-form c) (condition-location c) 962 (condition-arguments c)))))) 1027 963 (define-condition invalid-source-registry (invalid-configuration warning) 1028 ((format :initform " invalid source registry ~S~@[ in ~S~]~@{ ~@?~}")))964 ((format :initform "~@<invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~>"))) 1029 965 (define-condition invalid-output-translation (invalid-configuration warning) 1030 ((format :initform " invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}")))966 ((format :initform "~@<invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~>"))) 1031 967 1032 968 (defclass component () … … 1034 970 "Component name: designator for a string composed of portable pathname characters") 1035 971 (version :accessor component-version :initarg :version) 1036 (description :accessor component-description :initarg :description) 1037 (long-description :accessor component-long-description :initarg :long-description) 1038 ;; This one below is used by POIU - http://www.cliki.net/poiu 1039 ;; a parallelizing extension of ASDF that compiles in multiple parallel 1040 ;; slave processes (forked on demand) and loads in the master process. 1041 ;; Maybe in the future ASDF may use it internally instead of in-order-to. 972 ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to? 973 ;; POIU is a parallel (multi-process build) extension of ASDF. See 974 ;; http://www.cliki.net/poiu 1042 975 (load-dependencies :accessor component-load-dependencies :initform nil) 1043 976 ;; In the ASDF object model, dependencies exist between *actions* … … 1058 991 ;; hasn't yet been loaded in the current image (do-first). 1059 992 ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52! 1060 ;; See our ASDF 2 paper for more complete explanations.1061 993 (in-order-to :initform nil :initarg :in-order-to 1062 994 :accessor component-in-order-to) … … 1086 1018 (defmethod print-object ((c component) stream) 1087 1019 (print-unreadable-object (c stream :type t :identity nil) 1088 (format stream "~ {~S~^ ~}" (component-find-path c))))1020 (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c)))) 1089 1021 1090 1022 … … 1092 1024 1093 1025 (defmethod print-object ((c missing-dependency) s) 1094 (format s "~ A, required by ~A"1026 (format s "~@<~A, required by ~A~@:>" 1095 1027 (call-next-method c nil) (missing-required-by c))) 1096 1028 … … 1102 1034 1103 1035 (defmethod print-object ((c missing-component) s) 1104 (format s " component ~S not found~@[ in ~A~]"1036 (format s "~@<component ~S not found~@[ in ~A~]~@:>" 1105 1037 (missing-requires c) 1106 1038 (when (missing-parent c) … … 1108 1040 1109 1041 (defmethod print-object ((c missing-component-of-version) s) 1110 (format s " component ~S does not match version ~A~@[ in ~A~]"1042 (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>" 1111 1043 (missing-requires c) 1112 1044 (missing-version c) … … 1185 1117 1186 1118 (defclass system (module) 1187 (;; description and long-description are now available for all component's, 1188 ;; but now also inherited from component, but we add the legacy accessor 1189 (description :accessor system-description :initarg :description) 1190 (long-description :accessor system-long-description :initarg :long-description) 1119 ((description :accessor system-description :initarg :description) 1120 (long-description 1121 :accessor system-long-description :initarg :long-description) 1191 1122 (author :accessor system-author :initarg :author) 1192 1123 (maintainer :accessor system-maintainer :initarg :maintainer) … … 1237 1168 (symbol (string-downcase (symbol-name name))) 1238 1169 (string name) 1239 (t (sysdef-error " invalid component designator ~A" name))))1170 (t (sysdef-error "~@<invalid component designator ~A~@:>" name)))) 1240 1171 1241 1172 (defun* system-registered-p (name) … … 1255 1186 FN should be a function of one argument. It will be 1256 1187 called with an object of type asdf:system." 1257 (maphash #'(lambda (_ datum) 1188 (maphash (lambda (_ datum) 1189 (declare (ignore _)) 1190 (destructuring-bind (_ . def) datum 1258 1191 (declare (ignore _)) 1259 (destructuring-bind (_ . def) datum 1260 (declare (ignore _)) 1261 (funcall fn def))) 1192 (funcall fn def))) 1262 1193 *defined-systems*)) 1263 1194 … … 1271 1202 (let ((system-name (coerce-name system))) 1272 1203 (or 1273 (some #'(lambda (x) (funcall x system-name))1204 (some (lambda (x) (funcall x system-name)) 1274 1205 *system-definition-search-functions*) 1275 1206 (let ((system-pair (system-registered-p system-name))) … … 1300 1231 :name name 1301 1232 :type "asd"))) 1302 (when (probe-file *file)1233 (when (probe-file file) 1303 1234 (return file))) 1304 #+(and asdf-windows(not clisp))1235 #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) 1305 1236 (let ((shortcut 1306 1237 (make-pathname … … 1308 1239 :name (concatenate 'string name ".asd") 1309 1240 :type "lnk"))) 1310 (when (probe-file *shortcut)1241 (when (probe-file shortcut) 1311 1242 (let ((target (parse-windows-shortcut shortcut))) 1312 1243 (when target … … 1330 1261 (let* ((*print-circle* nil) 1331 1262 (message 1332 ( errfmt nil1333 " While searching for system ~S: ~S evaluated to ~S which is not a directory."1263 (format nil 1264 "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>" 1334 1265 system dir defaults))) 1335 1266 (error message)) … … 1339 1270 (coerce-entry-to-directory () 1340 1271 :report (lambda (s) 1341 (errfmt s "Coerce entry to ~a, replace ~a and continue."1342 1272 (format s "Coerce entry to ~a, replace ~a and continue." 1273 (ensure-directory-pathname defaults) dir)) 1343 1274 (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) 1344 1275 ;; cleanup … … 1372 1303 ;; as if the file were very old. 1373 1304 ;; (or should we treat the case in a different, special way?) 1374 (or (and pathname (probe-file *pathname) (file-write-date pathname))1305 (or (and pathname (probe-file pathname) (file-write-date pathname)) 1375 1306 (progn 1376 1307 (when (and pathname *asdf-verbose*) … … 1387 1318 (unwind-protect 1388 1319 (handler-bind 1389 ((error #'(lambda (condition)1390 1391 1392 1320 ((error (lambda (condition) 1321 (error 'load-system-definition-error 1322 :name name :pathname pathname 1323 :condition condition)))) 1393 1324 (let ((*package* package)) 1394 1325 (asdf-message 1395 "~& ; Loading system definition from ~A into ~A~%"1326 "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%" 1396 1327 pathname package) 1397 1328 (load pathname))) … … 1419 1350 1420 1351 (defun* register-system (name system) 1421 (asdf-message "~& ; Registering ~A as ~A~%" system name)1352 (asdf-message "~&~@<; ~@;Registering ~A as ~A~@:>~%" system name) 1422 1353 (setf (gethash (coerce-name name) *defined-systems*) 1423 1354 (cons (get-universal-time) system))) … … 1498 1429 1499 1430 (defun* merge-component-name-type (name &key type defaults) 1500 ;; For backwards compatibility only, for people using internals.1501 ;; Will be removed in a future release, e.g. 2.014.1502 (coerce-pathname name :type type :defaults defaults))1503 1504 (defun* coerce-pathname (name &key type defaults)1505 "coerce NAME into a PATHNAME.1506 When given a string, portably decompose it into a relative pathname:1507 #\\/ separates subdirectories. The last #\\/-separated string is as follows:1508 if TYPE is NIL, its last #\\. if any separates name and type from from type;1509 if TYPE is a string, it is the type, and the whole string is the name;1510 if TYPE is :DIRECTORY, the string is a directory component;1511 if the string is empty, it's a directory.1512 Any directory named .. is read as :BACK.1513 Host, device and version components are taken from DEFAULTS."1514 1431 ;; The defaults are required notably because they provide the default host 1515 1432 ;; to the below make-pathname, which may crucially matter to people using … … 1520 1437 ;; ASDF:MERGE-PATHNAMES* 1521 1438 (etypecase name 1522 ( (or null pathname)1439 (pathname 1523 1440 name) 1524 1441 (symbol 1525 ( coerce-pathname (string-downcase name) :type type :defaults defaults))1442 (merge-component-name-type (string-downcase name) :type type :defaults defaults)) 1526 1443 (string 1527 1444 (multiple-value-bind (relative path filename) … … 1544 1461 1545 1462 (defmethod component-relative-pathname ((component component)) 1546 ( coerce-pathname1463 (merge-component-name-type 1547 1464 (or (slot-value component 'relative-pathname) 1548 1465 (component-name component)) … … 1652 1569 (defmethod component-self-dependencies ((o operation) (c component)) 1653 1570 (let ((all-deps (component-depends-on o c))) 1654 (remove-if-not #'(lambda (x)1655 1571 (remove-if-not (lambda (x) 1572 (member (component-name c) (cdr x) :test #'string=)) 1656 1573 all-deps))) 1657 1574 … … 1660 1577 (self-deps (component-self-dependencies operation c))) 1661 1578 (if self-deps 1662 (mapcan #'(lambda (dep)1663 1664 1665 1579 (mapcan (lambda (dep) 1580 (destructuring-bind (op name) dep 1581 (output-files (make-instance op) 1582 (find-component parent name)))) 1666 1583 self-deps) 1667 1584 ;; no previous operations needed? I guess we work with the … … 1717 1634 ;; second). So that's cool. 1718 1635 (and 1719 (every #'probe-file *in-files)1720 (every #'probe-file *out-files)1636 (every #'probe-file in-files) 1637 (every #'probe-file out-files) 1721 1638 (>= (earliest-out) (latest-in)))))))) 1722 1639 … … 1765 1682 (retry () 1766 1683 :report (lambda (s) 1767 (errfmt s "Retry loading component ~S." required-c))1684 (format s "~@<Retry loading component ~S.~@:>" required-c)) 1768 1685 :test 1769 1686 (lambda (c) 1770 1771 1772 1773 1687 (or (null c) 1688 (and (typep c 'missing-dependency) 1689 (equalp (missing-requires c) 1690 required-c)))))))) 1774 1691 1775 1692 (defun* do-dep (operation c collect op dep) … … 1934 1851 (defmethod perform ((operation operation) (c source-file)) 1935 1852 (sysdef-error 1936 " required method PERFORM not implemented for operation ~A, component ~A"1853 "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>" 1937 1854 (class-of operation) (class-of c))) 1938 1855 … … 1957 1874 :initform *compile-file-failure-behaviour*) 1958 1875 (flags :initarg :flags :accessor compile-op-flags 1959 :initform nil)))1876 :initform #-ecl nil #+ecl '(:system-p t)))) 1960 1877 1961 1878 (defun output-file (operation component) … … 1966 1883 1967 1884 (defmethod perform :before ((operation compile-op) (c source-file)) 1968 (loop :for file :in (asdf:output-files operation c) 1969 :for pathname = (if (typep file 'logical-pathname) 1970 (translate-logical-pathname file) 1971 file) 1972 :do (ensure-directories-exist pathname))) 1885 (map nil #'ensure-directories-exist (output-files operation c))) 1886 1887 #+ecl 1888 (defmethod perform :after ((o compile-op) (c cl-source-file)) 1889 ;; Note how we use OUTPUT-FILES to find the binary locations 1890 ;; This allows the user to override the names. 1891 (let* ((files (output-files o c)) 1892 (object (first files)) 1893 (fasl (second files))) 1894 (c:build-fasl fasl :lisp-files (list object)))) 1973 1895 1974 1896 (defmethod perform :after ((operation operation) (c component)) … … 1976 1898 (get-universal-time))) 1977 1899 1978 (defvar *compile-op-compile-file-function* 'compile-file* 1979 "Function used to compile lisp files.") 1900 (declaim (ftype (function ((or pathname string) 1901 &rest t &key (:output-file t) &allow-other-keys) 1902 (values t t t)) 1903 compile-file*)) 1980 1904 1981 1905 ;;; perform is required to check output-files to find out where to put … … 1990 1914 (*compile-file-failure-behaviour* (operation-on-failure operation))) 1991 1915 (multiple-value-bind (output warnings-p failure-p) 1992 (apply *compile-op-compile-file-function* source-file :output-file output-file1916 (apply #'compile-file* source-file :output-file output-file 1993 1917 (compile-op-flags operation)) 1994 1918 (when warnings-p 1995 1919 (case (operation-on-warnings operation) 1996 1920 (:warn (warn 1997 " COMPILE-FILE warned while performing ~A on ~A."1921 "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>" 1998 1922 operation c)) 1999 1923 (:error (error 'compile-warned :component c :operation operation)) … … 2002 1926 (case (operation-on-failure operation) 2003 1927 (:warn (warn 2004 " COMPILE-FILE failed while performing ~A on ~A."1928 "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>" 2005 1929 operation c)) 2006 1930 (:error (error 'compile-failed :component c :operation operation)) … … 2012 1936 (declare (ignorable operation)) 2013 1937 (let ((p (lispize-pathname (component-pathname c)))) 2014 #-broken-fasl-loader (list (compile-file-pathname p)) 2015 #+broken-fasl-loader (list p))) 1938 #-:broken-fasl-loader 1939 (list (compile-file-pathname p #+ecl :type #+ecl :object) 1940 #+ecl (compile-file-pathname p :type :fasl)) 1941 #+:broken-fasl-loader (list p))) 2016 1942 2017 1943 (defmethod perform ((operation compile-op) (c static-file)) … … 2039 1965 2040 1966 (defmethod perform ((o load-op) (c cl-source-file)) 2041 (map () #'load (input-files o c))) 1967 (map () #'load 1968 #-ecl (input-files o c) 1969 #+ecl (loop :for i :in (input-files o c) 1970 :unless (string= (pathname-type i) "fas") 1971 :collect (compile-file-pathname (lispize-pathname i))))) 2042 1972 2043 1973 (defmethod perform-with-restarts (operation component) … … 2132 2062 (let ((what-would-load-op-do (cdr (assoc 'load-op 2133 2063 (component-in-order-to c))))) 2134 (mapcar #'(lambda (dep)2135 2136 2137 2064 (mapcar (lambda (dep) 2065 (if (eq (car dep) 'load-op) 2066 (cons 'load-source-op (cdr dep)) 2067 dep)) 2138 2068 what-would-load-op-do))) 2139 2069 … … 2198 2128 :report 2199 2129 (lambda (s) 2200 (errfmt s "Retry ~A." (operation-description op component))))2130 (format s "~@<Retry ~A.~@:>" (operation-description op component)))) 2201 2131 (accept () 2202 2132 :report 2203 2133 (lambda (s) 2204 (errfmt s "Continue, treating ~A as having been successful."2205 2134 (format s "~@<Continue, treating ~A as having been successful.~@:>" 2135 (operation-description op component))) 2206 2136 (setf (gethash (type-of op) 2207 2137 (component-operation-times component)) … … 2281 2211 (let* ((file-pathname (load-pathname)) 2282 2212 (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) 2283 (or (and pathname-supplied-p 2284 (merge-pathnames* (coerce-pathname pathname :type :directory) 2285 directory-pathname)) 2213 (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname)) 2286 2214 directory-pathname 2287 2215 (default-directory)))) … … 2326 2254 (or (module-default-component-class parent) 2327 2255 (find-class *default-component-class*))) 2328 (sysdef-error " don't recognize component type ~A" type)))2256 (sysdef-error "~@<don't recognize component type ~A~@:>" type))) 2329 2257 2330 2258 (defun* maybe-add-tree (tree op1 op2 c) … … 2383 2311 ;; methods will not be for this particular gf 2384 2312 ;; But this is hardly performance-critical 2385 #'(lambda (m)2386 2313 (lambda (m) 2314 (remove-method (symbol-function name) m)) 2387 2315 (component-inline-methods component))) 2388 2316 ;; clear methods, then add the new ones … … 2585 2513 (defun* system-relative-pathname (system name &key type) 2586 2514 (merge-pathnames* 2587 ( coerce-pathname name :type type)2515 (merge-component-name-type name :type type) 2588 2516 (system-source-directory system))) 2589 2517 … … 2596 2524 2597 2525 (defparameter *implementation-features* 2598 '((:a bcl :armedbear)2599 (: acl :allegro)2600 (: mcl :digitool) ; before clozure, so it won't get preempted by ccl2526 '((:acl :allegro) 2527 (:lw :lispworks) 2528 (:digitool) ; before clozure, so it won't get preempted by ccl 2601 2529 (:ccl :clozure) 2602 2530 (:corman :cormanlisp) 2603 (: lw :lispworks)2604 : clisp :cmu :ecl :gcl :sbcl :scl :symbolics))2531 (:abcl :armedbear) 2532 :sbcl :cmu :clisp :gcl :ecl :scl)) 2605 2533 2606 2534 (defparameter *os-features* … … 2610 2538 (:macosx :darwin :darwin-target :apple) 2611 2539 :freebsd :netbsd :openbsd :bsd 2612 :unix 2613 :genera)) 2540 :unix)) 2614 2541 2615 2542 (defparameter *architecture-features* … … 2623 2550 (:sparc32 :sparc) 2624 2551 (:arm :arm-target) 2625 (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7) 2626 :imach)) 2552 (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7))) 2627 2553 2628 2554 (defun* lisp-version-string () … … 2642 2568 (if (member :64bit *features*) "-64bit" "")) 2643 2569 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) 2644 #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)2570 #+clisp (subseq s 0 (position #\space s)) 2645 2571 #+clozure (format nil "~d.~d-f~d" ; shorten for windows 2646 2572 ccl::*openmcl-major-version* … … 2648 2574 (logand ccl::fasl-version #xFF)) 2649 2575 #+cmu (substitute #\- #\/ s) 2576 #+digitool (subseq s 8) 2650 2577 #+ecl (format nil "~A~@[-~A~]" s 2651 2578 (let ((vcs-id (ext:lisp-implementation-vcs-id))) … … 2653 2580 (subseq vcs-id 0 8)))) 2654 2581 #+gcl (subseq s (1+ (position #\space s))) 2655 #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")2656 (format nil "~D.~D" major minor))2657 2582 #+lispworks (format nil "~A~@[~A~]" s 2658 2583 (when (member :lispworks-64bit *features*) "-64bit")) 2659 2584 ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version 2660 #+mcl (subseq s 8) ; strip the leading "Version " 2661 #+(or cormanlisp sbcl scl) s 2662 #-(or allegro armedbear clisp clozure cmu cormanlisp 2663 ecl gcl genera lispworks mcl sbcl scl) s)) 2585 #+(or cormanlisp mcl sbcl scl) s 2586 #-(or allegro armedbear clisp clozure cmu cormanlisp digitool 2587 ecl gcl lispworks mcl sbcl scl) s)) 2664 2588 2665 2589 (defun* first-feature (features) … … 2693 2617 (os (maybe-warn (first-feature *os-features*) 2694 2618 "No os feature found in ~a." *os-features*)) 2695 (arch (or#-clisp2696 2697 2698 *architecture-features*)))2619 (arch #+clisp "" #-clisp 2620 (maybe-warn (first-feature *architecture-features*) 2621 "No architecture feature found in ~a." 2622 *architecture-features*)) 2699 2623 (version (maybe-warn (lisp-version-string) 2700 2624 "Don't know how to get Lisp implementation version."))) 2701 2625 (substitute-if 2702 #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))2703 (format nil "~(~ a~@{~@[-~a~]~}~)" lisp version os arch)))))2626 #\_ (lambda (x) (find x " /:\\(){}[]$#`'\"")) 2627 (format nil "~(~@{~a~^-~}~)" lisp version os arch))))) 2704 2628 2705 2629 … … 2708 2632 2709 2633 (defparameter *inter-directory-separator* 2710 #+ asdf-unix#\:2711 #- asdf-unix#\;)2634 #+(or unix cygwin) #\: 2635 #-(or unix cygwin) #\;) 2712 2636 2713 2637 (defun* user-homedir () 2714 (truenam ize (pathname-directory-pathname (user-homedir-pathname))))2638 (truename (user-homedir-pathname))) 2715 2639 2716 2640 (defun* try-directory-subpath (x sub &key type) 2717 2641 (let* ((p (and x (ensure-directory-pathname x))) 2718 2642 (tp (and p (probe-file* p))) 2719 (sp (and tp (merge-pathnames* ( coerce-pathname sub :type type) p)))2643 (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p))) 2720 2644 (ts (and sp (probe-file* sp)))) 2721 2645 (and ts (values sp ts)))) … … 2728 2652 :for dir :in (split-string dirs :separator ":") 2729 2653 :collect (try dir "common-lisp/")) 2730 #+ asdf-windows2654 #+(and (or win32 windows mswindows mingw32) (not cygwin)) 2731 2655 ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/") 2732 2656 ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData … … 2737 2661 #'null 2738 2662 (append 2739 #+ asdf-windows2663 #+(and (or win32 windows mswindows mingw32) (not cygwin)) 2740 2664 (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) 2741 2665 `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") 2742 2666 ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData 2743 2667 ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) 2744 #+asdf-unix2745 2668 (list #p"/etc/common-lisp/")))) 2746 2669 (defun* in-first-directory (dirs x) … … 2811 2734 (apply 'directory pathname-spec 2812 2735 (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) 2813 #+c lozure'(:follow-links nil)2736 #+ccl '(:follow-links nil) 2814 2737 #+clisp '(:circle t :if-does-not-exist :ignore) 2815 2738 #+(or cmu scl) '(:follow-links nil :truenamep nil) … … 2859 2782 (or 2860 2783 (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) 2861 #+ asdf-windows2784 #+(and (or win32 windows mswindows mingw32) (not cygwin)) 2862 2785 (try (getenv "APPDATA") "common-lisp" "cache" :implementation) 2863 2786 '(:home ".cache" "common-lisp" :implementation)))) … … 2874 2797 (list 2875 2798 (stable-sort (copy-list new-value) #'> 2876 :key #'(lambda (x)2877 2878 2879 2880 2881 2799 :key (lambda (x) 2800 (etypecase (car x) 2801 ((eql t) -1) 2802 (pathname 2803 (let ((directory (pathname-directory (car x)))) 2804 (if (listp directory) (length directory) 0)))))))) 2882 2805 new-value) 2883 2806 … … 2918 2841 ((eql :implementation) (implementation-identifier)) 2919 2842 ((eql :implementation-type) (string-downcase (implementation-type))) 2920 # +asdf-unix2843 #-(and (or win32 windows mswindows mingw32) (not cygwin)) 2921 2844 ((eql :uid) (princ-to-string (get-uid))))) 2922 2845 (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r))) … … 2989 2912 (member :default-directory :*/ :**/ :*.*.* 2990 2913 :implementation :implementation-type 2991 # +asdf-unix:uid)))))2914 #-(and (or win32 windows mswindows mingw32) (not cygwin)) :uid))))) 2992 2915 (or (typep x 'boolean) 2993 2916 (absolute-component-p x) … … 3081 3004 ;; Some implementations have precompiled ASDF systems, 3082 3005 ;; so we must disable translations for implementation paths. 3083 #+sbcl ,(let ((h (getenv "SBCL_HOME"))) 3084 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ()))) 3006 #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ()))) 3085 3007 #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system 3086 3008 #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system … … 3093 3015 :enable-user-cache)) 3094 3016 3095 (defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))3096 (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))3017 (defparameter *output-translations-file* #p"asdf-output-translations.conf") 3018 (defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/") 3097 3019 3098 3020 (defun* user-output-translations-pathname () … … 3122 3044 (process-output-translations (validate-output-translations-directory pathname) 3123 3045 :inherit inherit :collect collect)) 3124 ((probe-file *pathname)3046 ((probe-file pathname) 3125 3047 (process-output-translations (validate-output-translations-file pathname) 3126 3048 :inherit inherit :collect collect)) … … 3185 3107 :test 'equal :from-end t)) 3186 3108 3187 (defvar *output-translations-parameter* nil) 3188 3189 (defun* initialize-output-translations (&optional (parameter *output-translations-parameter*)) 3109 (defun* initialize-output-translations (&optional parameter) 3190 3110 "read the configuration, initialize the internal configuration variable, 3191 3111 return the configuration" 3192 (setf *output-translations-parameter* parameter 3193 (output-translations) (compute-output-translations parameter))) 3112 (setf (output-translations) (compute-output-translations parameter))) 3194 3113 3195 3114 (defun* disable-output-translations () … … 3267 3186 3268 3187 (defun* delete-file-if-exists (x) 3269 (when (and x (probe-file *x))3188 (when (and x (probe-file x)) 3270 3189 (delete-file x))) 3271 3190 … … 3360 3279 ;;;; http://www.wotsit.org/list.asp?fc=13 3361 3280 3362 #+(and asdf-windows(not clisp))3281 #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) 3363 3282 (progn 3364 3283 (defparameter *link-initial-dword* 76) … … 3470 3389 (defun directory-has-asd-files-p (directory) 3471 3390 (ignore-errors 3472 (and (directory* (merge-pathnames* *wild-asd* directory)) t))) 3391 (directory* (merge-pathnames* *wild-asd* directory)) 3392 t)) 3473 3393 3474 3394 (defun subdirectories (directory) 3475 3395 (let* ((directory (ensure-directory-pathname directory)) 3476 #- (or cormanlisp genera)3396 #-cormanlisp 3477 3397 (wild (merge-pathnames* 3478 3398 #-(or abcl allegro lispworks scl) … … 3481 3401 directory)) 3482 3402 (dirs 3483 #- (or cormanlisp genera)3403 #-cormanlisp 3484 3404 (ignore-errors 3485 (directory* wild . #.(or #+clozure '(:directories t :files nil) 3486 #+mcl '(:directories t)))) 3487 #+cormanlisp (cl::directory-subdirs directory) 3488 #+genera (fs:directory-list directory)) 3489 #+(or abcl allegro genera lispworks scl) 3405 (directory* wild . #.(or #+ccl '(:directories t :files nil) 3406 #+digitool '(:directories t)))) 3407 #+cormanlisp (cl::directory-subdirs directory)) 3408 #+(or abcl allegro lispworks scl) 3490 3409 (dirs (remove-if-not #+abcl #'extensions:probe-directory 3491 3410 #+allegro #'excl:probe-directory 3492 3411 #+lispworks #'lw:file-directory-p 3493 #+genera #'(lambda (x) (getf (cdr x) :directory)) 3494 #-(or abcl allegro genera lispworks) #'directory-pathname-p 3495 dirs)) 3496 #+genera 3497 (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs))) 3412 #-(or abcl allegro lispworks) #'directory-pathname-p 3413 dirs))) 3498 3414 dirs)) 3499 3415 … … 3590 3506 default-source-registry)) 3591 3507 3592 (defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))3593 (defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))3508 (defparameter *source-registry-file* #p"source-registry.conf") 3509 (defparameter *source-registry-directory* #p"source-registry.conf.d/") 3594 3510 3595 3511 (defun* wrapping-source-registry () 3596 3512 `(:source-registry 3597 #+sbcl (:tree ,( truenamize (getenv "SBCL_HOME")))3513 #+sbcl (:tree ,(getenv "SBCL_HOME")) 3598 3514 :inherit-configuration 3599 3515 #+cmu (:tree #p"modules:"))) … … 3602 3518 `(:source-registry 3603 3519 #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir))) 3604 (:directory ,( default-directory))3520 (:directory ,(truenamize (directory-namestring *default-pathname-defaults*))) 3605 3521 ,@(let* 3606 #+ asdf-unix3522 #+(or unix cygwin) 3607 3523 ((datahome 3608 3524 (or (getenv "XDG_DATA_HOME") … … 3611 3527 (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share")) 3612 3528 (dirs (cons datahome (split-string datadirs :separator ":")))) 3613 #+ asdf-windows3529 #+(and (or win32 windows mswindows mingw32) (not cygwin)) 3614 3530 ((datahome (getenv "APPDATA")) 3615 3531 (datadir … … 3618 3534 "Application Data")) 3619 3535 (dirs (list datahome datadir))) 3620 #-(or asdf-unix asdf-windows)3536 #-(or unix win32 windows mswindows mingw32 cygwin) 3621 3537 ((dirs ())) 3622 3538 (loop :for dir :in dirs … … 3649 3565 (process-source-registry (validate-source-registry-directory pathname) 3650 3566 :inherit inherit :register register))) 3651 ((probe-file *pathname)3567 ((probe-file pathname) 3652 3568 (let ((*here-directory* (pathname-directory-pathname pathname))) 3653 3569 (process-source-registry (validate-source-registry-file pathname) … … 3705 3621 ,parameter 3706 3622 ,@*default-source-registries*) 3707 :register #'(lambda (directory &key recurse exclude)3708 3623 :register (lambda (directory &key recurse exclude) 3624 (collect (list directory :recurse recurse :exclude exclude))))) 3709 3625 :test 'equal :from-end t))) 3710 3626 … … 3719 3635 :recurse recurse :exclude exclude :collect #'collect))))) 3720 3636 3721 (defvar *source-registry-parameter* nil) 3722 3723 (defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) 3724 (setf *source-registry-parameter* parameter 3725 (source-registry) (compute-source-registry parameter))) 3637 (defun* initialize-source-registry (&optional parameter) 3638 (setf (source-registry) (compute-source-registry parameter))) 3726 3639 3727 3640 ;; Checks an initial variable to see whether the state is initialized … … 3756 3669 ((style-warning #'muffle-warning) 3757 3670 (missing-component (constantly nil)) 3758 (error #'(lambda (e)3759 (errfmt *error-output* "ASDF could not load ~(~A~) because ~A.~%"3760 3671 (error (lambda (e) 3672 (format *error-output* "ASDF could not load ~(~A~) because ~A.~%" 3673 name e)))) 3761 3674 (let* ((*verbose-out* (make-broadcast-stream)) 3762 3675 (system (find-system (string-downcase name) nil))) … … 3782 3695 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 3783 3696 ;;;; 3697 ;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1 3698 (eval-when (:compile-toplevel :load-toplevel :execute) 3699 #+ecl ;; Support upgrade from before ECL went to 1.369 3700 (when (fboundp 'compile-op-system-p) 3701 (defmethod compile-op-system-p ((op compile-op)) 3702 (getf :system-p (compile-op-flags op))) 3703 (defmethod initialize-instance :after ((op compile-op) 3704 &rest initargs 3705 &key system-p &allow-other-keys) 3706 (declare (ignorable initargs)) 3707 (when system-p (appendf (compile-op-flags op) (list :system-p system-p)))))) 3784 3708 3785 3709 ;;; If a previous version of ASDF failed to read some configuration, try again.
Note:
See TracChangeset
for help on using the changeset viewer.
