Ignore:
Timestamp:
12/03/10 14:02:11 (12 years ago)
Author:
Mark Evenson
Message:

Upgrade to ASDF-2.011.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r12986 r13087  
    6969;;;; Create packages in a way that is compatible with hot-upgrade.
    7070;;;; See https://bugs.launchpad.net/asdf/+bug/485687
    71 ;;;; See more at the end of the file.
     71;;;; See more near the end of the file.
    7272
    7373(eval-when (:load-toplevel :compile-toplevel :execute)
    7474  (defvar *asdf-version* nil)
    7575  (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")
    7782         (existing-asdf (fboundp 'find-system))
    7883         (existing-version *asdf-version*)
    … …  
    8085    (unless (and existing-asdf already-there)
    8186      (when existing-asdf
    82         (format *error-output*
    83                 "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
    84                 existing-version asdf-version))
     87        (format *trace-output*
     88         "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%"
     89         existing-version asdf-version))
    8590      (labels
    8691          ((unlink-package (package)
    … …  
    183188           :unintern
    184189           (#:*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
    186192           :fmakunbound
    187193           (#:system-source-file
    … …  
    237243            #:map-systems
    238244
     245            #:operation-description
    239246            #:operation-on-warnings
    240247            #:operation-on-failure
    … …  
    289296            ;; Utilities
    290297            #:absolute-pathname-p
    291       ;; #:aif #:it
     298            ;; #:aif #:it
    292299            ;; #:appendf
    293300            #:coerce-name
    … …  
    298305            ;; #:get-uid
    299306            ;; #:length=n-p
     307            ;; #:find-symbol*
    300308            #:merge-pathnames*
    301309            #:pathname-directory-pathname
    302310            #:read-file-forms
    303       ;; #:remove-keys
    304       ;; #:remove-keyword
     311            ;; #:remove-keys
     312            ;; #:remove-keyword
    305313            #:resolve-symlinks
    306314            #:split-string
    … …  
    315323                               *upgraded-p*))))))
    316324
    317 ;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
    318 (when *upgraded-p*
    319    #+ecl
    320    (when (find-class 'compile-op nil)
    321      (defmethod update-instance-for-redefined-class :after
    322          ((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      (eval
    328       '(defmethod update-instance-for-redefined-class :after
    329            ((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 
    337325;;;; -------------------------------------------------------------------------
    338326;;;; User-visible parameters
    … …  
    376364
    377365;;;; -------------------------------------------------------------------------
    378 ;;;; ASDF Interface, in terms of generic functions.
     366;;;; General Purpose Utilities
     367
    379368(macrolet
    380369    ((defdef (def* def)
    … …  
    387376  (defdef defgeneric* defgeneric)
    388377  (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 operation
    400 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 be
    414 interpreted relative to the pathname of that component's parent.
    415 Despite the function's name, the return value may be an absolute
    416 pathname, because an absolute pathname may be interpreted relative to
    417 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   (:documentation
    433    "Recursively chase the operation's parent pointer until we get to
    434 the head of the tree"))
    435 
    436 (defgeneric* component-visited-p (operation component)
    437   (:documentation "Returns the value stored by a call to
    438 VISIT-COMPONENT, if that has been called, otherwise NIL.
    439 This value stored will be a cons cell, the first element
    440 of which is a computed key, so not interesting.  The
    441 CDR wil be the DATA value stored by VISIT-COMPONENT; recover
    442 it as (cdr (component-visited-p op c)).
    443   In the current form of ASDF, the DATA value retrieved is
    444 effectively a boolean, indicating whether some operations are
    445 to be performed in order to do OPERATION X COMPONENT.  If the
    446 data value is NIL, the combination had been explored, but no
    447 operations needed to be performed."))
    448 
    449 (defgeneric* visit-component (operation component data)
    450   (:documentation "Record DATA as being associated with OPERATION
    451 and COMPONENT.  This is a side-effecting function:  the association
    452 will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
    453 OPERATION\).
    454   No evidence that DATA is ever interesting, beyond just being
    455 non-NIL.  Using the data field is probably very risky; if there is
    456 already a record for OPERATION X COMPONENT, DATA will be quietly
    457 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   (:documentation
    468    "Returns a list of dependencies needed by the component to perform
    469     the operation.  A dependency has one of the following forms:
    470 
    471       (<operation> <component>*), where <operation> is a class
    472         designator and each <component> is a component
    473         designator, which means that the component depends on
    474         <operation> having been performed on each <component>; or
    475 
    476       (FEATURE <feature>), which means that the component depends
    477         on <feature>'s presence in *FEATURES*.
    478 
    479     Methods specialized on subclasses of existing component types
    480     should usually append the results of CALL-NEXT-METHOD to the
    481     list."))
    482 
    483 (defgeneric* component-self-dependencies (operation component))
    484 
    485 (defgeneric* traverse (operation component)
    486   (:documentation
    487 "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 CONS
    490 of ASDF operation object and a COMPONENT object. The pairs will be
    491 processed in order by OPERATE."))
    492 
    493 
    494 ;;;; -------------------------------------------------------------------------
    495 ;;;; General Purpose Utilities
    496378
    497379(defmacro while-collecting ((&rest collectors) &body body)
    … …  
    673555
    674556(defun* getenv (x)
    675   (#+abcl ext:getenv
     557  (#+(or abcl clisp) ext:getenv
    676558   #+allegro sys:getenv
    677    #+clisp ext:getenv
    678559   #+clozure ccl:getenv
    679560   #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
    … …  
    721602
    722603(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))))))
    724606
    725607(defun* length=n-p (x n) ;is it that (= (length x) n) ?
    … …  
    753635    #+allegro (excl.osi:getuid)
    754636    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
    755             :for f = (ignore-errors (read-from-string s))
     637                  :for f = (ignore-errors (read-from-string s))
    756638                  :when f :return (funcall f))
    757639    #+(or cmu scl) (unix:unix-getuid)
    … …  
    775657                 :name nil :type nil :version nil))
    776658
     659(defun* find-symbol* (s p)
     660  (find-symbol (string s) p))
     661
    777662(defun* probe-file* (p)
    778663  "when given a pathname P, probes the filesystem for a file or directory
    … …  
    783668   (pathname (unless (wild-pathname-p p)
    784669               #.(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          '(ignore-errors (truename p)))))))
     670               #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
     671               '(ignore-errors (truename p)))))))
    787672
    788673(defun* truenamize (p)
    … …  
    855740                            :directory `(:absolute ,@path))))
    856741        (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
     755on this component, e.g. \"loading /a/b/c\".
     756You 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
     769interpreted relative to the pathname of that component's parent.
     770Despite the function's name, the return value may be an absolute
     771pathname, because an absolute pathname may be interpreted relative to
     772another 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;
     782if 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
     789the head of the tree"))
     790
     791(defgeneric* component-visited-p (operation component)
     792  (:documentation "Returns the value stored by a call to
     793VISIT-COMPONENT, if that has been called, otherwise NIL.
     794This value stored will be a cons cell, the first element
     795of which is a computed key, so not interesting.  The
     796CDR wil be the DATA value stored by VISIT-COMPONENT; recover
     797it as (cdr (component-visited-p op c)).
     798  In the current form of ASDF, the DATA value retrieved is
     799effectively a boolean, indicating whether some operations are
     800to be performed in order to do OPERATION X COMPONENT.  If the
     801data value is NIL, the combination had been explored, but no
     802operations needed to be performed."))
     803
     804(defgeneric* visit-component (operation component data)
     805  (:documentation "Record DATA as being associated with OPERATION
     806and COMPONENT.  This is a side-effecting function:  the association
     807will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
     808OPERATION\).
     809  No evidence that DATA is ever interesting, beyond just being
     810non-NIL.  Using the data field is probably very risky; if there is
     811already a record for OPERATION X COMPONENT, DATA will be quietly
     812discarded instead of recorded.
     813  Starting with 2.006, TRAVERSE will store an integer in data,
     814so 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
     844The plan returned is a list of dotted-pairs. Each pair is the CONS
     845of ASDF operation object and a COMPONENT object. The pairs will be
     846processed 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))))))
    857870
    858871;;;; -------------------------------------------------------------------------
    … …  
    9981011          (missing-requires c)
    9991012          (when (missing-parent c)
    1000             (component-name (missing-parent c)))))
     1013            (coerce-name (missing-parent c)))))
    10011014
    10021015(defmethod print-object ((c missing-component-of-version) s)
    … …  
    12931306                 (let ((*package* package))
    12941307                   (asdf-message
    1295                     "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
     1308                    "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
    12961309                    on-disk *package*)
    12971310                   (load on-disk)))
    … …  
    13071320
    13081321(defun* register-system (name system)
    1309   (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
     1322  (asdf-message "~&~@<; ~@;Registering ~A as ~A~@:>~%" system name)
    13101323  (setf (gethash (coerce-name name) *defined-systems*)
    13111324        (cons (get-universal-time) system)))
    … …  
    13131326(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
    13141327  (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*)))
    13161332        requested (coerce-name requested))
    13171333  (when (equal requested fallback)
    … …  
    13191335           (system (or registered
    13201336                       (apply 'make-instance 'system
    1321             :name fallback :source-file source-file keys))))
     1337                              :name fallback :source-file source-file keys))))
    13221338      (unless registered
    13231339        (register-system fallback system))
    … …  
    21992215(defun* class-for-type (parent type)
    22002216  (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))
    22042220        :for class = (and symbol (find-class symbol nil))
    22052221        :when (and class (subtypep class 'component))
    … …  
    23882404         :input nil :whole nil
    23892405         #+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)
    23922408      exit-code)
    23932409
    … …  
    31183134;;;; -----------------------------------------------------------------
    31193135;;;; 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.
     3141ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
     3142which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
     3143and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
     3144In case you insist on preserving your previous A-B-L configuration, but
     3145do not know how to achieve the same effect with A-O-T, you may use function
     3146ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
     3147call that function where you would otherwise have loaded and configured A-B-L.")))
    31203148
    31213149(defun* enable-asdf-binary-locations-compatibility
    … …  
    35463574
    35473575;;;; -----------------------------------------------------------------
    3548 ;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
     3576;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
    35493577;;;;
    35503578(defun* module-provide-asdf (name)
    … …  
    35623590
    35633591#+(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))))
    35653593  (when x
    35663594    (eval `(pushnew 'module-provide-asdf
Note: See TracChangeset for help on using the changeset viewer.