From e2b6242387e90650886da650af6af486c64d7e82 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Fri, 11 Jan 2013 15:57:06 -0500
Subject: [PATCH] 2.26.78: Try harder to make CLISP happy, yet fail.

Have a package-definition-form in defpackage format
rather than ad-hoc package-data.

Backtrace on clisp and ecl.
---
 TODO         |   2 +
 asdf.asd     |   2 +-
 header.lisp  |   2 +-
 image.lisp   |   2 +
 package.lisp | 153 +++++++++++++++++++++++++++++++++++++--------------
 upgrade.lisp |   2 +-
 6 files changed, 118 insertions(+), 45 deletions(-)

diff --git a/TODO b/TODO
index da4f37e3..7ea2554c 100644
--- a/TODO
+++ b/TODO
@@ -4,6 +4,8 @@
 ** Have it pass test-lisp
 ** Have it pass test-upgrade
 ** Get package upgrade right
+   Try a newer CLISP than 2.44.1, and if it still breaks, try harder,
+   by e.g. having ensure-package return a working defpackage form.
 ** The unconditional ensure-package-unused breaks test-encodings.script,
    since asdf severs itself from its client package hosting the
    defsystem form during defsystem-depends-on.
diff --git a/asdf.asd b/asdf.asd
index b3ee9ef1..4f4b107c 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.77" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.78" ;; to be automatically updated by bin/bump-revision
   :depends-on ()
   :components ((:module "build" :components ((:file "asdf")))))
 
diff --git a/header.lisp b/header.lisp
index 9d21fd87..cd7618dd 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.77: Another System Definition Facility.
+;;; This is ASDF 2.26.78: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
diff --git a/image.lisp b/image.lisp
index 72c805a2..3c71ce21 100644
--- a/image.lisp
+++ b/image.lisp
@@ -78,9 +78,11 @@ This is designed to abstract away the implementation specific quit forms."
 (defun print-backtrace (out)
   "Print a backtrace (implementation-defined)"
   (declare (ignorable out))
+  #+clisp (system::print-backtrace)
   #+clozure (let ((*debug-io* out))
 	      (ccl:print-call-history :count 100 :start-frame-number 1)
 	      (finish-output out))
+  #+ecl (si::tpl-backtrace)
   #+sbcl
   (sb-debug:backtrace
    #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream 'most-positive-fixnum)
diff --git a/package.lisp b/package.lisp
index 690846f7..b0313554 100644
--- a/package.lisp
+++ b/package.lisp
@@ -16,8 +16,7 @@
    #:find-package* #:find-symbol* #:symbol-call #:intern* #:unintern*
    #:symbol-shadowing-p #:rehome-symbol
    #:delete-package* #:package-names #:packages-from-names
-   #:symbol-name-package #:package-data
-   #:ensure-package #:define-package))
+   #:package-definition-form #:ensure-package #:define-package))
 
 (in-package :asdf/package)
 
@@ -83,6 +82,35 @@ or when loading the package is optional."
         (values nil nil))))
   (defun symbol-shadowing-p (symbol package)
     (member symbol (package-shadowing-symbols package)))
