From 4b1cea29891e45ee50c4114dd7b7c17b78cfc7fc Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Wed, 9 Jan 2013 00:32:11 -0500
Subject: [PATCH] 2.26.63: more pathname hell.

New pathname functions to work around more logical-pathname issues.
See discussion with rpgoldman on asdf-devel, and see CCL ticket:953.
Also, tweak build to reflect recent refactoring of asdf.
WIP of define-package work needed for clean upgrade (still broken).
---
 Makefile                 | 20 ++++-----
 asdf.asd                 |  2 +-
 bin/bump-version         |  2 +-
 bundle.lisp              |  2 +-
 component.lisp           |  2 +-
 generate-asdf.asd        |  2 +-
 header.lisp              |  2 +-
 os.lisp                  |  4 +-
 package.lisp             | 33 +++++++++++----
 pathname.lisp            | 90 ++++++++++++++++++++++++++++++----------
 plan.lisp                | 19 ++++-----
 source-registry.lisp     |  2 +-
 test/script-support.lisp |  4 +-
 upgrade.lisp             |  2 +-
 utility.lisp             |  6 +--
 15 files changed, 129 insertions(+), 63 deletions(-)

diff --git a/Makefile b/Makefile
index 426e7468b..ba13d1572 100644
--- a/Makefile
+++ b/Makefile
@@ -18,19 +18,19 @@ export CL_SOURCE_REGISTRY := (:source-registry (:tree "${sourceDirectory}") :ign
 
 lisp ?= sbcl
 
+ABCL ?= abcl
+ALLEGRO ?= alisp
+ALLEGROMODERN ?= mlisp
 CCL ?= ccl
 CLISP ?= clisp
-SBCL ?= sbcl
+CMUCL ?= cmucl
 ECL ?= ecl
+GCL ?= gcl
+LISPWORKS ?= lispworks
 MKCL ?= mkcl
-CMUCL ?= cmucl
-ABCL ?= abcl
-XCL ?= xcl
+SBCL ?= sbcl
 SCL ?= scl
-ALLEGRO ?= alisp
-ALLEGROMODERN ?= mlisp
-LISPWORKS ?= lispworks
-GCL ?= gcl
+XCL ?= xcl
 
 # website, tag, install
 
@@ -53,7 +53,7 @@ archive-copy: archive tmp/asdf.lisp
 
 tmp/asdf.lisp: $(wildcard *.lisp)
 	mkdir -p tmp
-	cat header.lisp package.lisp implementation.lisp utility.lisp upgrade.lisp pathname.lisp os.lisp component.lisp system.lisp find-system.lisp find-component.lisp lisp-build.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp user.lisp footer.lisp > $@
+	cat header.lisp package.lisp implementation.lisp utility.lisp upgrade.lisp pathname.lisp os.lisp component.lisp system.lisp find-system.lisp find-component.lisp lisp-build.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp > $@
 
 push:
 	git status
@@ -146,7 +146,7 @@ test-upgrade:
 test-forward-references: tmp/asdf.lisp
 	${SBCL} --noinform --no-userinit --no-sysinit --load tmp/asdf.lisp --load test/script-support.lisp --eval '(asdf-test::exit-lisp 0)' 2>&1 | cmp - /dev/null
 
-test-lisp:
+test-lisp: tmp/asdf.lisp
 	@cd test; ${MAKE} clean;./run-tests.sh ${lisp} ${test-glob}
 
 test: test-lisp test-forward-references doc
diff --git a/asdf.asd b/asdf.asd
index 9f246d459..c49b91329 100644
--- a/asdf.asd
+++ b/asdf.asd
@@ -14,7 +14,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "2.26.62" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.63" ;; to be automatically updated by bin/bump-revision
   :depends-on ()
   :components
   ((:file "asdf")))
diff --git a/bin/bump-version b/bin/bump-version
index 9ac838660..cc1a578dd 100755
--- a/bin/bump-version
+++ b/bin/bump-version
@@ -7,7 +7,7 @@ PROG="$0"
 ASDFDIR="$(cd $(dirname $PROG)/.. ; /bin/pwd)" ## readlink -f doesn't work on BSD
 
 if [ -z "$NEWVER" ] ; then
