Changeset 14380


Ignore:
Timestamp:
Oct 29, 2010, 3:14:12 PM (9 years ago)
Author:
rme
Message:

Update to ASDF 2.010.

File:
1 edited

Legend:

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

    r14333 r14380  
    7272  (defvar *asdf-version* nil)
    7373  (defvar *upgraded-p* nil)
    74   (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
    75           (subseq "VERSION:2.009" (1+ (length "VERSION")))) ; same as 2.134
     74  (let* ((asdf-version "2.010") ;; same as 2.146
    7675         (existing-asdf (fboundp 'find-system))
    7776         (existing-version *asdf-version*)
     
    7978    (unless (and existing-asdf already-there)
    8079      (when existing-asdf
    81         (format *trace-output*
     80        (format *error-output*
    8281                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
    8382                existing-version asdf-version))
     
    171170                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
    172171                   :fmakunbound ',(append fmakunbound))))
    173           (unlink-package :asdf-utilities)
    174172          (pkgdcl
    175173           :asdf
     174           :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
    176175           :use (:common-lisp)
    177176           :redefined-functions
     
    306305            #:component-name-to-pathname-components
    307306            #:split-name-type
     307            #:subdirectories
    308308            #:truenamize
    309309            #:while-collecting)))
     
    534534         (defaults (pathname defaults))
    535535         (directory (pathname-directory specified))
    536          #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory))
     536         (directory
     537          (cond
     538            #-(or sbcl cmu)
     539            ((stringp directory) `(:absolute ,directory) directory)
     540            #+gcl
     541            ((and (consp directory) (stringp (first directory)))
     542             `(:absolute ,@directory))
     543            ((or (null directory)
     544                 (and (consp directory) (member (first directory) '(:absolute :relative))))
     545             directory)
     546            (t
     547             (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
    537548         (name (or (pathname-name specified) (pathname-name defaults)))
    538549         (type (or (pathname-type specified) (pathname-type defaults)))
     
    543554               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
    544555      (multiple-value-bind (host device directory unspecific-handler)
    545           (#-gcl ecase #+gcl case (first directory)
     556          (ecase (first directory)
    546557            ((nil)
    547558             (values (pathname-host defaults)
     
    560571                         (append (pathname-directory defaults) (cdr directory))
    561572                         directory)
    562                      (unspecific-handler defaults)))
    563             #+gcl
    564             (t
    565              (assert (stringp (first directory)))
    566              (values (pathname-host defaults)
    567                      (pathname-device defaults)
    568                      (append (pathname-directory defaults) directory)
    569573                     (unspecific-handler defaults))))
    570574        (make-pathname :host host :device device :directory directory
     
    621625          (values name type)))))
    622626
    623 (defun* component-name-to-pathname-components (s &optional force-directory)
     627(defun* component-name-to-pathname-components (s &key force-directory force-relative)
    624628  "Splits the path string S, returning three values:
    625629A flag that is either :absolute or :relative, indicating
     
    638642pathnames."
    639643  (check-type s string)
     644  (when (find #\: s)
     645    (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
    640646  (let* ((components (split-string s :separator "/"))
    641647         (last-comp (car (last components))))
     
    643649        (if (equal (first components) "")
    644650            (if (equal (first-char s) #\/)
    645                 (values :absolute (cdr components))
     651                (progn
     652                  (when force-relative
     653                    (error "absolute pathname designator not allowed: ~S" s))
     654                  (values :absolute (cdr components)))
    646655                (values :relative nil))
    647656          (values :relative components))
     
    687696Note that this does _not_ check to see that PATHNAME points to an
    688697actually-existing directory."
    689   (flet ((check-one (x)
    690            (member x '(nil :unspecific "") :test 'equal)))
    691     (and (check-one (pathname-name pathname))
    692          (check-one (pathname-type pathname))
    693          t)))
     698  (when pathname
     699    (let ((pathname (pathname pathname)))
     700      (flet ((check-one (x)
     701               (member x '(nil :unspecific "") :test 'equal)))
     702        (and (not (wild-pathname-p pathname))
     703             (check-one (pathname-name pathname))
     704             (check-one (pathname-type pathname))
     705             t)))))
    694706
    695707(defun* ensure-directory-pathname (pathspec)
     
    701713    (error "Invalid pathname designator ~S" pathspec))
    702714   ((wild-pathname-p pathspec)
    703     (error "Can't reliably convert wild pathnames."))
     715    (error "Can't reliably convert wild pathname ~S" pathspec))
    704716   ((directory-pathname-p pathspec)
    705717    pathspec)
     
    774786   (pathname (unless (wild-pathname-p p)
    775787               #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
    776                #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(,it p))
     788               #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))
    777789               '(ignore-errors (truename p)))))))
    778790
     
    840852                         root-namestring)))
    841853    (multiple-value-bind (relative path filename)
    842         (component-name-to-pathname-components root-string t)
     854        (component-name-to-pathname-components root-string :force-directory t)
    843855      (declare (ignore relative filename))
    844856      (let ((new-base
     
    922934         "Component name: designator for a string composed of portable pathname characters")
    923935   (version :accessor component-version :initarg :version)
    924    (in-order-to :initform nil :initarg :in-order-to
    925                 :accessor component-in-order-to)
    926936   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
    927937   ;; POIU is a parallel (multi-process build) extension of ASDF.  See
    928938   ;; http://www.cliki.net/poiu
    929939   (load-dependencies :accessor component-load-dependencies :initform nil)
    930    ;; XXX crap name, but it's an official API name!
     940   ;; In the ASDF object model, dependencies exist between *actions*
     941   ;; (an action is a pair of operation and component). They are represented
     942   ;; alists of operations to dependencies (other actions) in each component.
     943   ;; There are two kinds of dependencies, each stored in its own slot:
     944   ;; in-order-to and do-first dependencies. These two kinds are related to
     945   ;; the fact that some actions modify the filesystem,
     946   ;; whereas other actions modify the current image, and
     947   ;; this implies a difference in how to interpret timestamps.
     948   ;; in-order-to dependencies will trigger re-performing the action
     949   ;; when the timestamp of some dependency
     950   ;; makes the timestamp of current action out-of-date;
     951   ;; do-first dependencies do not trigger such re-performing.
     952   ;; Therefore, a FASL must be recompiled if it is obsoleted
     953   ;; by any of its FASL dependencies (in-order-to); but
     954   ;; it needn't be recompiled just because one of these dependencies
     955   ;; hasn't yet been loaded in the current image (do-first).
     956   ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
     957   (in-order-to :initform nil :initarg :in-order-to
     958                :accessor component-in-order-to)
    931959   (do-first :initform nil :initarg :do-first
    932960             :accessor component-do-first)
     
    10611089            :accessor system-license :initarg :license)
    10621090   (source-file :reader system-source-file :initarg :source-file
    1063                 :writer %set-system-source-file)))
     1091                :writer %set-system-source-file)
     1092   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
    10641093
    10651094;;;; -------------------------------------------------------------------------
     
    12851314        (cons (get-universal-time) system)))
    12861315
    1287 (defun* find-system-fallback (requested fallback &optional source-file)
     1316(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
    12881317  (setf fallback (coerce-name fallback)
    12891318        source-file (or source-file *compile-file-truename* *load-truename*)
     
    12921321    (let* ((registered (cdr (gethash fallback *defined-systems*)))
    12931322           (system (or registered
    1294                        (make-instance
    1295                         'system :name fallback
    1296                         :source-file source-file))))
     1323                       (apply 'make-instance 'system
     1324                              :name fallback :source-file source-file keys))))
    12971325      (unless registered
    12981326        (register-system fallback system))
     
    13001328
    13011329(defun* sysdef-find-asdf (name)
    1302   (find-system-fallback name "asdf"))
     1330  (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
    13031331
    13041332
     
    13711399    (string
    13721400     (multiple-value-bind (relative path filename)
    1373          (component-name-to-pathname-components name (eq type :directory))
     1401         (component-name-to-pathname-components name :force-directory (eq type :directory)
     1402                                                :force-relative t)
    13741403       (multiple-value-bind (name type)
    13751404           (cond
     
    16011630
    16021631(defun* do-one-dep (operation c collect required-op required-c required-v)
    1603   ;; this function is a thin, error-handling wrapper around
    1604   ;; %do-one-dep.  Returns a partial plan per that function.
     1632  ;; this function is a thin, error-handling wrapper around %do-one-dep.
     1633  ;; Collects a partial plan per that function.
    16051634  (loop
    16061635    (restart-case
     
    16131642        :test
    16141643        (lambda (c)
    1615           #|
    1616           (print (list :c1 c (typep c 'missing-dependency)))
    1617           (when (typep c 'missing-dependency)
    1618           (print (list :c2 (missing-requires c) required-c
    1619           (equalp (missing-requires c)
    1620           required-c))))
    1621           |#
    16221644          (or (null c)
    16231645              (and (typep c 'missing-dependency)
     
    18331855        (get-universal-time)))
    18341856
    1835 (declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
     1857(declaim (ftype (function ((or pathname string)
     1858                           &rest t &key (:output-file t) &allow-other-keys)
    18361859                          (values t t t))
    18371860                compile-file*))
     
    21532176                            defsystem-depends-on &allow-other-keys)
    21542177      options
    2155     (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
     2178    (let ((component-options (remove-keys '(:class) options)))
    21562179      `(progn
    21572180         ;; system must be registered before we parse the body, otherwise
     
    24582481
    24592482(defparameter *implementation-features*
    2460   '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
    2461     :corman :cormanlisp :armedbear :gcl :ecl :scl))
     2483  '((:acl :allegro)
     2484    (:lw :lispworks)
     2485    (:digitool) ; before clozure, so it won't get preempted by ccl
     2486    (:ccl :clozure)
     2487    (:corman :cormanlisp)
     2488    (:abcl :armedbear)
     2489    :sbcl :cmu :clisp :gcl :ecl :scl))
    24622490
    24632491(defparameter *os-features*
    2464   '((:windows :mswindows :win32 :mingw32)
     2492  '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
    24652493    (:solaris :sunos)
    2466     :linux ;; for GCL at least, must appear before :bsd.
    2467     :macosx :darwin :apple
     2494    (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
     2495    (:macosx :darwin :darwin-target :apple)
    24682496    :freebsd :netbsd :openbsd :bsd
    24692497    :unix))
    24702498
    24712499(defparameter *architecture-features*
    2472   '((:x86-64 :amd64 :x86_64 :x8664-target)
    2473     (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
    2474     :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc
    2475     :java-1.4 :java-1.5 :java-1.6 :java-1.7))
    2476 
     2500  '((:amd64 :x86-64 :x86_64 :x8664-target)
     2501    (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
     2502    :hppa64
     2503    :hppa
     2504    (:ppc64 :ppc64-target)
     2505    (:ppc32 :ppc32-target :ppc :powerpc)
     2506    :sparc64
     2507    (:sparc32 :sparc)
     2508    (:arm :arm-target)
     2509    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
    24772510
    24782511(defun* lisp-version-string ()
     
    24932526    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    24942527    #+clisp (subseq s 0 (position #\space s))
    2495     #+clozure (format nil "~d.~d-fasl~d"
     2528    #+clozure (format nil "~d.~d-f~d" ; shorten for windows
    24962529                      ccl::*openmcl-major-version*
    24972530                      ccl::*openmcl-minor-version*
     
    26892722  (setf *output-translations* '())
    26902723  (values))
    2691 
    2692 (defparameter *wild-asd*
    2693   (make-pathname :directory '(:relative :wild-inferiors)
    2694                  :name :wild :type "asd" :version :newest))
    26952724
    26962725(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
     
    28732902    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
    28742903    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    2875     ;; If we want to enable the user cache by default, here would be the place:
     2904    ;; We enable the user cache by default, and here is the place we do:
    28762905    :enable-user-cache))
    28772906
     
    30523081    (delete-file x)))
    30533082
    3054 (defun* compile-file* (input-file &rest keys &key &allow-other-keys)
    3055   (let* ((output-file (apply 'compile-file-pathname* input-file keys))
     3083(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
     3084  (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
    30563085         (tmp-file (tmpize-pathname output-file))
    30573086         (status :error))
     
    31033132     (map-all-source-files (or #+(or ecl clisp) t nil))
    31043133     (source-to-target-mappings nil))
    3105   (when (and (null map-all-source-files) #-(or ecl clisp) nil)
     3134  #+(or ecl clisp)
     3135  (when (null map-all-source-files)
    31063136    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
    31073137  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
     
    32073237;; Using ack 1.2 exclusions
    32083238(defvar *default-source-registry-exclusions*
    3209   '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
     3239  '(".bzr" ".cdv"
     3240    ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
    32103241    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    32113242    "_sgbak" "autom4te.cache" "cover_db" "_build"
     
    32343265  (setf *source-registry* '())
    32353266  (values))
     3267
     3268(defparameter *wild-asd*
     3269  (make-pathname :directory nil :name :wild :type "asd" :version :newest))
     3270
     3271(defun directory-has-asd-files-p (directory)
     3272  (and (ignore-errors
     3273         (directory (merge-pathnames* *wild-asd* directory)
     3274                    #+sbcl #+sbcl :resolve-symlinks nil
     3275                    #+ccl #+ccl :follow-links nil
     3276                    #+clisp #+clisp :circle t))
     3277       t))
     3278
     3279(defun subdirectories (directory)
     3280  (let* ((directory (ensure-directory-pathname directory))
     3281         #-cormanlisp
     3282         (wild (merge-pathnames*
     3283                #-(or abcl allegro lispworks scl)
     3284                (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
     3285                #+(or abcl allegro lispworks scl) "*.*"
     3286                directory))
     3287         (dirs
     3288          #-cormanlisp
     3289          (ignore-errors
     3290            (directory wild .
     3291              #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
     3292                    #+ccl '(:follow-links nil :directories t :files nil)
     3293                    #+clisp '(:circle t :if-does-not-exist :ignore)
     3294                    #+(or cmu scl) '(:follow-links nil :truenamep nil)
     3295                    #+digitool '(:directories t)
     3296                    #+sbcl '(:resolve-symlinks nil))))
     3297          #+cormanlisp (cl::directory-subdirs directory))
     3298         #+(or abcl allegro lispworks scl)
     3299         (dirs (remove-if-not #+abcl #'extensions:probe-directory
     3300                              #+allegro #'excl:probe-directory
     3301                              #+lispworks #'lw:file-directory-p
     3302                              #-(or abcl allegro lispworks) #'directory-pathname-p
     3303                              dirs)))
     3304    dirs))
     3305
     3306(defun collect-sub*directories (directory collectp recursep collector)
     3307  (when (funcall collectp directory)
     3308    (funcall collector directory))
     3309  (dolist (subdir (subdirectories directory))
     3310    (when (funcall recursep subdir)
     3311      (collect-sub*directories subdir collectp recursep collector))))
     3312
     3313(defun collect-sub*directories-with-asd
     3314    (directory &key
     3315     (exclude *default-source-registry-exclusions*)
     3316     collect)
     3317  (collect-sub*directories
     3318   directory
     3319   #'directory-has-asd-files-p
     3320   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
     3321   collect))
    32363322
    32373323(defun* validate-source-registry-directive (directive)
     
    32983384  (if (not recurse)
    32993385      (funcall collect directory)
    3300       (let* ((files
    3301               (handler-case
    3302                   (directory (merge-pathnames* *wild-asd* directory)
    3303                              #+sbcl #+sbcl :resolve-symlinks nil
    3304                              #+clisp #+clisp :circle t)
    3305                 (error (c)
    3306                   (warn "Error while scanning system definitions under directory ~S:~%~A"
    3307                         directory c)
    3308                   nil)))
    3309              (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
    3310                                       :test #'equal :from-end t)))
    3311         (loop
    3312           :for dir :in dirs
    3313           :unless (loop :for x :in exclude
    3314                     :thereis (find x (pathname-directory dir) :test #'equal))
    3315           :do (funcall collect dir)))))
     3386      (collect-sub*directories-with-asd
     3387       directory :exclude exclude :collect collect)))
    33163388
    33173389(defparameter *default-source-registries*
Note: See TracChangeset for help on using the changeset viewer.