+  #+(or clisp clozure)
+  (defun get-setf-function-symbol (symbol)
+    #+clisp (let ((sym (get symbol 'system::setf-function)))
+              (if sym (values sym :setf-function)
+                  (let ((sym (get symbol 'system::setf-expander)))
+                    (if sym (values sym :setf-expander)
+                        (values nil nil)))))
+    #+clozure (gethash symbol ccl::%setf-function-names%))
+  #+(or clisp clozure)
+  (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
+    #+clisp (assert (member kind '(:setf-function :setf-expander)))
+    #+clozure (assert (eq kind t))
+    #+clisp
+    (cond
+      ((null new-setf-symbol)
+       (remprop symbol 'system::setf-function)
+       (remprop symbol 'system::setf-expander))
+      ((eq kind :setf-function)
+       (setf (get symbol 'system::setf-function) new-setf-symbol))
+      ((eq kind :setf-expander)
+       (setf (get symbol 'system::setf-expander) new-setf-symbol)))
+    #+clozure
+    (progn
+      (gethash symbol ccl::%setf-function-names%) new-setf-symbol
+      (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
+  #+(or clisp clozure)
+  (defun create-setf-function-symbol (symbol)
+    #+clisp (system::setf-symbol symbol)
+    #+clozure (ccl::construct-setf-function-name symbol))
   (defun rehome-symbol (symbol package-designator)
     "Changes the home package of a symbol, also leaving it present in its old home if any"
     (let* ((name (symbol-name symbol))
@@ -109,18 +137,17 @@ or when loading the package is optional."
             (if shadowing
                 (shadowing-import symbol old-package)
                 (import symbol old-package))
-            #+ccl
-            (multiple-value-bind (setf-name foundp)
-                (gethash symbol ccl::%setf-function-names%)
-              (when foundp
-                (let* ((setf-function (fdefinition setf-name))
-                       (new-setf-name (ccl::construct-setf-function-name symbol)))
-                  (setf (fdefinition new-setf-name) setf-function
-                        (gethash symbol ccl::%setf-function-names%) new-setf-name
-                        (gethash new-setf-name ccl::%setf-function-name-inverses%) symbol))))
-            #+ccl
+            #+(or clisp clozure)
+            (multiple-value-bind (setf-symbol kind)
+                (get-setf-function-symbol symbol)
+              (when kind
+                (let* ((setf-function (fdefinition setf-symbol))
+                       (new-setf-symbol (create-setf-function-symbol symbol)))
+                  (setf (fdefinition new-setf-symbol) setf-function)
+                  (set-setf-function-symbol symbol new-setf-symbol kind))))
+            #+(or clisp clozure)
             (multiple-value-bind (overwritten-setf foundp)
-                (gethash overwritten-symbol ccl::%setf-function-names%)
+                (get-setf-function-symbol overwritten-symbol)
               (when foundp
                 (unintern overwritten-setf)))
             (when (eq old-status :external)
@@ -145,34 +172,57 @@ or when loading the package is optional."
 ;;; Communicable representation of symbol and package information
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
-  (defun symbol-name-package (symbol)
-    (cons (symbol-name symbol) (package-name (symbol-package symbol))))
-  (defun package-data (package-designator &key name-package (error t))
-    (let ((package (find-package* package-designator error)))
+  (defun package-definition-form (package-designator &key internp (error t))
+    (let* ((package (find-package* package-designator error))
+           (name (package-name package))
+           (nicknames (package-nicknames package))
+           (use (mapcar #'package-name (package-use-list package)))
+           (shadow ())
+           (shadowing-import (make-hash-table :test 'equal))
+           (import (make-hash-table :test 'equal))
+           (export ())
+           (intern ()))
       (when package
-        (labels ((marshall-symbols (symbols)
-                   (if name-package (mapcar #'symbol-name-package symbols) symbols))
-                 (sort-symbols (symbols)
-                   (marshall-symbols (sort symbols #'string<)))
-                 (sort-packages (packages)
-                   (sort (mapcar #'package-name packages) #'string<)))
-          (loop :with internal :with external :with inherited
-                :for sym :being :the :symbols :in package
-                :for status = (nth-value 1 (find-symbol* sym package)) :do
-                  (ecase status
-                    (:internal (push sym internal))
-                    (:external (push sym external))
-                    (:inherited (push sym inherited)))
-                :finally
-                   (return
-                     `(:name ,(package-name package)
-                       :nicknames ,(package-nicknames package)
-                       :internal ,(sort-symbols internal)
-                       :external ,(sort-symbols external)
-                       :inherited ,(sort-symbols inherited)
-                       :shadowing ,(sort-symbols (package-shadowing-symbols package))
-                       :use ,(sort-packages (package-use-list package))
-                       :used-by ,(sort-packages (package-used-by-list package))))))))))
+        (loop :for sym :being :the :symbols :in package
+              :for status = (nth-value 1 (find-symbol* sym package)) :do
+                (ecase status
+                  ((nil :inherited))
+                  ((:internal :external)
+                   (let* ((name (symbol-name sym))
+                          (external (eq status :external))
+                          (home (symbol-package sym))
+                          (home-name (package-name home))
+                          (imported (not (eq home package)))
+                          (shadowing (symbol-shadowing-p sym package)))
+                     (cond
+                       ((and shadowing import)
+                        (push name (gethash home-name shadowing-import)))
+                       (shadowing
+                        (push name shadow))
+                       (imported
+                        (push name (gethash home-name import))))
+                     (cond
+                       (external
+                        (push name export))
+                       (imported)
+                       (t (push name intern)))))))
+        (labels ((sort-names (names)
+                   (sort names #'string<))
+                 (table-keys (table)
+                   (loop :for k :being :the :hash-keys :of table :collect k))
+                 (when-relevant (key value)
+                   (when value (list (cons key value))))
+                 (import-options (key table)
+                   (loop :for i :in (sort-names (table-keys table))
+                         :collect `(,key ,i ,@(sort-names (gethash i table))))))
+          `(defpackage ,name
+             ,@(when-relevant :nicknames (sort-names nicknames))
+             (:use ,@(sort-names use))
+             ,@(when-relevant :shadow (sort-names shadow))
+             ,@(import-options :shadowing-import-from shadowing-import)
+             ,@(import-options :import-from import)
+             ,@(when-relevant :export (sort-names export))
+             ,@(when-relevant :intern (and internp (sort-names intern)))))))))
 
 
 ;;; ensure-package, define-package
@@ -189,6 +239,7 @@ or when loading the package is optional."
            (names (cons name nicknames))
            (previous (packages-from-names names))
            (discarded (cdr previous))
+           (to-delete ())
            (package (or (first previous) (make-package name :nicknames nicknames)))
            (recycle (packages-from-names recycle))
            (shadowed (make-hash-table :test 'equal)) ; string to bool
@@ -196,7 +247,14 @@ or when loading the package is optional."
            (exported (make-hash-table :test 'equal)) ; string to bool
            (inherited (make-hash-table :test 'equal))) ; string to package name
       (labels
-          ((ensure-shadowing-import (sym p)
+          ((fresh-package-name (&optional (prefix :%TO-BE-DELETED)
+                                  (index (random most-positive-fixnum)))
+             (loop :for i :from index
+                   :for n = (format nil "~A-~D" prefix i)
+                   :thereis (and (not (find-package n)) n)))
+           (rename-package-away (p)
+             (rename-package p (fresh-package-name)))
+           (ensure-shadowing-import (sym p)
              (let* ((name (string sym))
                     (i (find-symbol* name p)))
                (cond
@@ -300,7 +358,9 @@ or when loading the package is optional."
               :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
                                   (package-names p))
               :do (if n (rename-package p (first n) (rest n))
-                      (delete-package* p)))
+                      (progn
+                        (rename-package-away p)
+                        (push p to-delete))))
         (rename-package package name nicknames)
         (loop :for p :in (set-difference (package-use-list package) (append mix use))
               :do (unuse-package p package))
@@ -337,6 +397,7 @@ or when loading the package is optional."
           (ensure-symbol (string name) t))
         (do-symbols (sym package)
           (ensure-symbol (symbol-name sym)))
+        (map () 'delete-package* to-delete)
         package))))
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
@@ -373,5 +434,13 @@ or when loading the package is optional."
 (defmacro define-package (package &rest clauses)
   `(eval-when (:compile-toplevel :load-toplevel :execute)
      #+(or ecl gcl) (defpackage ,package (:use))
+     #+clisp (macrolet ((foo ()
+                          (apply 'ensure-package ',(parse-define-package-form package clauses))
+                          (package-definition-form ',package)))
+               (foo))
      (apply 'ensure-package ',(parse-define-package-form package clauses))))
 
+#+clisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (find-package :asdf) (delete-package* :asdf)))
+
diff --git a/upgrade.lisp b/upgrade.lisp
index efdaf855..87d411be 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -31,7 +31,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.77")
+         (asdf-version "2.26.78")
          (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
-- 
GitLab