From 0b6818979f4a6f25ce4c6359d502460290ec4be5 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Wed, 16 Jan 2013 20:25:36 -0500
Subject: [PATCH] 2.26.104: some more pathname munging.

---
 asdf.asd           |   2 +-
 bin/make-tarball   |  62 ++++++++++++-----------
 configuration.lisp | 122 ++++++++++++++++++++++-----------------------
 header.lisp        |   2 +-
 pathname.lisp      |  36 +++++++++----
 upgrade.lisp       |   2 +-
 version.lisp-expr  |   2 +-
 7 files changed, 122 insertions(+), 106 deletions(-)

diff --git a/asdf.asd b/asdf.asd
index 214fa899..a703a51f 100644
--- a/asdf.asd
+++ b/asdf.asd
@@ -15,7 +15,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "2.26.104" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.105" ;; to be automatically updated by bin/bump-revision
   :depends-on ()
   :components ((:module "build" :components ((:file "asdf"))))
   :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
diff --git a/bin/make-tarball b/bin/make-tarball
index 1b17aaa7..283363d5 100755
--- a/bin/make-tarball
+++ b/bin/make-tarball
@@ -13,33 +13,37 @@
 (describe (find-system :asdf))
 
 (defparameter *ad* (find-system :asdf-driver))
-(defparameter *asdf-directory* (system-source-directory *ad*))
-(defparameter *version*
-  (safe-read-first-file-form (subpathname *asdf-directory* "version.lisp-expr")))
-
-(DBG :foo *ad* *version* (asdf-version))
-
+(defparameter *asdf-dir*
+  (ensure-pathname (system-source-directory *ad*)
+                   :want-existing t :want-absolute t))
+(defun apath (x) (subpathname *asdf-dir* x))
+(defun ann (x) (native-namestring (apath x)))
+(defparameter *build-dir* (apath "build/"))
+(defparameter /build-dir/ (ann "build/"))
+(defun bpath (x) (subpathname *build-dir* x))
+(defun bnn (x) (native-namestring (bpath x)))
 (defparameter *files*
-  (append
-   (loop :for c :in (operated-components *ad*
-                                         :goal-operation 'load-op
-                                         :keep-operation 'load-op)
-         :for n = (enough-namestring (component-pathname c) *asdf-directory*)
-         :when (typep c 'cl-source-file)
-           :collect n)
-   (list "version.lisp-expr" "asdf-driver.asd")))
-
-;; make asdf:
-;;;(run-program/ (list "make" "-C" (native-namestring *asdf-directory*) "build/asdf.lisp"))
-
-#|
-if [ -d "tmp" ]; then
-    rm -r tmp
-fi
-mkdir tmp
-
-archive_file="tmp/asdf-$tag.tar.gz"
-echo "Create tmp/asdf.tar.gz with tag $tag"
-git archive $tag --prefix="asdf/" --format=tar | \
-    gzip > $archive_file
-|#
\ No newline at end of file
+  (list* "asdf-driver.asd" "version.lisp-expr"
+         (loop :for c :in (operated-components
+                           *ad* :goal-operation 'load-op
+                                :keep-operation 'load-op)
+               :for n = (enough-namestring (component-pathname c)
+                                           *asdf-directory*)
+               :when (typep c 'cl-source-file)
+                 :collect n)))
+(defparameter *version*
+  (safe-read-first-file-form (apath "version.lisp-expr")))
+(defparameter *name* (format nil "asdf-driver-~A" *version*))
+(defparameter *tarname* (strcat *name* ".tar.gz"))
+(defparameter dirname/ (strcat *name* "/"))
+(defparameter *destination*
+  (ensure-pathname (bpath dirname/)
+                   :want-directory t :want-absolute t))
+(assert (< 6 (length (pathname-directory *destination*))))
+(defparameter /destination/ (native-namestring *destination*))
+(run-program/ `("rm" "-rf" ,/destination/))
+(ensure-directory-exists *destination*)
+(run-program/ `("ln" ,@(mapcar 'ann *files*) ,/destination/))
+(run-program/ (format nil "cd ~S && tar zcf ~S ~S"
+                      ,/build-dir/, ,*tarname* ,dirname/))
+(run-program/ `("rm" "-rf" ,/destination/))
diff --git a/configuration.lisp b/configuration.lisp
index 7d2a3bd2..9eef435e 100644
--- a/configuration.lisp
+++ b/configuration.lisp
@@ -152,35 +152,34 @@ values of TAG include :source-registry and :output-translations."
       :inherit-configuration)))
 
 (defun* resolve-relative-location-component (x &key want-directory wilden)
-  (let* ((r (etypecase x
-              (pathname x)
-              (string (parse-unix-namestring
-                       x :want-directory want-directory))
-              (cons
-               (if (null (cdr x))
-                   (resolve-relative-location-component
-                    (car x) :want-directory want-directory :wilden wilden)
-                   (let* ((car (resolve-relative-location-component
-                                (car x) :want-directory t :wilden nil)))
-                     (merge-pathnames*
-                      (resolve-relative-location-component
-                       (cdr x) :want-directory want-directory :wilden wilden)
-                      car))))
-              ((eql :*/) *wild-directory*)
-              ((eql :**/) *wild-inferiors*)
-              ((eql :*.*.*) *wild-file*)
-              ((eql :implementation)
-               (parse-unix-namestring
-                (implementation-identifier) :want-directory t))
-              ((eql :implementation-type)
-               (parse-unix-namestring
-                (string-downcase (implementation-type)) :want-directory t))
-              ((eql :hostname)
-               (parse-unix-namestring (hostname) :want-directory t))))
-         (w (if (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
-                (wilden r)
-                r)))
-    (ensure-pathname w :want-relative t)))
+  (ensure-pathname
+   (etypecase x
+     (pathname x)
+     (string (parse-unix-namestring
+              x :want-directory want-directory))
+     (cons
+      (if (null (cdr x))
+          (resolve-relative-location-component
+           (car x) :want-directory want-directory :wilden wilden)
+          (let* ((car (resolve-relative-location-component
+                       (car x) :want-directory t :wilden nil)))
+            (merge-pathnames*
+             (resolve-relative-location-component
+              (cdr x) :want-directory want-directory :wilden wilden)
+             car))))
+     ((eql :*/) *wild-directory*)
+     ((eql :**/) *wild-inferiors*)
+     ((eql :*.*.*) *wild-file*)
+     ((eql :implementation)
+      (parse-unix-namestring
+       (implementation-identifier) :want-directory t))
+     ((eql :implementation-type)
+      (parse-unix-namestring
+       (string-downcase (implementation-type)) :want-directory t))
+     ((eql :hostname)
+      (parse-unix-namestring (hostname) :want-directory t)))
+  :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
+  :want-relative t))
 
 (defvar *here-directory* nil
   "This special variable is bound to the currect directory during calls to
@@ -203,39 +202,38 @@ directive.")
 (register-image-restore-hook 'compute-user-cache)
 
 (defun* resolve-absolute-location-component (x &key want-directory wilden)
-  (let* ((r (etypecase x
-              (pathname x)
-              (string
-               (let ((p #-mcl (parse-namestring x)
-                        #+mcl (probe-posix x)))
-                 #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
-                 (if want-directory (ensure-directory-pathname p) p)))
-              (cons
-               (return-from resolve-absolute-location-component
-                 (if (null (cdr x))
-                     (resolve-absolute-location-component
-                      (car x) :want-directory want-directory :wilden wilden)
-                     (merge-pathnames*
-                      (resolve-relative-location-component
-                       (cdr x) :want-directory want-directory :wilden wilden)
-                      (resolve-absolute-location-component
-                       (car x) :want-directory t :wilden nil)))))
-              ((eql :root)
-               ;; special magic! we return a relative pathname,
-               ;; but what it means to the output-translations is
-               ;; "relative to the root of the source pathname's host and device".
-               (return-from resolve-absolute-location-component
-                 (let ((p (make-pathname* :directory '(:relative))))
-                   (if wilden (wilden p) p))))
-              ((eql :home) (user-homedir))
-              ((eql :here) (resolve-absolute-location-component
-                            *here-directory* :want-directory t :wilden nil))
-              ((eql :user-cache) (resolve-absolute-location-component
-                                  *user-cache* :want-directory t :wilden nil))))
-         (w (if (and wilden (not (pathnamep x)))
-                (wilden r)
-                r)))
-    (ensure-pathname w :want-absolute t)))
+  (ensure-pathname
+   (etypecase x
+     (pathname x)
+     (string
+      (let ((p #-mcl (parse-namestring x)
+               #+mcl (probe-posix x)))
+        #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
+        (if want-directory (ensure-directory-pathname p) p)))
+     (cons
+      (return-from resolve-absolute-location-component
+        (if (null (cdr x))
+            (resolve-absolute-location-component
+             (car x) :want-directory want-directory :wilden wilden)
+            (merge-pathnames*
+             (resolve-relative-location-component
+              (cdr x) :want-directory want-directory :wilden wilden)
+             (resolve-absolute-location-component
+              (car x) :want-directory t :wilden nil)))))
+     ((eql :root)
+      ;; special magic! we return a relative pathname,
+      ;; but what it means to the output-translations is
+      ;; "relative to the root of the source pathname's host and device".
+      (return-from resolve-absolute-location-component
+        (let ((p (make-pathname* :directory '(:relative))))
+          (if wilden (wilden p) p))))
+     ((eql :home) (user-homedir))
+     ((eql :here) (resolve-absolute-location-component
+                   *here-directory* :want-directory t :wilden nil))
+     ((eql :user-cache) (resolve-absolute-location-component
+                         *user-cache* :want-directory t :wilden nil)))
+   :wilden (and wilden (not (pathnamep x)))
+   :want-absolute t))
 
 (defun* resolve-location (x &key want-directory wilden directory)
   (when directory (setf want-directory t)) ;; :directory backward compatibility, until 2014-01-16.
diff --git a/header.lisp b/header.lisp
index 8c3d680b..43410678 100644
--- a/header.lisp
+++ b/header.lisp
@@ -1,5 +1,5 @@
 ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.26.104: Another System Definition Facility.
+;;; This is ASDF 2.26.105: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
diff --git a/pathname.lisp b/pathname.lisp
index 89a5e1b2..f7526a19 100644
--- a/pathname.lisp
+++ b/pathname.lisp
@@ -931,9 +931,11 @@ Otherwise, this will be the root of some implementation-dependent filesystem hos
 
 (defun* ensure-pathname
     (pathname &key want-pathname want-existing
-              want-absolute want-relative want-directory want-file
-              want-wild want-non-wild want-truename truenamize
-              error-arguments)
+              want-absolute want-relative
+              want-logical want-physical ensure-physical
+              want-wild want-non-wild wilden
+              ensure-directory want-directory want-file
+              want-truename truenamize error-arguments)
   "Coerces its argument into a PATHNAME, and checks specified constraints.
 If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
 If the argument is a STRING, it is first converted to a pathname via PARSE-NAMESTRING.
@@ -968,30 +970,42 @@ in case you use the long variant."
           (string
            (setf pathname (parse-namestring pathname)))
           (pathname))
+        (when want-logical
+          (unless (typep pathname 'logical-pathname)
+            (err want-logical "Expected a logical pathname, got")))
+        (when want-physical
+          (unless (physical-pathname-p pathname)
+            (err want-physical "Expected a physical pathname, got")))
+        (when ensure-physical
+          (setf pathname (translate-logical-pathname pathname)))
         (when want-absolute
           (unless (absolute-pathname-p pathname)
             (err want-absolute "Expected an absolute pathname, got")))
         (when want-relative
           (when (absolute-pathname-p pathname)
             (err want-relative "Expected a relative pathname, got")))
-        (when want-directory
-          (unless (directory-pathname-p pathname)
-            (err want-directory "Expected a directory pathname, got")))
-        (when want-file
-          (unless (pathname-name pathname)
-            (err want-file "Expected a file pathname, got")))
         (when want-wild
           (unless (wild-pathname-p pathname)
             (err want-wild "Expected a wildcard pathname, got")))
         (when (or want-non-wild want-existing)
           (when (wild-pathname-p pathname)
             (err want-non-wild "Expected a non-wildcard pathname, got")))
+        (when (and wilden (not (wild-pathname-p pathname)))
+          (setf pathname (wilden pathname)))
+        (when ensure-directory
+          (setf pathname (ensure-directory-pathname pathname)))
+        (when want-directory
+          (unless (directory-pathname-p pathname)
+            (err want-directory "Expected a directory pathname, got")))
+        (when want-file
+          (unless (pathname-name pathname)
+            (err want-file "Expected a file pathname, got")))
         (when want-existing
           (let ((existing (probe-file* pathname)))
             (if existing
-                (err want-existing "Expected an existing pathname, got")
                 (when (or want-truename truenamize)
-                  (return existing)))))
+                  (return existing))
+                (err want-existing "Expected an existing pathname, got"))))
         (when want-truename
           (let ((truename (truename* pathname)))
             (if truename
diff --git a/upgrade.lisp b/upgrade.lisp
index 291ad472..60b35c50 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -45,7 +45,7 @@
          ;; "2.345.6" would be a development version in the official upstream
          ;; "2.345.0.7" would be your seventh local modification of official release 2.345
          ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
-         (asdf-version "2.26.104")
+         (asdf-version "2.26.105")
          (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
diff --git a/version.lisp-expr b/version.lisp-expr
index 6c4ed9ef..e1a03a91 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -1 +1 @@
-"2.26.104"
+"2.26.105"
-- 
GitLab