Changeset 14333


Ignore:
Timestamp:
Oct 6, 2010, 6:09:11 PM (9 years ago)
Author:
rme
Message:

ASDF 2.009 from upstream.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/tools/asdf.lisp

    r14252 r14333  
    4848#+xcvb (module ())
    4949
    50 (cl:in-package :cl)
     50(cl:in-package :cl-user)
    5151
    5252(eval-when (:compile-toplevel :load-toplevel :execute)
     
    5656    (make-package :asdf :use '(:cl)))
    5757  ;;; Implementation-dependent tweaks
    58   ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
     58  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
    5959  #+allegro
    6060  (setf excl::*autoload-package-name-alist*
     
    7373  (defvar *upgraded-p* nil)
    7474  (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
    75           (subseq "VERSION:2.008" (1+ (length "VERSION")))) ; same as 2.128
     75          (subseq "VERSION:2.009" (1+ (length "VERSION")))) ; same as 2.134
    7676         (existing-asdf (fboundp 'find-system))
    7777         (existing-version *asdf-version*)
     
    8383                existing-version asdf-version))
    8484      (labels
    85           ((rename-away (package)
    86              (loop :with name = (package-name package)
    87                :for i :from 1 :for new = (format nil "~A.~D" name i)
    88                :unless (find-package new) :do
    89                (rename-package-name package name new)))
    90            (rename-package-name (package old new)
    91              (let* ((old-names (cons (package-name package)
    92                                      (package-nicknames package)))
    93                     (new-names (subst new old old-names :test 'equal))
    94                     (new-name (car new-names))
    95                     (new-nicknames (cdr new-names)))
    96                (rename-package package new-name new-nicknames)))
     85          ((unlink-package (package)
     86             (let ((u (find-package package)))
     87               (when u
     88                 (ensure-unintern u
     89                   (loop :for s :being :each :present-symbol :in u :collect s))
     90                 (loop :for p :in (package-used-by-list u) :do
     91                   (unuse-package u p))
     92                 (delete-package u))))
    9793           (ensure-exists (name nicknames use)
    98              (let* ((previous
    99                      (remove-duplicates
    100                       (remove-if
    101                        #'null
    102                        (mapcar #'find-package (cons name nicknames)))
    103                       :from-end t)))
    104                (cond
    105                  (previous
    106                   ;; do away with packages with conflicting (nick)names
    107                   (map () #'rename-away (cdr previous))
    108                   ;; reuse previous package with same name
    109                   (let ((p (car previous)))
     94             (let ((previous
     95                    (remove-duplicates
     96                     (mapcar #'find-package (cons name nicknames))
     97                     :from-end t)))
     98               ;; do away with packages with conflicting (nick)names
     99               (map () #'unlink-package (cdr previous))
     100               ;; reuse previous package with same name
     101               (let ((p (car previous)))
     102                 (cond
     103                   (p
    110104                    (rename-package p name nicknames)
    111105                    (ensure-use p use)
    112                     p))
    113                  (t
    114                   (make-package name :nicknames nicknames :use use)))))
     106                    p)
     107                   (t
     108                    (make-package name :nicknames nicknames :use use))))))
    115109           (find-sym (symbol package)
    116110             (find-symbol (string symbol) package))
     
    177171                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
    178172                   :fmakunbound ',(append fmakunbound))))
    179           (let ((u (find-package :asdf-utilities)))
    180             (when u
    181               (ensure-unintern u (loop :for s :being :each :present-symbol :in u :collect s))))
     173          (unlink-package :asdf-utilities)
    182174          (pkgdcl
    183175           :asdf
     
    187179            #:perform-with-restarts #:component-relative-pathname
    188180            #:system-source-file #:operate #:find-component #:find-system
    189             #:apply-output-translations #:translate-pathname*)
     181            #:apply-output-translations #:translate-pathname* #:resolve-location)
    190182           :unintern
    191183           (#:*asdf-revision* #:around #:asdf-method-combination
     
    332324   (when (find-class 'module nil)
    333325     (eval
    334       '(defmethod update-instance-for-redefined-class :after
    335            ((m module) added deleted plist &key)
    336          (declare (ignorable deleted plist))
    337          (format *trace-output* "Updating ~A~%" m)
    338          (when (member 'components-by-name added)
    339            (compute-module-components-by-name m))))))
     326      '(progn
     327         (defmethod update-instance-for-redefined-class :after
     328             ((m module) added deleted plist &key)
     329           (declare (ignorable deleted plist))
     330           (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
     331           (when (member 'components-by-name added)
     332             (compute-module-components-by-name m)))
     333         (defmethod update-instance-for-redefined-class :after
     334             ((s system) added deleted plist &key)
     335           (declare (ignorable deleted plist))
     336           (when *asdf-verbose* (format *trace-output* "Updating ~A~%" s))
     337           (when (member 'source-file added)
     338             (%set-system-source-file (probe-asd (component-name s) (component-pathname s)) s)))))))
    340339
    341340;;;; -------------------------------------------------------------------------
     
    971970
    972971(defmethod print-object ((c missing-component) s)
    973   (format s "~@<component ~S not found~
    974              ~@[ in ~A~]~@:>"
     972  (format s "~@<component ~S not found~@[ in ~A~]~@:>"
    975973          (missing-requires c)
    976974          (when (missing-parent c)
     
    978976
    979977(defmethod print-object ((c missing-component-of-version) s)
    980   (format s "~@<component ~S does not match version ~A~
    981               ~@[ in ~A~]~@:>"
     978  (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
    982979          (missing-requires c)
    983980          (missing-version c)
     
    12031200                                   (message
    12041201                                    (format nil
    1205                                             "~@<While searching for system ~S: ~S evaluated ~
    1206 to ~S which is not a directory.~@:>"
     1202                                            "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
    12071203                                            system dir defaults)))
    12081204                              (error message))
     
    12891285        (cons (get-universal-time) system)))
    12901286
    1291 (defun* sysdef-find-asdf (system)
    1292   (let ((name (coerce-name system)))
    1293     (when (equal name "asdf")
    1294       (let* ((registered (cdr (gethash name *defined-systems*)))
    1295              (asdf (or registered
     1287(defun* find-system-fallback (requested fallback &optional source-file)
     1288  (setf fallback (coerce-name fallback)
     1289        source-file (or source-file *compile-file-truename* *load-truename*)
     1290        requested (coerce-name requested))
     1291  (when (equal requested fallback)
     1292    (let* ((registered (cdr (gethash fallback *defined-systems*)))
     1293           (system (or registered
    12961294                       (make-instance
    1297                         'system :name "asdf"
    1298                         :source-file (or *compile-file-truename* *load-truename*)))))
    1299         (unless registered
    1300           (register-system "asdf" asdf))
    1301         (throw 'find-system asdf)))))
     1295                        'system :name fallback
     1296                        :source-file source-file))))
     1297      (unless registered
     1298        (register-system fallback system))
     1299      (throw 'find-system system))))
     1300
     1301(defun* sysdef-find-asdf (name)
     1302  (find-system-fallback name "asdf"))
    13021303
    13031304
     
    17851786(defmethod perform ((operation operation) (c source-file))
    17861787  (sysdef-error
    1787    "~@<required method PERFORM not implemented ~
    1788     for operation ~A, component ~A~@:>"
     1788   "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
    17891789   (class-of operation) (class-of c)))
    17901790
     
    18991899
    19001900(defmethod perform ((o load-op) (c cl-source-file))
    1901   #-ecl (mapcar #'load (input-files o c))
    1902   #+ecl (loop :for i :in (input-files o c)
    1903           :unless (string= (pathname-type i) "fas")
    1904           :collect (let ((output (compile-file-pathname (lispize-pathname i))))
    1905                      (load output))))
     1901  (map () #'load
     1902       #-ecl (input-files o c)
     1903       #+ecl (loop :for i :in (input-files o c)
     1904               :unless (string= (pathname-type i) "fas")
     1905               :collect (compile-file-pathname (lispize-pathname i)))))
    19061906
    19071907(defmethod perform-with-restarts (operation component)
     
    20662066                :report
    20672067                (lambda (s)
    2068                   (format s "~@<Continue, treating ~A as ~
    2069                                    having been successful.~@:>"
     2068                  (format s "~@<Continue, treating ~A as having been successful.~@:>"
    20702069                          (operation-description op component)))
    20712070                (setf (gethash (type-of op)
     
    21102109details."
    21112110  (declare (ignore force verbose version))
    2112   (apply #'operate 'load-op system args))
     2111  (apply #'operate 'load-op system args)
     2112  t)
    21132113
    21142114(defun* compile-system (system &rest args &key force verbose version
     
    21172117for details."
    21182118  (declare (ignore force verbose version))
    2119   (apply #'operate 'compile-op system args))
     2119  (apply #'operate 'compile-op system args)
     2120  t)
    21202121
    21212122(defun* test-system (system &rest args &key force verbose version
     
    21242125details."
    21252126  (declare (ignore force verbose version))
    2126   (apply #'operate 'test-op system args))
     2127  (apply #'operate 'test-op system args)
     2128  t)
    21272129
    21282130;;;; -------------------------------------------------------------------------
     
    25432545                            *architecture-features*))
    25442546          (version (maybe-warn (lisp-version-string)
    2545                                "Don't know how to get Lisp ~
    2546                                           implementation version.")))
     2547                               "Don't know how to get Lisp implementation version.")))
    25472548      (substitute-if
    25482549       #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
     
    26932694                 :name :wild :type "asd" :version :newest))
    26942695
    2695 (declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional))
     2696(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
     2697                          (values (or null pathname) &optional))
    26962698                resolve-location))
    26972699
    2698 (defun* resolve-relative-location-component (super x &optional wildenp)
     2700(defun* resolve-relative-location-component (super x &key directory wilden)
    26992701  (let* ((r (etypecase x
    27002702              (pathname x)
    27012703              (string x)
    27022704              (cons
    2703                (let ((car (resolve-relative-location-component super (car x) nil)))
     2705               (return-from resolve-relative-location-component
    27042706                 (if (null (cdr x))
    2705                      car
    2706                      (let ((cdr (resolve-relative-location-component
    2707                                  (merge-pathnames* car super) (cdr x) wildenp)))
     2707                     (resolve-relative-location-component
     2708                      super (car x) :directory directory :wilden wilden)
     2709                     (let* ((car (resolve-relative-location-component
     2710                                  super (car x) :directory t :wilden nil))
     2711                            (cdr (resolve-relative-location-component
     2712                                  (merge-pathnames* car super) (cdr x)
     2713                                  :directory directory :wilden wilden)))
    27082714                       (merge-pathnames* cdr car)))))
    27092715              ((eql :default-directory)
     
    27132719              #-(and (or win32 windows mswindows mingw32) (not cygwin))
    27142720              ((eql :uid) (princ-to-string (get-uid)))))
    2715          (d (if (pathnamep x) r (ensure-directory-pathname r)))
    2716          (s (if (and wildenp (not (pathnamep x)))
    2717                 (wilden d)
    2718                 d)))
     2721         (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
     2722         (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
    27192723    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
    27202724      (error "pathname ~S is not relative to ~S" s super))
    27212725    (merge-pathnames* s super)))
    27222726
    2723 (defun* resolve-absolute-location-component (x wildenp)
     2727(defun* resolve-absolute-location-component (x &key directory wilden)
    27242728  (let* ((r
    27252729          (etypecase x
    27262730            (pathname x)
    2727             (string (ensure-directory-pathname x))
     2731            (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
    27282732            (cons
    2729              (let ((car (resolve-absolute-location-component (car x) nil)))
     2733             (return-from resolve-absolute-location-component
    27302734               (if (null (cdr x))
    2731                    car
    2732                    (let ((cdr (resolve-relative-location-component
    2733                                car (cdr x) wildenp)))
    2734                      (merge-pathnames* cdr car)))))
     2735                   (resolve-absolute-location-component
     2736                    (car x) :directory directory :wilden wilden)
     2737                   (let* ((car (resolve-absolute-location-component
     2738                                (car x) :directory t :wilden nil))
     2739                          (cdr (resolve-relative-location-component
     2740                                car (cdr x) :directory directory :wilden wilden)))
     2741                     (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
    27352742            ((eql :root)
    27362743             ;; special magic! we encode such paths as relative pathnames,
    27372744             ;; but it means "relative to the root of the source pathname's host and device".
    27382745             (return-from resolve-absolute-location-component
    2739                (make-pathname :directory '(:relative))))
     2746               (let ((p (make-pathname :directory '(:relative))))
     2747                 (if wilden (wilden p) p))))
    27402748            ((eql :home) (user-homedir))
    2741             ((eql :user-cache) (resolve-location *user-cache* nil))
    2742             ((eql :system-cache) (resolve-location *system-cache* nil))
     2749            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
     2750            ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
    27432751            ((eql :default-directory) (default-directory))))
    2744          (s (if (and wildenp (not (pathnamep x)))
     2752         (s (if (and wilden (not (pathnamep x)))
    27452753                (wilden r)
    27462754                r)))
     
    27492757    s))
    27502758
    2751 (defun* resolve-location (x &optional wildenp)
     2759(defun* resolve-location (x &key directory wilden)
    27522760  (if (atom x)
    2753       (resolve-absolute-location-component x wildenp)
    2754       (loop :with path = (resolve-absolute-location-component (car x) nil)
     2761      (resolve-absolute-location-component x :directory directory :wilden wilden)
     2762      (loop :with path = (resolve-absolute-location-component
     2763                          (car x) :directory (and (or directory (cdr x)) t)
     2764                          :wilden (and wilden (null (cdr x))))
    27552765        :for (component . morep) :on (cdr x)
     2766        :for dir = (and (or morep directory) t)
     2767        :for wild = (and wilden (not morep))
    27562768        :do (setf path (resolve-relative-location-component
    2757                         path component (and wildenp (not morep))))
     2769                        path component :directory dir :wilden wild))
    27582770        :finally (return path))))
    27592771
     
    27762788      (or (member directive '(:inherit-configuration
    27772789                              :ignore-inherited-configuration
    2778                               :enable-user-cache :disable-cache))
     2790                              :enable-user-cache :disable-cache nil))
    27792791          (and (consp directive)
    27802792               (or (and (length=n-p directive 2)
     
    28532865    ;; Some implementations have precompiled ASDF systems,
    28542866    ;; so we must disable translations for implementation paths.
    2855     #+sbcl (,(getenv "SBCL_HOME") ())
     2867    #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
    28562868    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
    2857     #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
     2869    #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
    28582870    ;; All-import, here is where we want user stuff to be:
    28592871    :inherit-configuration
     
    29212933        ((:inherit-configuration)
    29222934         (inherit-output-translations inherit :collect collect))
    2923         ((:ignore-inherited-configuration)
     2935        ((:ignore-inherited-configuration nil)
    29242936         nil))
    29252937      (let ((src (first directive))
     
    29302942            (when src
    29312943              (let ((trusrc (or (eql src t)
    2932                                 (let ((loc (resolve-location src t)))
     2944                                (let ((loc (resolve-location src :directory t :wilden t)))
    29332945                                  (if (absolute-pathname-p loc) (truenamize loc) loc)))))
    29342946                (cond
     
    29432955                  (t
    29442956                   (let* ((trudst (make-pathname
    2945                                    :defaults (if dst (resolve-location dst t) trusrc)))
     2957                                   :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
    29462958                          (wilddst (make-pathname
    29472959                                    :name :wild :type :wild :version :wild
     
    30893101                           (user-homedir)))
    30903102     (include-per-user-information nil)
    3091      (map-all-source-files nil)
     3103     (map-all-source-files (or #+(or ecl clisp) t nil))
    30923104     (source-to-target-mappings nil))
     3105  (when (and (null map-all-source-files) #-(or ecl clisp) nil)
     3106    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
    30933107  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
    30943108         (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
     
    31173131;;;; http://www.wotsit.org/list.asp?fc=13
    31183132
     3133#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     3134(progn
    31193135(defparameter *link-initial-dword* 76)
    31203136(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
     
    31833199                    (map 'string #'code-char buffer)))))))
    31843200      (end-of-file ()
    3185         nil))))
     3201        nil)))))
    31863202
    31873203;;;; -----------------------------------------------------------------
     
    32263242              ((:include :directory :tree)
    32273243               (and (length=n-p rest 1)
    3228                     (typep (car rest) '(or pathname string null))))
     3244                    (location-designator-p (first rest))))
    32293245              ((:exclude :also-exclude)
    32303246               (every #'stringp rest))
     
    33903406      ((:include)
    33913407       (destructuring-bind (pathname) rest
    3392          (process-source-registry (pathname pathname) :inherit nil :register register)))
     3408         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
    33933409      ((:directory)
    33943410       (destructuring-bind (pathname) rest
    33953411         (when pathname
    3396            (funcall register (ensure-directory-pathname pathname)))))
     3412           (funcall register (resolve-location pathname :directory t)))))
    33973413      ((:tree)
    33983414       (destructuring-bind (pathname) rest
    33993415         (when pathname
    3400            (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
     3416           (funcall register (resolve-location pathname :directory t)
     3417                    :recurse t :exclude *source-registry-exclusions*))))
    34013418      ((:exclude)
    34023419       (setf *source-registry-exclusions* rest))
Note: See TracChangeset for help on using the changeset viewer.