Changeset 15423


Ignore:
Timestamp:
Jul 17, 2012, 5:30:46 PM (7 years ago)
Author:
rme
Message:

ASDF 2.23 from upstream.

File:
1 edited

Legend:

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

    r15414 r15423  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
    2 ;;; This is ASDF 2.22: Another System Definition Facility.
     2;;; This is ASDF 2.23: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    117117         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    118118         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    119          (asdf-version "2.22")
     119         (asdf-version "2.23")
    120120         (existing-asdf (find-class 'component nil))
    121121         (existing-version *asdf-version*)
     
    372372            #:directory-pathname-p #:ensure-directory-pathname
    373373            #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root
    374             #:getenv
     374            #:getenv #:getenv-pathname #:getenv-pathname
     375            #:getenv-absolute-directory #:getenv-absolute-directories
    375376            #:probe-file*
    376377            #:find-symbol* #:strcat
     
    24652466    (multiple-value-bind (output warnings-p failure-p)
    24662467        (call-with-around-compile-hook
    2467          c #'(lambda ()
     2468         c #'(lambda (&rest flags)
    24682469               (apply *compile-op-compile-file-function* source-file
    24692470                      :output-file output-file
    24702471                      :external-format (component-external-format c)
    2471                       (compile-op-flags operation))))
     2472                      (append flags (compile-op-flags operation)))))
    24722473      (unless output
    24732474        (error 'compile-error :component c :operation operation))
     
    32913292    #-mcl (user-homedir-pathname))))
    32923293
    3293 (defun* ensure-absolute-pathname* (x fmt &rest args)
    3294   (and (plusp (length x))
    3295        (or (absolute-pathname-p x)
    3296            (cerror "ignore relative pathname"
    3297                    "Invalid relative pathname ~A~@[ ~?~]" x fmt args))
    3298        x))
    3299 (defun* split-absolute-pathnames (x fmt &rest args)
     3294(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args)
     3295  (when (plusp (length x))
     3296    (let ((p (if want-directory (ensure-directory-pathname x) (pathname x))))
     3297      (when want-absolute
     3298        (unless (absolute-pathname-p p)
     3299          (cerror "ignore relative pathname"
     3300                  "Invalid relative pathname ~A~@[ ~?~]" x fmt args)
     3301          (return-from ensure-pathname* nil)))
     3302      p)))
     3303(defun* split-pathnames* (x want-absolute want-directory fmt &rest args)
    33003304  (loop :for dir :in (split-string
    33013305                      x :separator (string (inter-directory-separator)))
    3302     :do (apply 'ensure-absolute-pathname* dir fmt args)
    3303     :collect dir))
    3304 (defun getenv-absolute-pathname (x &aux (s (getenv x)))
    3305   (ensure-absolute-pathname* s "from (getenv ~S)" x))
    3306 (defun getenv-absolute-pathnames (x &aux (s (getenv x)))
     3306        :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args)))
     3307(defun getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x)))
     3308  (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x))
     3309(defun getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x)))
    33073310  (and (plusp (length s))
    3308        (split-absolute-pathnames s "from (getenv ~S) = ~S" x s)))
     3311       (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s)))
     3312(defun getenv-absolute-directory (x)
     3313  (getenv-pathname x :want-absolute t :want-directory t))
     3314(defun getenv-absolute-directories (x)
     3315  (getenv-pathnames x :want-absolute t :want-directory t))
     3316
    33093317
    33103318(defun* user-configuration-directories ()
     
    33123320         `(,@(when (os-unix-p)
    33133321               (cons
    3314                 (subpathname* (getenv-absolute-pathname "XDG_CONFIG_HOME") "common-lisp/")
    3315                 (loop :for dir :in (getenv-absolute-pathnames "XDG_CONFIG_DIRS")
     3322                (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
     3323                (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
    33163324                  :collect (subpathname* dir "common-lisp/"))))
    33173325           ,@(when (os-windows-p)
    33183326               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
    3319                                     (getenv-absolute-pathname "LOCALAPPDATA"))
     3327                                    (getenv-absolute-directory "LOCALAPPDATA"))
    33203328                               "common-lisp/config/")
    33213329                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    33223330                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
    3323                                     (getenv-absolute-pathname "APPDATA"))
     3331                                    (getenv-absolute-directory "APPDATA"))
    33243332                                "common-lisp/config/")))
    33253333           ,(subpathname (user-homedir) ".config/common-lisp/"))))
     
    33343342      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    33353343      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
    3336                         (getenv-absolute-pathname "ALLUSERSAPPDATA")
    3337                         (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/"))
     3344                        (getenv-absolute-directory "ALLUSERSAPPDATA")
     3345                        (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))
    33383346                    "common-lisp/config/")
    33393347      (list it)))))
     
    34593467  (flet ((try (x &rest sub) (and x `(,x ,@sub))))
    34603468    (or
    3461      (try (getenv-absolute-pathname "XDG_CACHE_HOME") "common-lisp" :implementation)
     3469     (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
    34623470     (when (os-windows-p)
    34633471       (try (or #+lispworks (sys:get-folder-path :local-appdata)
    3464                 (getenv-absolute-pathname "LOCALAPPDATA")
     3472                (getenv-absolute-directory "LOCALAPPDATA")
    34653473                #+lispworks (sys:get-folder-path :appdata)
    3466                 (getenv-absolute-pathname "APPDATA"))
     3474                (getenv-absolute-directory "APPDATA"))
    34673475            "common-lisp" "cache" :implementation))
    34683476     '(:home ".cache" "common-lisp" :implementation))))
     
    36883696    ;; Some implementations have precompiled ASDF systems,
    36893697    ;; so we must disable translations for implementation paths.
    3690     #+sbcl ,(let ((h (getenv "SBCL_HOME")))
    3691                  (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
     3698    #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t)))
     3699              (when h `((,(truenamize h) ,*wild-inferiors*) ())))
    36923700    ;; The below two are not needed: no precompiled ASDF system there
    36933701    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
     
    38833891    (delete-file x)))
    38843892
    3885 (defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
    3886   (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys))
     3893(defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys)
     3894  (let* ((keywords (remove-keyword :compile-check keys))
     3895         (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
    38873896         (tmp-file (tmpize-pathname output-file))
    38883897         (status :error))
    38893898    (multiple-value-bind (output-truename warnings-p failure-p)
    3890         (apply 'compile-file input-file :output-file tmp-file keys)
     3899        (apply 'compile-file input-file :output-file tmp-file keywords)
    38913900      (cond
    38923901        (failure-p
     
    38963905        (t
    38973906         (setf status :success)))
    3898       (ecase status
    3899         ((:success :warn :ignore)
     3907      (cond
     3908        ((and (ecase status
     3909                ((:success :warn :ignore) t)
     3910                ((:error nil)))
     3911              (or (not compile-check)
     3912                  (apply compile-check input-file :output-file tmp-file keywords)))
    39003913         (delete-file-if-exists output-file)
    39013914         (when output-truename
    39023915           (rename-file output-truename output-file)
    39033916           (setf output-truename output-file)))
    3904         (:error
     3917        (t ;; error or failed check
    39053918         (delete-file-if-exists output-truename)
    3906          (setf output-truename nil)))
     3919         (setf output-truename nil failure-p t)))
    39073920      (values output-truename warnings-p failure-p))))
    39083921
     
    41804193(defun* wrapping-source-registry ()
    41814194  `(:source-registry
    4182     #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
     4195    #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t)))
    41834196    :inherit-configuration
    41844197    #+cmu (:tree #p"modules:")
     
    41904203      ,@(loop :for dir :in
    41914204          `(,@(when (os-unix-p)
    4192                 `(,(or (getenv-absolute-pathname "XDG_DATA_HOME")
     4205                `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
    41934206                       (subpathname (user-homedir) ".local/share/"))
    4194                   ,@(or (getenv-absolute-pathnames "XDG_DATA_DIRS")
     4207                  ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
    41954208                        '("/usr/local/share" "/usr/share"))))
    41964209            ,@(when (os-windows-p)
    41974210                `(,(or #+lispworks (sys:get-folder-path :local-appdata)
    4198                        (getenv-absolute-pathname "LOCALAPPDATA"))
     4211                       (getenv-absolute-directory "LOCALAPPDATA"))
    41994212                  ,(or #+lispworks (sys:get-folder-path :appdata)
    4200                        (getenv-absolute-pathname "APPDATA"))
     4213                       (getenv-absolute-directory "APPDATA"))
    42014214                  ,(or #+lispworks (sys:get-folder-path :common-appdata)
    4202                        (getenv-absolute-pathname "ALLUSERSAPPDATA")
    4203                        (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/")))))
     4215                       (getenv-absolute-directory "ALLUSERSAPPDATA")
     4216                       (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))
    42044217          :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
    42054218          :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
Note: See TracChangeset for help on using the changeset viewer.