-  OLDVER="$(grep '         (asdf-version "' ${ASDFDIR}/header.lisp | cut -d\" -f2)"
+  OLDVER="$(grep '         (asdf-version "' ${ASDFDIR}/upgrade.lisp | cut -d\" -f2)"
   NEWVER="$(echo $OLDVER | perl -npe 's/([0-9].[0-9]+)(\.([0-9]+))?/"${1}.".($3+1)/e')"
 fi
 echo "Setting ASDF version to $NEWVER"
diff --git a/bundle.lisp b/bundle.lisp
index ed61f7804..623a3f54c 100644
--- a/bundle.lisp
+++ b/bundle.lisp
@@ -244,7 +244,7 @@
          (files (and system (output-files operation system))))
     (if (or move-here (and (null move-here-p)
                            (member operation-name '(:program :binary))))
-        (loop :with dest-path = (truename (ensure-directories-exist move-here-path))
+        (loop :with dest-path = (truename* (ensure-directories-exist move-here-path))
               :for f :in files
               :for new-f = (make-pathname :name (pathname-name f)
                                 :type (pathname-type f)
diff --git a/component.lisp b/component.lisp
index bc1a90dbb..2f9e062b0 100644
--- a/component.lisp
+++ b/component.lisp
@@ -184,7 +184,7 @@ hopefully, if done consistently, that won't affect program behavior too much.")
   "Hook for an extension to define a function to automatically detect a file's encoding")
 
 (defun* detect-encoding (pathname)
-  (if (and pathname (probe-file pathname))
+  (if (and pathname (not (directory-pathname-p pathname)) (probe-file pathname))
       (funcall *encoding-detection-hook* pathname)
       *default-encoding*))
 
diff --git a/generate-asdf.asd b/generate-asdf.asd
index c165825ce..87b78efeb 100644
--- a/generate-asdf.asd
+++ b/generate-asdf.asd
@@ -7,7 +7,7 @@
   :class :concatenated-source-system
   ;; :include-dependencies t
   :translate-output-p nil
-  :output-file "tmp/asdf.lisp"
+  :concatenated-source-file "tmp/generated-asdf.lisp"
 #|
   :depends-on (:asdf-header
                :asdf-package
diff --git a/header.lisp b/header.lisp
index ccd50ff86..4c46d1051 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.62: Another System Definition Facility.
+;;; This is ASDF 2.26.63: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
diff --git a/os.lisp b/os.lisp
index a9664f641..ae621ca83 100644
--- a/os.lisp
+++ b/os.lisp
@@ -222,12 +222,12 @@ using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver
 (defun* lisp-implementation-directory (&key truename)
   (let ((dir
           (ignore-errors
-           #+clozure (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))
+           #+clozure #p"ccl:"
            #+(or ecl mkcl) #p"SYS:"
            #+sbcl (aif (find-symbol* :sbcl-homedir-pathname :sb-int)
                        (funcall it)
                        (getenv-pathname "SBCL_HOME" :want-directory t)))))
     (if (and dir truename)
-        (let ((*default-pathname-defaults* #p"")) (truename dir))
+        (truename* dir)
         dir)))
 
diff --git a/package.lisp b/package.lisp
index 06f7a2ae0..40614aaae 100644
--- a/package.lisp
+++ b/package.lisp
@@ -124,9 +124,10 @@ when the symbol is not found."
       (loop :for x :in newly-exported-symbols :do
         (export (intern* x package)))))
   (defun ensure-package (name &key
-                                nicknames use reuse unintern
-                                shadow export fmakunbound fmakunbound-setf)
-    reuse
+                                nicknames use intern unintern shadow export
+                                import-from shadowing-import-from
+                                recycle mix fmakunbound fmakunbound-setf)
+    recycle mix intern import-from shadowing-import-from
     (let* ((p (ensure-package-exists name nicknames use)))
       #-ecl (ensure-package-fmakunbound p fmakunbound) #+ecl fmakunbound ;; do it later on ECL
       #-ecl (ensure-package-fmakunbound-setf p fmakunbound-setf) #+ecl fmakunbound-setf
@@ -134,8 +135,6 @@ when the symbol is not found."
       (ensure-package-shadow p shadow)
                (ensure-package-export p export)
                p))
-  (defun do-define-package (package clauses)
-    package clauses
 #|
   (let ((h (make-hash-table :test 'equal)))
     (labels ((ensure-imported (n)
@@ -163,8 +162,28 @@ when the symbol is not found."
          ,@clauses
          (:export ,@(loop :for s :being :the :hash-keys :of h :collect s)))))))
 |#
-    ))
+  (defun parse-define-package-clauses (clauses)
+    (loop :for (kw . args) :in clauses
+      :when (eq kw :nicknames) :append args :into nicknames :else
+      :when (eq kw :use) :append args :into use :else
+      :when (eq kw :shadow) :append args :into shadow :else
+      :when (eq kw :export) :append args :into export :else
+      :when (eq kw :intern) :append args :into intern :else
+      :when (eq kw :import-from) :collect args :into import-from :else
+      :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
+      :when (eq kw :recycle) :append args :into recycle :else
+      :when (eq kw :mix) :append args :into mix :else
+      :when (eq kw :unintern) :append args :into unintern :else
+      :when (eq kw :fmakunbound) :append args :into fmakunbound :else
+      :when (eq kw :fmakunbound-setf) :append args :into fmakunbound-setf :else
+        :do (error "unrecognized define-package keyword ~S" kw)
+      :finally (return `(:nicknames ,nicknames :use ,use
+                         :shadow ,shadow :export ,export :intern ,intern
+                         :import-from ,import-from :shadowing-import-from ,shadowing-import-from
+                         :recycle ,recycle :mix ,mix :unintern ,unintern
+                         :fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf))))
+);eval-when
 
 (defmacro define-package (package &rest clauses)
   `(eval-when (:compile-toplevel :load-toplevel :execute)
-     (do-define-package ',package ',clauses)))
+     (apply 'ensure-package ',package ',(parse-define-package-clauses clauses))))
diff --git a/pathname.lisp b/pathname.lisp
index 72acca946..01bdf0d59 100644
--- a/pathname.lisp
+++ b/pathname.lisp
@@ -23,10 +23,12 @@
    ;; Wildcard pathnames
    #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden
    ;; Pathname host and its root
-   #:pathname-root #:directory-sperator-for-host
+   #:pathname-root #:directory-separator-for-host
    #:directorize-pathname-host-device
+   ;; defaults
+   #:nil-pathname #:with-pathname-defaults
    ;; probe filesystem
-   #:probe-file* #:safe-file-write-date
+   #:truename* #:probe-file* #:safe-file-write-date
    #:subdirectories #:directory-files #:directory*
    #:filter-logical-directory-results #:collect-sub*directories
    ;; Simple filesystem operations
@@ -39,7 +41,9 @@
    #:add-pathname-suffix #:tmpize-pathname
    #:call-with-staging-pathname #:with-staging-pathname
    ;; basic pathnames
-   #:load-pathname #:default-directory
+   #:load-pathname #:default-directory #:nil-pathname
+   ;; physical pathnames
+   #:physical-pathname-p #:sane-physical-pathname
    ;; Windows shortcut support
    #:read-null-terminated-string #:read-little-endian
    #:parse-file-location-info #:parse-windows-shortcut))
@@ -106,7 +110,7 @@ Defaults to T.")
               :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
 
 (defun* make-pathname* (&rest keys &key (directory nil directoryp)
-                              host device name type version defaults)
+                              host device name type version defaults #+scl &allow-other-keys)
   (declare (ignore host device name type version defaults))
   (apply 'make-pathname
          (append (when directoryp
@@ -241,24 +245,36 @@ actually-existing directory."
 
 
 ;;; Probing the filesystem
+(defun* nil-pathname (&optional (defaults *default-pathname-defaults*))
+  (make-pathname :directory nil :name nil :type nil :version nil :device nil :host nil
+                 :defaults defaults)) ;; shouldn't matter
+
+(defmacro with-pathname-defaults ((&optional defaults) &body body)
+  `(let ((*default-pathname-defaults* ,(or defaults (nil-pathname)))) ,@body))
+
+(defun truename* (p)
+  ;; avoids both logical-pathname merging and physical resolution issues
+  (ignore-errors (with-pathname-defaults () (truename p))))
+
 (defun* probe-file* (p)
   "when given a pathname P, probes the filesystem for a file or directory
 with given pathname and if it exists return its truename."
-  (etypecase p
-    (null nil)
-    (string (probe-file* (parse-namestring p)))
-    (pathname (unless (wild-pathname-p p)
-                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl)
-                      '(probe-file p)
-                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
-                                   `(ignore-errors (,it p)))
-                      #+gcl<2.7
-                      '(or (probe-file p)
-                        (and (directory-pathname-p p)
-                         (ignore-errors
-                          (ensure-directory-pathname
-                           (truename (subpathname (ensure-directory-pathname p) "."))))))
-                      '(ignore-errors (truename p)))))))
+  (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
+    (etypecase p
+      (null nil)
+      (string (probe-file* (parse-namestring p)))
+      (pathname (unless (wild-pathname-p p)
+                  #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl)
+                        '(probe-file p)
+                        #+clisp (aif (find-symbol* '#:probe-pathname :ext)
+                                     `(ignore-errors (,it p)))
+                        #+gcl<2.7
+                        '(or (probe-file p)
+                          (and (directory-pathname-p p)
+                           (ignore-errors
+                            (ensure-directory-pathname
+                             (truename* (subpathname (ensure-directory-pathname p) "."))))))
+                        '(truename* p)))))))
 
 (defun* safe-file-write-date (pathname)
   ;; If FILE-WRITE-DATE returns NIL, it's possible that
@@ -293,8 +309,8 @@ with given pathname and if it exists return its truename."
                      (let* ((u (ignore-errors (funcall merger f))))
                        ;; The first u avoids a cumbersome (truename u) error.
                        ;; At this point f should already be a truename,
-                       ;; but isn't quite in CLISP, for doesn't have :version :newest
-                       (and u (equal (ignore-errors (truename u)) (truename f)) u)))
+                       ;; but isn't quite in CLISP, for it doesn't have :version :newest
+                       (and u (equal (truename* u) (truename* f)) u)))
         :when p :collect p)
       entries))
 
@@ -489,6 +505,13 @@ Host, device and version components are taken from DEFAULTS."
                   ;; scheme-specific parts: port username password, not others:
                   . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
 
+(defun* pathname-host-pathname (pathname)
+  (make-pathname :directory nil
+                 :name nil :type nil :version nil :device nil
+                 :defaults pathname ;; host device, and on scl, *some*
+                  ;; scheme-specific parts: port username password, not others:
+                  . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
+
 #-scl
 (defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
   (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
@@ -547,7 +570,7 @@ Host, device and version components are taken from DEFAULTS."
       (let ((found (probe-file* p)))
         (when found (return found)))
       (unless (absolute-pathname-p p)
-        (let ((true-defaults (ignore-errors (truename defaults))))
+        (let ((true-defaults (truename* defaults)))
           (when true-defaults
             (setf p (merge-pathnames pathname true-defaults)))))
       (unless (absolute-pathname-p p) (return p))
@@ -680,6 +703,29 @@ For the latter case, we ought pick random suffix and atomically open it."
 (defun* default-directory ()
   (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
 
+(defun* physical-pathname-p (x)
+  (and (pathnamep x) (not (typep x 'logical-pathname))))
+
+(defun* sane-physical-pathname (&key (defaults *default-pathname-defaults*)
+                                     fallback (keep t) must-exist)
+  (flet ((sanitize (x)
+           (setf x (and x (ignore-errors (translate-logical-pathname x))))
+           (when (pathnamep x)
+             (setf x
+                   (ecase keep
+                     ((t) x)
+                     ((:directory) (pathname-directory-pathname x))
+                     ((:root) (pathname-root x))
+                     ((:host) (pathname-host-pathname x))
+                     ((nil) (nil-pathname x))))
+             (when must-exist ;; CCL's probe-file will choke if d-p-d is logical
+               (setf x (and (probe-file* x) x)))
+             (and (physical-pathname-p x) x))))
+    (or (sanitize defaults)
+        (when fallback (sanitize (ignore-errors (user-homedir-pathname))))
+        (error "Could not find a sanitize ~S ~:[~;or a fallback ~] into a physical pathname"
+               defaults fallback))))
+
 ;;;; -----------------------------------------------------------------
 ;;;; Windows shortcut support.  Based on:
 ;;;;
diff --git a/plan.lisp b/plan.lisp
index c5bd9ccef..11581ba7d 100644
--- a/plan.lisp
+++ b/plan.lisp
@@ -219,16 +219,15 @@ the action of OPERATION on COMPONENT in the PLAN"))
   (with-accessors ((action-set plan-visiting-action-set)
                    (action-list plan-visiting-action-list)) plan
     (let ((action (cons operation component)))
-      (aif (gethash action action-set)
-           (error 'circular-dependency :actions
-                  (member action (reverse action-list) :test 'equal))
-           (progn
-             (setf (gethash action action-set) t)
-             (push action action-list)
-             (unwind-protect
-                  (funcall fun)
-               (pop action-list)
-               (setf (gethash action action-set) nil)))))))
+      (when (gethash action action-set)
+        (error 'circular-dependency :actions
+               (member action (reverse action-list) :test 'equal)))
+      (setf (gethash action action-set) t)
+      (push action action-list)
+      (unwind-protect
+           (funcall fun)
+        (pop action-list)
+        (setf (gethash action action-set) nil)))))
 
 
 ;;;; Actual traversal: traverse-action
diff --git a/source-registry.lisp b/source-registry.lisp
index 928384b89..6b7a4f7b3 100644
--- a/source-registry.lisp
+++ b/source-registry.lisp
@@ -247,7 +247,7 @@ with a different configuration, so the configuration would be re-read then."
 (defun* flatten-source-registry (&optional parameter)
   (remove-duplicates
    (while-collecting (collect)
-     (let ((*default-pathname-defaults* (default-directory)))
+     (with-pathname-defaults () ;; be location-independent
        (inherit-source-registry
         `(wrapping-source-registry
           ,parameter
diff --git a/test/script-support.lisp b/test/script-support.lisp
index 42b01326c..f3d04415a 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -31,7 +31,9 @@
     (make-pathname :directory '(#-gcl :relative #-gcl :back #+gcl :parent) :defaults *test-directory*)
     *test-directory*)))
 (defparameter *asdf-lisp*
-  (make-pathname :name "asdf" :type "lisp" :defaults *asdf-directory*))
+   (merge-pathnames
+    (make-pathname :directory '(#-gcl :relative "tmp") :name "asdf" :type "lisp" :defaults *asdf-directory*)
+    *asdf-directory*))
 (defparameter *asdf-fasl*
   (compile-file-pathname
    (let ((impl (string-downcase
diff --git a/upgrade.lisp b/upgrade.lisp
index 22feaa7b9..a8fcec8c5 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -23,7 +23,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.62")
+         (asdf-version "2.26.63")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
diff --git a/utility.lisp b/utility.lisp
index 1a3902521..fdce626d4 100644
--- a/utility.lisp
+++ b/utility.lisp
@@ -152,7 +152,7 @@ starting the separation from the end, e.g. when called with arguments
 ;;; Functions
 (defun* ensure-function (fun &key (package :asdf))
   (etypecase fun
-    ((or boolean keyword character number) (constantly fun))
+    ((or boolean keyword character number pathname) (constantly fun))
     ((or function symbol) fun)
     (cons (eval `(function ,fun)))
     (string (eval `(function ,(with-standard-io-syntax
@@ -186,8 +186,8 @@ NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
 If major versions differ, it's not compatible.
 If they are equal, then any later version is compatible,
 with later being determined by a lexicographical comparison of minor numbers."
-  (let ((x (parse-version version 'warn))
-        (y (parse-version base-version 'warn)))
+  (let ((x (parse-version provided-version 'warn))
+        (y (parse-version required-version 'warn)))
     (labels ((bigger (x y)
                (cond ((not y) t)
                      ((not x) nil)
-- 
GitLab