From b6d6fb0693c17ea9b2d508b44659d6933c3331be Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Wed, 9 Jan 2013 23:42:36 -0500
Subject: [PATCH] 2.26.68: self-upgrade now works somewhat on SBCL and CCL.

Fixed corner bugs in the package surgery.
Stopped using fmakunbound as part of the package definition;
it should happen as part of with-upgrade,
or, for now, systematically with defgeneric* and defun*.
Added special magic for ASDF fixup, that will have to be enhanced.
---
 asdf.asd         |  2 +-
 header.lisp      |  2 +-
 interface.lisp   |  2 +-
 lisp-action.lisp |  2 +-
 package.lisp     | 42 ++++++++++++++++++++++++++++++------------
 upgrade.lisp     |  2 +-
 utility.lisp     |  2 +-
 7 files changed, 36 insertions(+), 18 deletions(-)

diff --git a/asdf.asd b/asdf.asd
index 9d8cce90..827f1814 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.67" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.68" ;; to be automatically updated by bin/bump-revision
   :depends-on ()
   :components
   ((:file "asdf")))
diff --git a/header.lisp b/header.lisp
index 7bc0ec0d..2a95609d 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.67: Another System Definition Facility.
+;;; This is ASDF 2.26.68: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
diff --git a/interface.lisp b/interface.lisp
index 7b0e7456..6e248149 100644
--- a/interface.lisp
+++ b/interface.lisp
@@ -5,7 +5,7 @@
   (:nicknames :asdf)
   (:recycle :asdf/interface :asdf)
   (:unintern
-   #:*asdf-revision* #:around #:asdf-method-combination
+   #:*asdf-revision* #:around #:asdf-method-combination #:intern*
    #:do-traverse #:do-dep #:do-one-dep #:visit-action #:component-visited-p
    #:split #:make-collector
    #:loaded-systems ; makes for annoying SLIME completion
diff --git a/lisp-action.lisp b/lisp-action.lisp
index 57363589..73e97428 100644
--- a/lisp-action.lisp
+++ b/lisp-action.lisp
@@ -9,7 +9,7 @@
   (:export
    #:compile-error #:compile-failed #:compile-warned #:try-recompiling
    #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
-   #:basic-load-op #:basic-compile-op
+   #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
    #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
    #:call-with-around-compile-hook
    #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source))
diff --git a/package.lisp b/package.lisp
index b2b1b71c..38089b2c 100644
--- a/package.lisp
+++ b/package.lisp
@@ -179,10 +179,10 @@ when the symbol is not found."
                    ((gethash name shadowed)
                     (error "Can't both shadow ~S and import it from ~S" name (package-name p)))
                    (t
-                    (when (and xp (not (eq i x)))
-                      (unintern* x package))
                     (setf (gethash name imported) t)
-                    (import i package))))))
+                    (unless (and xp (eq i x))
+                      (when xp (unintern* x p))
+                      (import i package)))))))
            (ensure-mix (sym p)
              (let* ((name (string sym))
                     (sp (string p)))
@@ -197,22 +197,24 @@ when the symbol is not found."
                       (ensure-inherited sym sp)))))))
            (ensure-inherited (sym p)
              (let* ((name (string sym))
-                    (sp (string p))
-                    (s (find-symbol* name sp))
-                    (ip (gethash name inherited)))
+                    (symbol (find-symbol* name p))
+                    (sp (symbol-package symbol))
+                    (spn (package-name sp))
+                    (ipn (gethash name inherited)))
                (multiple-value-bind (x xp) (find-symbol name package)
                  (cond
-                   (ip
-                    (unless (eq ip sp)
+                   (ipn
+                    (unless (eq spn ipn)
                       (error "Can't inherit ~S from ~S, it is inherited from ~S"
-                             name sp ip)))
+                             name spn ipn)))
                    ((gethash name imported)
-                    (unless (eq s x)
+                    (unless (eq symbol x)
                       (error "Can't inherit ~S from ~S, it is imported from ~S"
                              name sp (package-name (symbol-package x)))))
                    ((gethash name shadowed)
-                    (error "Can't inherit ~S from ~S, it is shadowed" name sp))
+                    (error "Can't inherit ~S from ~S, it is shadowed" name spn))
                    (t
+                    (setf (gethash name inherited) spn)
                     (when xp
                       (unintern* x package)))))))
            (recycle-symbol (name)
@@ -353,6 +355,7 @@ when the symbol is not found."
               (error "define-package: bad :upgrade directive"))
             (setf upgrade (car args)) :else
       :do (error "unrecognized define-package keyword ~S" kw)
+      (progn fmakunbound fmakunbound-setf)
       :finally (return `(,package
                          :nicknames ,nicknames :documentation ,documentation
                          :use ,(if use-p use '(:common-lisp))
@@ -361,9 +364,24 @@ when the symbol is not found."
                          :recycle ,(if recycle-p recycle (cons package nicknames))
                          :mix ,mix :reexport ,reexport :unintern ,unintern
                          ,@(when upgrade `(:upgrade ,upgrade))
-                         :fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf)))))
+                         #|:fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf|#)))))
 
 (defmacro define-package (package &rest clauses)
   `(eval-when (:compile-toplevel :load-toplevel :execute)
      #+gcl (defpackage ,package (:use))
      (apply 'ensure-package ',(parse-define-package-form package clauses))))
+
+;;;; MAGIC FIXUP FOR ASDF.
+;; For bootstrapping reason, define-package can't do its magic on the asdf/package package itself,
+;; so instead do something ugly and special purpose. However, other packages could have imported
+;; from ASDF and be in trouble. There ought to be a better solution to merging packages without tears.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *extirpated-symbols* ())
+  (when (find-package :asdf)
+    (let (l)
+      (do-external-symbols (sym :asdf/package)
+        (multiple-value-bind (symbol lstatus) (find-symbol* sym :asdf nil)
+          (when (and lstatus (not (eq sym symbol)))
+            (push symbol l))))
+      (push (cons :asdf (mapcar #'symbol-name-package (sort l 'string<))) *extirpated-symbols*))))
diff --git a/upgrade.lisp b/upgrade.lisp
index b0414a87..de3e005a 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -24,7 +24,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.67")
+         (asdf-version "2.26.68")
          (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 677f2876..2468cbef 100644
--- a/utility.lisp
+++ b/utility.lisp
@@ -26,7 +26,7 @@
     ((defdef (def* def)
        `(defmacro ,def* (name formals &rest rest)
           `(progn
-             #+(or ecl gcl)
+             ;; #+(or ecl gcl)
              ,(when (and #+gcl<2.7 (symbolp name))
                 `(fmakunbound ',name))
              #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
-- 
GitLab