0.8.20.10:

	Fix ctor/package deletion problems (Tim Daly sbcl-help 2005-03)
	... MORE GENERALIZED FUNCTION NAMES

diff --git a/NEWS b/NEWS
index dbe40c6..4ca43a6 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -18,6 +18,8 @@ changes in sbcl-0.8.21 (0.9alpha.1?) relative to sbcl-0.8.20:
   * fixed bug 276b: mutating with MULTIPLE-VALUE-SETQ a binding of a
     specialized parameter to a method to something that is not TYPEP
     the specializer is now possible.
+  * fixed bug: the MAKE-INSTANCE optimization is now correct in the
+    face of package deletion.
   * contrib improvement: the SB-SIMPLE-STREAMS contrib now defines
     STRING-SIMPLE-STREAM and FILE-SIMPLE-STREAM as subclasses of
     STRING-STREAM and FILE-STREAM, respectively.

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index ea3e116..089b759 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -1235,6 +1235,38 @@
       (setf (sap-ref-8 sap tail) bits))
   (code-char byte))
 
+(let* ((table (let ((s (make-string 256)))
+               (map-into s #'code-char
+                         '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f
+                           #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f
+                           #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07
+                           #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a
+                           #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c
+                           #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac
+                           #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
+                           #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22
+                           #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1
+                           #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4
+                           #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae
+                           #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7
+                           #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5
+                           #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
+                           #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5
+                           #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f))
+               s))
+       (reverse-table (let ((rt (make-array 256 :element-type '(unsigned-byte 8) :initial-element 0)))
+                         (loop for char across table for i from 0
+                              do (aver (= 0 (aref rt (char-code char))))
+                              do (setf (aref rt (char-code char)) i))
+                         rt)))
+  (define-external-format (:ebcdic-us :ibm-037 :ibm037)
+      1 t
+    (if (>= bits 256)
+       (stream-encoding-error stream bits)
+       (setf (sap-ref-8 sap tail) (aref reverse-table bits)))
+    (aref table byte)))
+    
+
 #!+sb-unicode
 (let ((latin-9-table (let ((table (make-string 256)))
                        (do ((i 0 (1+ i)))

diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp
index cd5793c..937da71 100644 (file)
--- a/src/pcl/compiler-support.lisp
+++ b/src/pcl/compiler-support.lisp
@@ -85,6 +85,9 @@
 (define-internal-pcl-function-name-syntax sb-pcl::slow-method (list)
   (valid-function-name-p (cadr list)))
 
+(define-internal-pcl-function-name-syntax sb-pcl::ctor (list)
+  (valid-function-name-p (cadr list)))
+
 (defun sb-pcl::random-documentation (name type)
   (cdr (assoc type (info :random-documentation :stuff name))))
 

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 89957c7..3a08689 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -134,17 +134,8 @@
     (setf (%funcallable-instance-info ctor 1)
          (ctor-function-name ctor))))
 
-;;; Keep this a separate function for testing.
 (defun make-ctor-function-name (class-name initargs)
-  (let ((*package* *pcl-package*)
-       (*print-case* :upcase)
-       (*print-pretty* nil)
-       (*print-gensym* t))
-    (format-symbol *pcl-package* "CTOR ~S::~S ~S ~S"
-                  (package-name (symbol-package class-name))
-                  (symbol-name class-name)
-                  (plist-keys initargs)
-                  (plist-values initargs :test #'constantp))))
+  (list* 'ctor class-name initargs))
 
 ;;; Keep this a separate function for testing.
 (defun ensure-ctor (function-name class-name initargs)
@@ -156,7 +147,7 @@
   (without-package-locks ; for (setf symbol-function)
    (let ((ctor (%make-ctor function-name class-name nil initargs)))
      (push ctor *all-ctors*)
-     (setf (symbol-function function-name) ctor)
+     (setf (fdefinition function-name) ctor)
      (install-initial-constructor ctor :force-p t)
      ctor)))
 
@@ -233,7 +224,7 @@
                                    t)
                          (function (&rest t) t))
                      ,function-name))
-             (,function-name ,@value-forms))))))))
+             (funcall (function ,function-name) ,@value-forms))))))))
 
 \f
 ;;; **************************************************

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 23374fa..231ca8d 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -1151,13 +1151,7 @@
                    (apply fmf pv-cell nmc (nconc args (list rest))))
                  (apply fmf pv-cell nmc method-args)))))
     (let* ((fname (method-function-get fmf :name))
-          (name `(,(or (get (car fname) 'method-sym)
-                       (setf (get (car fname) 'method-sym)
-                             (let ((str (symbol-name (car fname))))
-                               (if (string= "FAST-" str :end2 5)
-                                   (format-symbol *pcl-package* (subseq str 5))
-                                   (car fname)))))
-                   ,@(cdr fname))))
+          (name (cons 'slow-method (cdr fname))))
       (set-fun-name method-function name))
     (setf (method-function-get method-function :fast-function) fmf)
     method-function))

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index e157330..731cfdf 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -904,7 +904,12 @@
   (assert (string= (with-output-to-string (*standard-output*)
                     (method-for-defined-classes #\3))
                   "3")))
-            
+
+(load "package-ctor-bug.lisp")
+(assert (= (package-ctor-bug:test) 3))
+(delete-package "PACKAGE-CTOR-BUG")
+(load "package-ctor-bug.lisp")
+(assert (= (package-ctor-bug:test) 3))
 
 ;;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/tests/package-ctor-bug.lisp b/tests/package-ctor-bug.lisp
new file mode 100644 (file)
index 0000000..e4285f4
--- /dev/null
+++ b/tests/package-ctor-bug.lisp
@@ -0,0 +1,11 @@
+(defpackage "PACKAGE-CTOR-BUG"
+  (:use "CL")
+  (:export "TEST"))
+
+(in-package "PACKAGE-CTOR-BUG")
+
+(defclass fooass ()
+  ((flot :initarg :flot :reader flot)))
+
+(defun test ()
+  (flot (make-instance 'fooass :flot 3)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 15559e9..f241267 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.20.9"
+"0.8.20.10"