Changeset 13087 for trunk/abcl/src/org/armedbear
- Timestamp:
- 12/03/10 14:02:11 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
r12986 r13087 69 69 ;;;; Create packages in a way that is compatible with hot-upgrade. 70 70 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 71 ;;;; See more atthe end of the file.71 ;;;; See more near the end of the file. 72 72 73 73 (eval-when (:load-toplevel :compile-toplevel :execute) 74 74 (defvar *asdf-version* nil) 75 75 (defvar *upgraded-p* nil) 76 (let* ((asdf-version "2.010.1") ;; bump this version when you modify this file. Same as 2.147 76 (let* (;; For bug reporting sanity, please always bump this version when you modify this file. 77 ;; "2.345" would be an official release 78 ;; "2.345.6" would be a development version in the official upstream 79 ;; "2.345.0.7" would be your local modification of an official release 80 ;; "2.345.6.7" would be your local modification of a development version 81 (asdf-version "2.011") 77 82 (existing-asdf (fboundp 'find-system)) 78 83 (existing-version *asdf-version*) … … 80 85 (unless (and existing-asdf already-there) 81 86 (when existing-asdf 82 (format * error-output*83 "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"84 87 (format *trace-output* 88 "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%" 89 existing-version asdf-version)) 85 90 (labels 86 91 ((unlink-package (package) … … 183 188 :unintern 184 189 (#:*asdf-revision* #:around #:asdf-method-combination 185 #:split #:make-collector) 190 #:split #:make-collector 191 #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function 186 192 :fmakunbound 187 193 (#:system-source-file … … 237 243 #:map-systems 238 244 245 #:operation-description 239 246 #:operation-on-warnings 240 247 #:operation-on-failure … … 289 296 ;; Utilities 290 297 #:absolute-pathname-p 291 298 ;; #:aif #:it 292 299 ;; #:appendf 293 300 #:coerce-name … … 298 305 ;; #:get-uid 299 306 ;; #:length=n-p 307 ;; #:find-symbol* 300 308 #:merge-pathnames* 301 309 #:pathname-directory-pathname 302 310 #:read-file-forms 303 304 311 ;; #:remove-keys 312 ;; #:remove-keyword 305 313 #:resolve-symlinks 306 314 #:split-string … … 315 323 *upgraded-p*)))))) 316 324 317 ;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687318 (when *upgraded-p*319 #+ecl320 (when (find-class 'compile-op nil)321 (defmethod update-instance-for-redefined-class :after322 ((c compile-op) added deleted plist &key)323 (declare (ignore added deleted))324 (let ((system-p (getf plist 'system-p)))325 (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))326 (when (find-class 'module nil)327 (eval328 '(defmethod update-instance-for-redefined-class :after329 ((m module) added deleted plist &key)330 (declare (ignorable deleted plist))331 (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))332 (when (member 'components-by-name added)333 (compute-module-components-by-name m))334 (when (and (typep m 'system) (member 'source-file added))335 (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m))))))336 337 325 ;;;; ------------------------------------------------------------------------- 338 326 ;;;; User-visible parameters … … 376 364 377 365 ;;;; ------------------------------------------------------------------------- 378 ;;;; ASDF Interface, in terms of generic functions. 366 ;;;; General Purpose Utilities 367 379 368 (macrolet 380 369 ((defdef (def* def) … … 387 376 (defdef defgeneric* defgeneric) 388 377 (defdef defun* defun)) 389 390 (defgeneric* find-system (system &optional error-p))391 (defgeneric* perform-with-restarts (operation component))392 (defgeneric* perform (operation component))393 (defgeneric* operation-done-p (operation component))394 (defgeneric* explain (operation component))395 (defgeneric* output-files (operation component))396 (defgeneric* input-files (operation component))397 (defgeneric* component-operation-time (operation component))398 (defgeneric* operation-description (operation component)399 (:documentation "returns a phrase that describes performing this operation400 on this component, e.g. \"loading /a/b/c\".401 You can put together sentences using this phrase."))402 403 (defgeneric* system-source-file (system)404 (:documentation "Return the source file in which system is defined."))405 406 (defgeneric* component-system (component)407 (:documentation "Find the top-level system containing COMPONENT"))408 409 (defgeneric* component-pathname (component)410 (:documentation "Extracts the pathname applicable for a particular component."))411 412 (defgeneric* component-relative-pathname (component)413 (:documentation "Returns a pathname for the component argument intended to be414 interpreted relative to the pathname of that component's parent.415 Despite the function's name, the return value may be an absolute416 pathname, because an absolute pathname may be interpreted relative to417 another pathname in a degenerate way."))418 419 (defgeneric* component-property (component property))420 421 (defgeneric* (setf component-property) (new-value component property))422 423 (defgeneric* version-satisfies (component version))424 425 (defgeneric* find-component (base path)426 (:documentation "Finds the component with PATH starting from BASE module;427 if BASE is nil, then the component is assumed to be a system."))428 429 (defgeneric* source-file-type (component system))430 431 (defgeneric* operation-ancestor (operation)432 (:documentation433 "Recursively chase the operation's parent pointer until we get to434 the head of the tree"))435 436 (defgeneric* component-visited-p (operation component)437 (:documentation "Returns the value stored by a call to438 VISIT-COMPONENT, if that has been called, otherwise NIL.439 This value stored will be a cons cell, the first element440 of which is a computed key, so not interesting. The441 CDR wil be the DATA value stored by VISIT-COMPONENT; recover442 it as (cdr (component-visited-p op c)).443 In the current form of ASDF, the DATA value retrieved is444 effectively a boolean, indicating whether some operations are445 to be performed in order to do OPERATION X COMPONENT. If the446 data value is NIL, the combination had been explored, but no447 operations needed to be performed."))448 449 (defgeneric* visit-component (operation component data)450 (:documentation "Record DATA as being associated with OPERATION451 and COMPONENT. This is a side-effecting function: the association452 will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the453 OPERATION\).454 No evidence that DATA is ever interesting, beyond just being455 non-NIL. Using the data field is probably very risky; if there is456 already a record for OPERATION X COMPONENT, DATA will be quietly457 discarded instead of recorded.458 Starting with 2.006, TRAVERSE will store an integer in data,459 so that nodes can be sorted in decreasing order of traversal."))460 461 462 (defgeneric* (setf visiting-component) (new-value operation component))463 464 (defgeneric* component-visiting-p (operation component))465 466 (defgeneric* component-depends-on (operation component)467 (:documentation468 "Returns a list of dependencies needed by the component to perform469 the operation. A dependency has one of the following forms:470 471 (<operation> <component>*), where <operation> is a class472 designator and each <component> is a component473 designator, which means that the component depends on474 <operation> having been performed on each <component>; or475 476 (FEATURE <feature>), which means that the component depends477 on <feature>'s presence in *FEATURES*.478 479 Methods specialized on subclasses of existing component types480 should usually append the results of CALL-NEXT-METHOD to the481 list."))482 483 (defgeneric* component-self-dependencies (operation component))484 485 (defgeneric* traverse (operation component)486 (:documentation487 "Generate and return a plan for performing OPERATION on COMPONENT.488 489 The plan returned is a list of dotted-pairs. Each pair is the CONS490 of ASDF operation object and a COMPONENT object. The pairs will be491 processed in order by OPERATE."))492 493 494 ;;;; -------------------------------------------------------------------------495 ;;;; General Purpose Utilities496 378 497 379 (defmacro while-collecting ((&rest collectors) &body body) … … 673 555 674 556 (defun* getenv (x) 675 (#+ abclext:getenv557 (#+(or abcl clisp) ext:getenv 676 558 #+allegro sys:getenv 677 #+clisp ext:getenv678 559 #+clozure ccl:getenv 679 560 #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=))) … … 721 602 722 603 (defun* absolute-pathname-p (pathspec) 723 (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec)))))) 604 (and (typep pathspec '(or pathname string)) 605 (eq :absolute (car (pathname-directory (pathname pathspec)))))) 724 606 725 607 (defun* length=n-p (x n) ;is it that (= (length x) n) ? … … 753 635 #+allegro (excl.osi:getuid) 754 636 #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") 755 637 :for f = (ignore-errors (read-from-string s)) 756 638 :when f :return (funcall f)) 757 639 #+(or cmu scl) (unix:unix-getuid) … … 775 657 :name nil :type nil :version nil)) 776 658 659 (defun* find-symbol* (s p) 660 (find-symbol (string s) p)) 661 777 662 (defun* probe-file* (p) 778 663 "when given a pathname P, probes the filesystem for a file or directory … … 783 668 (pathname (unless (wild-pathname-p p) 784 669 #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p) 785 #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))786 670 #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p))) 671 '(ignore-errors (truename p))))))) 787 672 788 673 (defun* truenamize (p) … … 855 740 :directory `(:absolute ,@path)))) 856 741 (translate-pathname absolute-pathname wild-root (wilden new-base)))))) 742 743 ;;;; ------------------------------------------------------------------------- 744 ;;;; ASDF Interface, in terms of generic functions. 745 (defgeneric* find-system (system &optional error-p)) 746 (defgeneric* perform-with-restarts (operation component)) 747 (defgeneric* perform (operation component)) 748 (defgeneric* operation-done-p (operation component)) 749 (defgeneric* explain (operation component)) 750 (defgeneric* output-files (operation component)) 751 (defgeneric* input-files (operation component)) 752 (defgeneric* component-operation-time (operation component)) 753 (defgeneric* operation-description (operation component) 754 (:documentation "returns a phrase that describes performing this operation 755 on this component, e.g. \"loading /a/b/c\". 756 You can put together sentences using this phrase.")) 757 758 (defgeneric* system-source-file (system) 759 (:documentation "Return the source file in which system is defined.")) 760 761 (defgeneric* component-system (component) 762 (:documentation "Find the top-level system containing COMPONENT")) 763 764 (defgeneric* component-pathname (component) 765 (:documentation "Extracts the pathname applicable for a particular component.")) 766 767 (defgeneric* component-relative-pathname (component) 768 (:documentation "Returns a pathname for the component argument intended to be 769 interpreted relative to the pathname of that component's parent. 770 Despite the function's name, the return value may be an absolute 771 pathname, because an absolute pathname may be interpreted relative to 772 another pathname in a degenerate way.")) 773 774 (defgeneric* component-property (component property)) 775 776 (defgeneric* (setf component-property) (new-value component property)) 777 778 (defgeneric* version-satisfies (component version)) 779 780 (defgeneric* find-component (base path) 781 (:documentation "Finds the component with PATH starting from BASE module; 782 if BASE is nil, then the component is assumed to be a system.")) 783 784 (defgeneric* source-file-type (component system)) 785 786 (defgeneric* operation-ancestor (operation) 787 (:documentation 788 "Recursively chase the operation's parent pointer until we get to 789 the head of the tree")) 790 791 (defgeneric* component-visited-p (operation component) 792 (:documentation "Returns the value stored by a call to 793 VISIT-COMPONENT, if that has been called, otherwise NIL. 794 This value stored will be a cons cell, the first element 795 of which is a computed key, so not interesting. The 796 CDR wil be the DATA value stored by VISIT-COMPONENT; recover 797 it as (cdr (component-visited-p op c)). 798 In the current form of ASDF, the DATA value retrieved is 799 effectively a boolean, indicating whether some operations are 800 to be performed in order to do OPERATION X COMPONENT. If the 801 data value is NIL, the combination had been explored, but no 802 operations needed to be performed.")) 803 804 (defgeneric* visit-component (operation component data) 805 (:documentation "Record DATA as being associated with OPERATION 806 and COMPONENT. This is a side-effecting function: the association 807 will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the 808 OPERATION\). 809 No evidence that DATA is ever interesting, beyond just being 810 non-NIL. Using the data field is probably very risky; if there is 811 already a record for OPERATION X COMPONENT, DATA will be quietly 812 discarded instead of recorded. 813 Starting with 2.006, TRAVERSE will store an integer in data, 814 so that nodes can be sorted in decreasing order of traversal.")) 815 816 817 (defgeneric* (setf visiting-component) (new-value operation component)) 818 819 (defgeneric* component-visiting-p (operation component)) 820 821 (defgeneric* component-depends-on (operation component) 822 (:documentation 823 "Returns a list of dependencies needed by the component to perform 824 the operation. A dependency has one of the following forms: 825 826 (<operation> <component>*), where <operation> is a class 827 designator and each <component> is a component 828 designator, which means that the component depends on 829 <operation> having been performed on each <component>; or 830 831 (FEATURE <feature>), which means that the component depends 832 on <feature>'s presence in *FEATURES*. 833 834 Methods specialized on subclasses of existing component types 835 should usually append the results of CALL-NEXT-METHOD to the 836 list.")) 837 838 (defgeneric* component-self-dependencies (operation component)) 839 840 (defgeneric* traverse (operation component) 841 (:documentation 842 "Generate and return a plan for performing OPERATION on COMPONENT. 843 844 The plan returned is a list of dotted-pairs. Each pair is the CONS 845 of ASDF operation object and a COMPONENT object. The pairs will be 846 processed in order by OPERATE.")) 847 848 849 ;;;; ------------------------------------------------------------------------- 850 ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 851 (when *upgraded-p* 852 #+ecl 853 (when (find-class 'compile-op nil) 854 (defmethod update-instance-for-redefined-class :after 855 ((c compile-op) added deleted plist &key) 856 (declare (ignore added deleted)) 857 (let ((system-p (getf plist 'system-p))) 858 (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) 859 (when (find-class 'module nil) 860 (eval 861 `(defmethod update-instance-for-redefined-class :after 862 ((m module) added deleted plist &key) 863 (declare (ignorable deleted plist)) 864 (when (or *asdf-verbose* *load-verbose*) 865 (asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version))) 866 (when (member 'components-by-name added) 867 (compute-module-components-by-name m)) 868 (when (and (typep m 'system) (member 'source-file added)) 869 (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m)))))) 857 870 858 871 ;;;; ------------------------------------------------------------------------- … … 998 1011 (missing-requires c) 999 1012 (when (missing-parent c) 1000 (co mponent-name (missing-parent c)))))1013 (coerce-name (missing-parent c))))) 1001 1014 1002 1015 (defmethod print-object ((c missing-component-of-version) s) … … 1293 1306 (let ((*package* package)) 1294 1307 (asdf-message 1295 "~&~@<; ~@; loading system definition from ~A into ~A~@:>~%"1308 "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%" 1296 1309 on-disk *package*) 1297 1310 (load on-disk))) … … 1307 1320 1308 1321 (defun* register-system (name system) 1309 (asdf-message "~&~@<; ~@; registering ~A as ~A~@:>~%" system name)1322 (asdf-message "~&~@<; ~@;Registering ~A as ~A~@:>~%" system name) 1310 1323 (setf (gethash (coerce-name name) *defined-systems*) 1311 1324 (cons (get-universal-time) system))) … … 1313 1326 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) 1314 1327 (setf fallback (coerce-name fallback) 1315 source-file (or source-file *compile-file-truename* *load-truename*) 1328 source-file (or source-file 1329 (if *resolve-symlinks* 1330 (or *compile-file-truename* *load-truename*) 1331 (or *compile-file-pathname* *load-pathname*))) 1316 1332 requested (coerce-name requested)) 1317 1333 (when (equal requested fallback) … … 1319 1335 (system (or registered 1320 1336 (apply 'make-instance 'system 1321 1337 :name fallback :source-file source-file keys)))) 1322 1338 (unless registered 1323 1339 (register-system fallback system)) … … 2199 2215 (defun* class-for-type (parent type) 2200 2216 (or (loop :for symbol :in (list 2201 (unless (keywordp type) type)2202 (find-symbol (symbol-name type)*package*)2203 (find-symbol (symbol-name type):asdf))2217 type 2218 (find-symbol* type *package*) 2219 (find-symbol* type :asdf)) 2204 2220 :for class = (and symbol (find-class symbol nil)) 2205 2221 :when (and class (subtypep class 'component)) … … 2388 2404 :input nil :whole nil 2389 2405 #+mswindows :show-window #+mswindows :hide) 2390 ( format *verbose-out*"~{~&; ~a~%~}~%" stderr)2391 ( format *verbose-out*"~{~&; ~a~%~}~%" stdout)2406 (asdf-message "~{~&; ~a~%~}~%" stderr) 2407 (asdf-message "~{~&; ~a~%~}~%" stdout) 2392 2408 exit-code) 2393 2409 … … 3118 3134 ;;;; ----------------------------------------------------------------- 3119 3135 ;;;; Compatibility mode for ASDF-Binary-Locations 3136 3137 (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) 3138 (declare (ignorable operation-class system args)) 3139 (when (find-symbol* '#:output-files-for-system-and-operation :asdf) 3140 (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. 3141 ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, 3142 which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, 3143 and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. 3144 In case you insist on preserving your previous A-B-L configuration, but 3145 do not know how to achieve the same effect with A-O-T, you may use function 3146 ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; 3147 call that function where you would otherwise have loaded and configured A-B-L."))) 3120 3148 3121 3149 (defun* enable-asdf-binary-locations-compatibility … … 3546 3574 3547 3575 ;;;; ----------------------------------------------------------------- 3548 ;;;; Hook into REQUIRE for ABCL, C lozureCL, CMUCL, ECL and SBCL3576 ;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL 3549 3577 ;;;; 3550 3578 (defun* module-provide-asdf (name) … … 3562 3590 3563 3591 #+(or abcl clisp clozure cmu ecl sbcl) 3564 (let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*":custom))))3592 (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom)))) 3565 3593 (when x 3566 3594 (eval `(pushnew 'module-provide-asdf
Note: See TracChangeset
for help on using the changeset viewer.