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