From 056f33a907f9ae3ffe5e0ae6aaa5f3b6f5bc863a Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Wed, 9 Jan 2013 07:43:10 -0500
Subject: [PATCH] 2.26.64: checkpointing progress with define-package

---
 asdf.asd                 |   2 +-
 generate-asdf.asd        |  16 +-
 header.lisp              |   2 +-
 package.lisp             | 334 ++++++++++++++++++++++++---------------
 pathname.lisp            |   8 +-
 test/script-support.lisp |   4 +-
 upgrade.lisp             |   2 +-
 7 files changed, 228 insertions(+), 140 deletions(-)

diff --git a/asdf.asd b/asdf.asd
index c49b91329..87f8f017f 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.63" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.64" ;; to be automatically updated by bin/bump-revision
   :depends-on ()
   :components
   ((:file "asdf")))
diff --git a/generate-asdf.asd b/generate-asdf.asd
index 87b78efeb..494e51f0f 100644
--- a/generate-asdf.asd
+++ b/generate-asdf.asd
@@ -26,24 +26,26 @@
   :components
   ((:file "header")
    (:module
-    "code" :pathname "" :components
+    "utils" :pathname "" :components
     ((:file "package")
      (:file "implementation" :depends-on ("package"))
      (:file "utility" :depends-on ("implementation"))
      (:file "pathname" :depends-on ("utility"))
-     (:file "os" :depends-on ("pathname"))
-     (:file "upgrade" :depends-on ("utility"))
-     (:file "component" :depends-on ("pathname"))
+     (:file "os" :depends-on ("pathname"))))
+   (:module
+    "code" :pathname "" :components
+     (:file "upgrade")
+     (:file "component")
      (:file "system" :depends-on ("component"))
      (:file "find-system" :depends-on ("system"))
      (:file "find-component" :depends-on ("find-system"))
-     (:file "lisp-build" :depends-on ("pathname"))
-     (:file "operation" :depends-on ("utility"))
+     (:file "lisp-build")
+     (:file "operation")
      (:file "action" :depends-on ("find-component" "operation"))
      (:file "lisp-action" :depends-on ("action" "lisp-build"))
      (:file "plan" :depends-on ("action"))
      (:file "operate" :depends-on ("plan"))
-     (:file "configuration" :depends-on ("pathname"))
+     (:file "configuration")
      (:file "output-translations" :depends-on ("configuration" "operate"))
      (:file "source-registry" :depends-on ("configuration" "find-system"))
      (:file "backward-internals" :depends-on ("action" "operate"))
diff --git a/header.lisp b/header.lisp
index 4c46d1051..75cf1595a 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.63: Another System Definition Facility.
+;;; This is ASDF 2.26.64: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
diff --git a/package.lisp b/package.lisp
index 40614aaae..fd863d476 100644
--- a/package.lisp
+++ b/package.lisp
@@ -13,7 +13,9 @@
 (defpackage :asdf/package
   (:use :common-lisp)
   (:export
-   #:find-symbol* #:define-package))
+   #:find-symbol* #:present-symbol-p #:present-symbols
+   #:intern* #:remove-symbol #:unlink-package #:ensure-package
+   #:define-package))
 
 (in-package :asdf/package)
 
@@ -38,152 +40,234 @@ when the symbol is not found."
   (defun intern* (name package)
     (intern (string name) package))
   (defun remove-symbol (symbol package)
-    (let ((sym (find-symbol* symbol package)))
+    (let ((sym (find-symbol* symbol package nil)))
       (when sym
         #-cormanlisp (unexport sym package)
         (unintern sym package)
         sym)))
   (defun present-symbol-p (symbol package)
-    (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
+    (member (nth-value 1 (find-symbol* symbol package nil)) '(:internal :external)))
   (defun present-symbols (package)
     ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
-    (let (l)
-      (do-symbols (s package)
-        (when (present-symbol-p s package) (push s l)))
-      (reverse l)))
-  (defun ensure-package-use (package use)
-    (dolist (used (package-use-list package))
-      (unless (member (package-name used) use :test 'string=)
-        (unuse-package used)
-        (do-external-symbols (sym used)
-          (when (eq sym (find-symbol* sym package))
-            (remove-symbol sym package)))))
-    (dolist (used (reverse use))
-      (do-external-symbols (sym used)
-        (unless (eq sym (find-symbol* sym package))
-          (remove-symbol sym package)))
-      (use-package used package)))
-  (defun ensure-package-unintern (package symbols)
-    (loop :with packages = (list-all-packages)
-          :for sym :in symbols
-          :for removed = (remove-symbol sym package)
-          :when removed :do
-            (loop :for p :in packages :do
-              (when (eq removed (find-symbol* sym p))
-                (unintern removed p)))))
-  (defun unlink-package (package)
-    (let ((u (find-package package)))
-      (when u
-        (ensure-package-unintern u (present-symbols u))
-        (loop :for p :in (package-used-by-list u) :do
-          (unuse-package u p))
-        (delete-package u))))
-  (defun ensure-package-exists (name nicknames use)
-    (let ((previous
-            (remove-duplicates
-             (mapcar #'find-package (cons name nicknames))
-             :from-end t)))
-      ;; do away with packages with conflicting (nick)names
-      (map () #'unlink-package (cdr previous))
-      ;; reuse previous package with same name
-      (let ((p (car previous)))
-        (cond
-          (p
-           (rename-package p name nicknames)
-           (ensure-package-use p use)
-           p)
-          (t
-           (make-package name :nicknames nicknames :use use))))))
-  (defun ensure-package-shadow (package symbols)
-    (shadow symbols package))
+    (let (l) (do-symbols (s package) (when (present-symbol-p s package) (push s l))) (reverse l))))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun soft-upgrade-p (upgrade)
+    (ecase upgrade ((:soft nil) t) (:hard nil)))
+  (defun check-packages-exist (package-names)
+    (remove-duplicates
+     (loop :for n :in package-names
+           :for p = (find-package n)
+           :when p :collect p :else :do (error "Package ~A does not exist" n))
+     :from-end t))
+  (defun ensure-package-unused (package)
+    (loop :for p :in (package-used-by-list package) :do
+      (unuse-package package p)))
+  (defun ensure-package-deleted (package) ;; &key upgrade
+    (let ((p (find-package package)))
+      (when p
+        ;;(unless (soft-upgrade-p upgrade) (ensure-package-unintern p (present-symbols u)))
+        (ensure-package-unused p)
+        (delete-package package))))
   (defun ensure-package-fmakunbound (package symbols)
     (loop :for name :in symbols
-          :for sym = (find-symbol* name package)
+          :for sym = (find-symbol* name package nil)
           :when sym :do (fmakunbound sym)))
   (defun ensure-package-fmakunbound-setf (package symbols)
     (loop :for name :in symbols
-          :for sym = (find-symbol* name package)
+          :for sym = (find-symbol* name package nil)
           :when sym :do #-gcl (fmakunbound `(setf ,sym))))
-  (defun ensure-package-export (package export)
-    (let ((formerly-exported-symbols nil)
-          (bothly-exported-symbols nil)
-          (newly-exported-symbols nil))
-      (do-external-symbols (sym package)
-        (if (member sym export :test 'string-equal)
-            (push sym bothly-exported-symbols)
-            (push sym formerly-exported-symbols)))
-      (loop :for sym :in export :do
-        (unless (member sym bothly-exported-symbols :test 'equal)
-          (push sym newly-exported-symbols)))
-      (loop :for user :in (package-used-by-list package)
-            :for shadowing = (package-shadowing-symbols user) :do
-              (loop :for new :in newly-exported-symbols
-                    :for old = (find-symbol* new user)
-                    :when (and old (not (member old shadowing)))
-                      :do (unintern old user)))
-      (loop :for x :in newly-exported-symbols :do
-        (export (intern* x package)))))
+  (defun ensure-package-unintern (package unintern &key table (users (list-all-packages)))
+    (loop :for u :in unintern
+          :for name = (string u)
+          :for removed = (remove-symbol name package) :do
+          (when removed
+            (loop :for p :in users :do
+              (when (eq removed (find-symbol name p))
+                (unintern removed p)))))))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun recycle-symbol (name recycle)
+    (loop :for r :in recycle
+          :for s = (find-symbol* name r nil)
+          :when s :do (values s r)))
   (defun ensure-package (name &key
-                                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
-      (ensure-package-unintern p unintern)
-      (ensure-package-shadow p shadow)
-               (ensure-package-export p export)
-               p))
-#|
-  (let ((h (make-hash-table :test 'equal)))
-    (labels ((ensure-imported (n)
-               (let* ((s (string n))
-                      (x (gethash s h)))
-                 (unless x (setf (gethash s h) t))
-                 x))
-             (import-from (package)
-               (loop :for s :being :each :external-symbol :in package
-                 :for n = (symbol-name s)
-                 :unless (ensure-imported n)
-                 :collect n)))
-      ;; First, mark the symbols explicitly imported by the user
-      (loop :for (kw . ()) :in clauses
-            :when (member kw '(:import-from :shadowing-import-from)) :do
-              (map () #'ensure-imported (cddr clauses)))
-      `(eval-when (:compile-toplevel :load-toplevel :execute)
-         (ensure-package
-          ',name :nicknames ',nicknames :use ',use :export ',export
-                 :shadow ',shadow :unintern ',unintern
-                 :fmakunbound ',fmakunbound :fmakunbound-setf ',fmakunbound-setf)))
-      `(defpackage ,package (:use)
-         ,@(loop :for p :in mixed-packages
-             :collect `(:import-from ,p ,@(import-from p)))
-         ,@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
+                                upgrade
+                                nicknames documentation use
+                                shadow shadowing-import-from
+                                import-from export intern
+                                recycle mix reexport
+                                unintern fmakunbound fmakunbound-setf)
+    (let* ((nicknames (mapcar #'string nicknames))
+           (use (check-packages-exist use))
+           (shadow (mapcar #'string shadow))
+           (shadowing-import-from (loop :for sif :in shadowing-import-from
+                                        :collect (mapcar #'string sif)))
+           (import-from (loop :for if :in import-from
+                              :collect (mapcar #'string if)))
+           (export (mapcar #'string export))
+           (recycle (remove nil (mapcar #'find-package recycle)))
+           (mix (check-packages-exist mix))
+           (shadowed (make-hash-table :test 'equal))
+           (inherited (make-hash-table :test 'equal))
+           (imported (make-hash-table :test 'equal))
+           (exported (make-hash-table :test 'equal))
+           (previous (remove-duplicates
+                      (mapcar #'find-package (cons name nicknames))
+                      :from-end t))
+           (discarded (cdr previous))
+           (package (or (first previous) (make-package name :nicknames nicknames))))
+      (setf (documentation package t) documentation)
+      (assert (soft-upgrade-p upgrade))
+      (ensure-package-unused package)
+      (map () #'ensure-package-deleted discarded)
+      (rename-package package name nicknames)
+      (dolist (name unintern) (remove-symbol name package))
+      ;;; Compute the desired state of the package
+      (loop :for sym :in shadow :for name = (string sym) :do
+        (setf (gethash name shadowed) t)
+        (multiple-value-bind (recycled previous) (recycle-symbol name recycle)
+          (cond
+            ((or (not previous) (not (member (symbol-package recycle) recycle)))
+             (ecase (nth-value 1 (find-symbol* name package nil))
+               ((nil :inherited) (shadow name package))
+               ((:internal :external) (shadowing-import (make-symbol name) package))))
+            ((eq previous package) (shadow recycled package))
+            (t (unintern recycled previous) (shadowing-import recycled package)))))
+      (labels
+          ((ensure-shadowing-import (sym p)
+             (let* ((name (string sym))
+                    (i (find-symbol* name p)))
+               (cond
+                 ((gethash name shadowed)
+                  (unless (eq i (gethash name imported))
+                    (error "Conflicting shadowings for ~A" name)))
+                 (t
+                    (setf (gethash name shadowed) t)
+                    (setf (gethash name imported) i)
+                    (shadowing-import package)))))
+           (ensure-import (sym p)
+             (let* ((name (string sym))
+                    (i (find-symbol* name p)))
+               (multiple-value-bind (ii ip) (gethash name imported)
+                 (cond
+                   (ip
+                    (unless (eq i ii)
+                      (error "Can't import ~S from both ~S and ~S"
+                             name (package-name (symbol-package ii)) (package-name p))))
+                   ((gethash name shadowed)
+                    (error "Can't both shadow ~S and import it from ~S" name (package-name p)))
+                   (t
+                    (multiple-value-bind (x xp) (find-symbol name package)
+                      (when (and xp (not (eq i x)))
+                        (unintern x package))
+                      (import i package)))))))
+           (ensure-mix (sym p)
+             (let* ((name (string sym))
+                    (i (find-symbol* name p)))
+               (unless (or (gethash name shadowed) (nth-value 1 (gethash name imported)))
+                 (multiple-value-bind (in inp) (gethash name inherited)
+                   (cond
+                     ((eq i in))
+                     (inp
+                      (remhash name inherited)
+                      (ensure-shadowing-import name (symbol-package in)))
+                     (t
+                      (ensure-inherited sym p)))))))
+           (ensure-inherited (sym p)
+             (let* ((name (string sym))
+                    (i (find-symbol* name p)))
+               (multiple-value-bind (in inp) (gethash name inherited)
+                 (multiple-value-bind (im imp) (gethash name imported)
+                   (cond
+                     (inp
+                      (unless (eq i in)
+                        (error "Can't inherit ~S from ~S, it is inherited from ~S"
+                               name (package-name p) (package-name (symbol-package in)))))
+                     (imp
+                      (unless (eq i im)
+                        (error "Can't inherit ~S from ~S, it is imported from ~S"
+                               name (package-name p) (package-name (symbol-package im)))))
+                     ((gethash name shadowed)
+                      (error "Can't inherit ~S from ~S, it is shadowed" name (package-name p)))
+                     (t
+                      (multiple-value-bind (x xp) (find-symbol name package)
+                        (when xp
+                          (unintern x package)))))))))
+           (ensure-registered-symbol (sym)
+             (let ((name (string sym)))
+               (unless (or (gethash name shadowed)
+                           (nth-value 1 (gethash name imported))
+                           (nth-value 1 (gethash name inherited)))
+                 (multiple-value-bind (recycled previous) (recycle-symbol name recycle)
+                   (cond
+                       ((or (not previous) (not (member (symbol-package recycle) recycle)))
+                        (unintern sym package))
+                       ((eq previous package))
+                       (t (unintern recycled previous) (import recycled package))))))))
+        (loop :for (p . syms) :in shadowing-import-from :do
+          (dolist (sym syms) (ensure-shadowing-import sym p)))
+        (loop :for p :in mix :do
+          (do-external-symbols (sym p) (ensure-mix sym p)))
+        (loop :for (p . syms) :in import-from :do
+          (dolist (sym syms) (ensure-import sym p)))
+        (loop :for p :in use :do
+          (do-external-symbols (sym p) (ensure-inherited sym p)))
+        (loop :for p :in use :do (use-package p package))
+        (dolist (sym intern) (intern* sym package))
+        (do-symbols (sym package)
+          (ensure-registered-symbol sym))
+        (loop :for p :in reexport :do
+        (do-external-symbols (sym p)
+          (let ((name (string sym)))
+            (export (find-symbol* name package) package) (setf (gethash name exported) t))))
+        (dolist (sym export) (export sym package) (setf (gethash sym exported) t))
+        (do-external-symbols (sym package) (unless (gethash sym exported) (unexport sym)))
+        ;; do away with packages with conflicting (nick)names
+        ;; note from ASDF 2.26: ECL might not be liking an early fmakunbound (below #-ecl'ed)
+        (ensure-package-fmakunbound package fmakunbound)
+        (ensure-package-fmakunbound-setf package fmakunbound-setf)
+        package))))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun parse-define-package-clauses (package clauses)
+    (loop
+      :with use-p = nil :with recycle-p = nil
+      :with documentation = nil :with upgrade = nil
+      :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 :documentation)
+        :do (cond
+              (documentation (error "define-package: can't define documentation twice"))
+              ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
+              (t (setf documentation (car args)))) :else
+      :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
       :when (eq kw :shadow) :append args :into shadow :else
+      :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
+      :when (eq kw :import-from) :collect args :into import-from :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 :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
       :when (eq kw :mix) :append args :into mix :else
+      :when (eq kw :reexport) :append args :into reexport :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
+      :when (eq kw :upgrade)
+        :do (unless (and (consp args) (null (cdr args)) (member (car args) '(:soft :hard)) (null upgrade))
+              (error "define-package: bad :upgrade directive"))
+            (setf upgrade (car args)) :else
+      :do (error "unrecognized define-package keyword ~S" kw)
+      :finally (return `(:nicknames ,nicknames :documentation ,documentation
+                         :use ,(if use-p use '(:common-lisp))
+                         :shadow ,shadow :shadowing-import-from ,shadowing-import-from
+                         :import-from ,import-from :export ,export :intern ,intern
+                         :recycle ,(if recycle-p recycle (cons package nicknames))
+                         :mix ,mix :reexport ,reexport :unintern ,unintern
+                         ,@(when upgrade `(:upgrade ,upgrade))
+                         :fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf)))))
 
 (defmacro define-package (package &rest clauses)
   `(eval-when (:compile-toplevel :load-toplevel :execute)
-     (apply 'ensure-package ',package ',(parse-define-package-clauses clauses))))
+     #+gcl (defpackage ,package (:use))
+     (apply 'ensure-package ',(parse-define-package-clauses package clauses))))
diff --git a/pathname.lisp b/pathname.lisp
index 01bdf0d59..ad40192f1 100644
--- a/pathname.lisp
+++ b/pathname.lisp
@@ -706,8 +706,7 @@ For the latter case, we ought pick random suffix and atomically open it."
 (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)
+(defun* sane-physical-pathname (defaults &key (keep t) fallback must-exist)
   (flet ((sanitize (x)
            (setf x (and x (ignore-errors (translate-logical-pathname x))))
            (when (pathnamep x)
@@ -722,10 +721,13 @@ For the latter case, we ought pick random suffix and atomically open it."
                (setf x (and (probe-file* x) x)))
              (and (physical-pathname-p x) x))))
     (or (sanitize defaults)
-        (when fallback (sanitize (ignore-errors (user-homedir-pathname))))
+        (when fallback
+          (or (sanitize (ignore-errors (user-homedir-pathname)))
+              (sanitize (nil-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/test/script-support.lisp b/test/script-support.lisp
index f3d04415a..f24f9e6ed 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -63,9 +63,9 @@
   (let ((old-asdf
           (merge-pathnames
            (make-pathname :directory `(#-gcl :relative "tmp")
-                          :name (format nil "asdf-~A" tag)
+                          :name (format nil "asdf-~A" tag) :type "lisp"
                           :defaults *asdf-directory*)
-           *asdf-lisp*)))
+           *asdf-directory*)))
     (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning))
       (load old-asdf))))
 
diff --git a/upgrade.lisp b/upgrade.lisp
index a8fcec8c5..0e5595185 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.63")
+         (asdf-version "2.26.64")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
-- 
GitLab