0.8.1.43:

	Get SB-MOP:CLASS-PROTOTYPE right in more cases
	... new :PROTOTYPE-FORM property in
		SB-KERNEL:*BUILT-IN-CLASSES* list;
	... use it to generate the prototype in
		SB-PCL::*BUILT-IN-CLASSES*;
	bonus: since this means we have an instance of almost every
	built-in-class by SAVE-LISP-AND-DIE time, we can detect
	longstanding bugs in PURIFY
	... make complex bit-vectors and simple-array-nils purifyable.

diff --git a/NEWS b/NEWS
index 0adda5f..337069c 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1920,6 +1920,10 @@ changes in sbcl-0.8.2 relative to sbcl-0.8.1:
     of ARRAY-DIMENSION-LIMIT and ARRAY-TOTAL-SIZE-LIMIT no longer leak
     into the newly-built SBCL. (reported by Eric Marsden on #lisp,
     test case from Patrik Nordebo)
+  * improved the ability of the disassembler on the PPC platform to
+    provide helpful disassembly notes.
+  * SB-MOP:CLASS-PROTOTYPE on built-in-classes returns an instance of
+    the class in more cases than previously.
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** LAST and [N]BUTLAST should accept a bignum.
     ** condition slot accessors are methods.

diff --git a/src/code/class.lisp b/src/code/class.lisp
index 5ccc7ac..8da8e98 100644 (file)
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -928,25 +928,32 @@
   (setq
    *built-in-classes*
    '((t :state :read-only :translation t)
-     (character :enumerable t :translation base-char)
+     (character :enumerable t :translation base-char
+                :prototype-form (code-char 42))
      (base-char :enumerable t
                :inherits (character)
-               :codes (#.sb!vm:base-char-widetag))
-     (symbol :codes (#.sb!vm:symbol-header-widetag))
+               :codes (#.sb!vm:base-char-widetag)
+                :prototype-form (code-char 42))
+     (symbol :codes (#.sb!vm:symbol-header-widetag)
+             :prototype-form '#:mu)
 
      (instance :state :read-only)
 
-     (system-area-pointer :codes (#.sb!vm:sap-widetag))
-     (weak-pointer :codes (#.sb!vm:weak-pointer-widetag))
+     (system-area-pointer :codes (#.sb!vm:sap-widetag)
+                          :prototype-form (sb!sys:int-sap 42))
+     (weak-pointer :codes (#.sb!vm:weak-pointer-widetag)
+      :prototype-form (sb!ext:make-weak-pointer (find-package "CL")))
      (code-component :codes (#.sb!vm:code-header-widetag))
      (lra :codes (#.sb!vm:return-pc-header-widetag))
-     (fdefn :codes (#.sb!vm:fdefn-widetag))
+     (fdefn :codes (#.sb!vm:fdefn-widetag)
+            :prototype-form (sb!kernel:make-fdefn "42"))
      (random-class) ; used for unknown type codes
 
      (function
       :codes (#.sb!vm:closure-header-widetag
              #.sb!vm:simple-fun-header-widetag)
-      :state :read-only)
+      :state :read-only
+      :prototype-form (function (lambda () 42)))
      (funcallable-instance
       :inherits (function)
       :state :read-only)
@@ -955,20 +962,24 @@
      (complex
       :translation complex
       :inherits (number)
-      :codes (#.sb!vm:complex-widetag))
+      :codes (#.sb!vm:complex-widetag)
+      :prototype-form (complex 42 42))
      (complex-single-float
       :translation (complex single-float)
       :inherits (complex number)
-      :codes (#.sb!vm:complex-single-float-widetag))
+      :codes (#.sb!vm:complex-single-float-widetag)
+      :prototype-form (complex 42f0 42f0))
      (complex-double-float
       :translation (complex double-float)
       :inherits (complex number)
-      :codes (#.sb!vm:complex-double-float-widetag))
+      :codes (#.sb!vm:complex-double-float-widetag)
+      :prototype-form (complex 42d0 42d0))
      #!+long-float
      (complex-long-float
       :translation (complex long-float)
       :inherits (complex number)
-      :codes (#.sb!vm:complex-long-float-widetag))
+      :codes (#.sb!vm:complex-long-float-widetag)
+      :prototype-form (complex 42l0 42l0))
      (real :translation real :inherits (number))
      (float
       :translation float
@@ -976,23 +987,27 @@
      (single-float
       :translation single-float
       :inherits (float real number)
-      :codes (#.sb!vm:single-float-widetag))
+      :codes (#.sb!vm:single-float-widetag)
+      :prototype-form 42f0)
      (double-float
       :translation double-float
       :inherits (float real number)
-      :codes (#.sb!vm:double-float-widetag))
+      :codes (#.sb!vm:double-float-widetag)
+      :prototype-form 42d0)
      #!+long-float
      (long-float
       :translation long-float
       :inherits (float real number)
-      :codes (#.sb!vm:long-float-widetag))
+      :codes (#.sb!vm:long-float-widetag)
+      :prototype-form 42l0)
      (rational
       :translation rational
       :inherits (real number))
      (ratio
       :translation (and rational (not integer))
       :inherits (rational real number)
-      :codes (#.sb!vm:ratio-widetag))
+      :codes (#.sb!vm:ratio-widetag)
+      :prototype-form 1/42)
      (integer
       :translation integer
       :inherits (rational real number))
@@ -1000,17 +1015,22 @@
       :translation (integer #.sb!xc:most-negative-fixnum
                    #.sb!xc:most-positive-fixnum)
       :inherits (integer rational real number)
-      :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag))
+      :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag)
+      :prototype-form 42)
      (bignum
       :translation (and integer (not fixnum))
       :inherits (integer rational real number)
-      :codes (#.sb!vm:bignum-widetag))
+      :codes (#.sb!vm:bignum-widetag)
+      ;; FIXME: wrong for 64-bit!
+      :prototype-form (expt 2 42))
 
      (array :translation array :codes (#.sb!vm:complex-array-widetag)
-            :hierarchical-p nil)
+            :hierarchical-p nil
+            :prototype-form (make-array nil :adjustable t))
      (simple-array
       :translation simple-array :codes (#.sb!vm:simple-array-widetag)
-      :inherits (array))
+      :inherits (array)
+      :prototype-form (make-array nil))
      (sequence
       :translation (or cons (member nil) vector))
      (vector
@@ -1020,92 +1040,110 @@
      (simple-vector
       :translation simple-vector :codes (#.sb!vm:simple-vector-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0))
      (bit-vector
       :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag)
-      :inherits (vector array sequence))
+      :inherits (vector array sequence)
+      :prototype-form (make-array 0 :element-type 'bit :fill-pointer t))
      (simple-bit-vector
       :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag)
       :direct-superclasses (bit-vector simple-array)
       :inherits (bit-vector vector simple-array
-                array sequence))
+                array sequence)
+      :prototype-form (make-array 0 :element-type 'bit))
      (simple-array-unsigned-byte-2
       :translation (simple-array (unsigned-byte 2) (*))
       :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(unsigned-byte 2)))
      (simple-array-unsigned-byte-4
       :translation (simple-array (unsigned-byte 4) (*))
       :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(unsigned-byte 4)))
      (simple-array-unsigned-byte-8
       :translation (simple-array (unsigned-byte 8) (*))
       :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(unsigned-byte 8)))
      (simple-array-unsigned-byte-16
       :translation (simple-array (unsigned-byte 16) (*))
       :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(unsigned-byte 16)))
      (simple-array-unsigned-byte-32
       :translation (simple-array (unsigned-byte 32) (*))
       :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(unsigned-byte 32)))
      (simple-array-signed-byte-8
       :translation (simple-array (signed-byte 8) (*))
       :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(signed-byte 8)))
      (simple-array-signed-byte-16
       :translation (simple-array (signed-byte 16) (*))
       :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(signed-byte 16)))
      (simple-array-signed-byte-30
       :translation (simple-array (signed-byte 30) (*))
       :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(signed-byte 30)))
      (simple-array-signed-byte-32
       :translation (simple-array (signed-byte 32) (*))
       :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(signed-byte 32)))
      (simple-array-single-float
       :translation (simple-array single-float (*))
       :codes (#.sb!vm:simple-array-single-float-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type 'single-float))
      (simple-array-double-float
       :translation (simple-array double-float (*))
       :codes (#.sb!vm:simple-array-double-float-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type 'double-float))
      #!+long-float
      (simple-array-long-float
       :translation (simple-array long-float (*))
       :codes (#.sb!vm:simple-array-long-float-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type 'long-float))
      (simple-array-complex-single-float
       :translation (simple-array (complex single-float) (*))
       :codes (#.sb!vm:simple-array-complex-single-float-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(complex single-float)))
      (simple-array-complex-double-float
       :translation (simple-array (complex double-float) (*))
       :codes (#.sb!vm:simple-array-complex-double-float-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(complex double-float)))
      #!+long-float
      (simple-array-complex-long-float
       :translation (simple-array (complex long-float) (*))
       :codes (#.sb!vm:simple-array-complex-long-float-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence))
+      :inherits (vector simple-array array sequence)
+      :prototype-form (make-array 0 :element-type '(complex long-float)))
      (string
       :translation string
       :direct-superclasses (vector)
@@ -1115,43 +1153,50 @@
       :direct-superclasses (string simple-array)
       :inherits (string vector simple-array array sequence))
      (vector-nil
-      ;; FIXME: Should this be (AND (VECTOR NIL) (NOT (SIMPLE-ARRAY NIL (*))))?
       :translation (vector nil)
       :codes (#.sb!vm:complex-vector-nil-widetag)
       :direct-superclasses (string)
-      :inherits (string vector array sequence))
+      :inherits (string vector array sequence)
+      :prototype-form (make-array 0 :element-type 'nil :fill-pointer t))
      (simple-array-nil
       :translation (simple-array nil (*))
       :codes (#.sb!vm:simple-array-nil-widetag)
       :direct-superclasses (vector-nil simple-string)
-      :inherits (vector-nil simple-string string vector simple-array array sequence))
+      :inherits (vector-nil simple-string string vector simple-array
+                array sequence)
+      :prototype-form (make-array 0 :element-type 'nil))
      (base-string
       :translation base-string
       :codes (#.sb!vm:complex-base-string-widetag)
       :direct-superclasses (string)
-      :inherits (string vector array sequence))
+      :inherits (string vector array sequence)
+      :prototype-form (make-array 0 :element-type 'base-char :fill-pointer t))
      (simple-base-string
       :translation simple-base-string
       :codes (#.sb!vm:simple-base-string-widetag)
       :direct-superclasses (base-string simple-string)
       :inherits (base-string simple-string string vector simple-array
-                array sequence))
+                array sequence)
+      :prototype-form (make-array 0 :element-type 'base-char))
      (list
       :translation (or cons (member nil))
       :inherits (sequence))
      (cons
       :codes (#.sb!vm:list-pointer-lowtag)
       :translation cons
-      :inherits (list sequence))
+      :inherits (list sequence)
+      :prototype-form (cons nil nil))
      (null
       :translation (member nil)
       :inherits (symbol list sequence)
-      :direct-superclasses (symbol list))
+      :direct-superclasses (symbol list)
+      :prototype-form 'nil)
      
      (stream
       :state :read-only
       :depth 3
-      :inherits (instance)))))
+      :inherits (instance)
+      :prototype-form (make-broadcast-stream)))))
 
 ;;; See also src/code/class-init.lisp where we finish setting up the
 ;;; translations for built-in types.
@@ -1166,12 +1211,13 @@
              enumerable
              state
               depth
+             prototype-form
              (hierarchical-p t) ; might be modified below
              (direct-superclasses (if inherits
                                     (list (car inherits))
                                     '(t))))
        x
-      (declare (ignore codes state translation))
+      (declare (ignore codes state translation prototype-form))
       (let ((inherits-list (if (eq name t)
                               ()
                               (cons t (reverse inherits))))

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index 2bdeb05..89177ba 100644 (file)
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -302,58 +302,6 @@
 \f
 ;;;; built-in classes
 
-;;; FIXME: This was the portable PCL way of setting up
-;;; *BUILT-IN-CLASSES*, but in SBCL (as in CMU CL) it's almost
-;;; entirely wasted motion, since it's immediately overwritten by a
-;;; result mostly derived from SB-KERNEL::*BUILT-IN-CLASSES*. However,
-;;; we can't just delete it, since the fifth element from each entry
-;;; (a prototype of the class) is still in the final result. It would
-;;; be nice to clean this up so that the other, never-used stuff is
-;;; gone, perhaps finding a tidier way to represent examples of each
-;;; class, too.
-;;;
-;;; FIXME: This can probably be blown away after bootstrapping.
-;;; And SB-KERNEL::*BUILT-IN-CLASSES*, too..
-#|
-(defvar *built-in-classes*
-  ;; name       supers     subs                     cdr of cpl
-  ;; prototype
-  '(;(t         ()      (number sequence array character symbol) ())
-    (number     (t)    (complex float rational) (t))
-    (complex    (number)   ()                 (number t)
-     #c(1 1))
-    (float      (number)   ()                 (number t)
-     1.0)
-    (rational   (number)   (integer ratio)       (number t))
-    (integer    (rational) ()                 (rational number t)
-     1)
-    (ratio      (rational) ()                 (rational number t)
-     1/2)
-
-    (sequence   (t)    (list vector)       (t))
-    (list       (sequence) (cons null)       (sequence t))
-    (cons       (list)     ()                 (list sequence t)
-     (nil))
-
-    (array      (t)    (vector)                 (t)
-     #2A((nil)))
-    (vector     (array
-                sequence) (string bit-vector)      (array sequence t)
-     #())
-    (string     (vector)   ()                 (vector array sequence t)
-     "")
-    (bit-vector (vector)   ()                 (vector array sequence t)
-     #*1)
-    (character  (t)    ()                     (t)
-     #\c)
-
-    (symbol     (t)    (null)             (t)
-     symbol)
-    (null       (symbol
-                list)     ()                  (symbol list sequence t)
-     nil)))
-|#
-
 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
 ;;; SB-PCL:*BUILT-IN-CLASSES*.
 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
@@ -377,34 +325,13 @@
                     (/noshow sub)
                     (when (member class (direct-supers sub))
                       (res sub)))))
-              (res)))
-          (prototype (class-name)
-            (let ((assoc (assoc class-name
-                                '((complex    . #c(1 1))
-                                  (float      . 1.0)
-                                  (integer    . 1)
-                                  (ratio      . 1/2)
-                                  (sequence   . nil)
-                                  (list       . nil)
-                                  (cons       . (nil))
-                                  (array      . #2a((nil)))
-                                  (vector     . #())
-                                  (string     . "")
-                                  (bit-vector . #*1)
-                                  (character  . #\c)
-                                  (symbol     . symbol)
-                                  (null       . nil)))))
-              (if assoc
-                  (cdr assoc)
-                  ;; This is the default prototype value which was
-                  ;; used, without explanation, by the CMU CL code
-                  ;; we're derived from. Evidently it's safe in all
-                  ;; relevant cases.
-                  42))))
+              (res))))
     (mapcar (lambda (kernel-bic-entry)
              (/noshow "setting up" kernel-bic-entry)
              (let* ((name (car kernel-bic-entry))
-                    (class (find-classoid name)))
+                    (class (find-classoid name))
+                    (prototype-form
+                     (getf (cdr kernel-bic-entry) :prototype-form)))
                (/noshow name class)
                `(,name
                  ,(mapcar #'classoid-name (direct-supers class))
@@ -416,7 +343,13 @@
                        (reverse
                         (layout-inherits
                          (classoid-layout class))))
-                 ,(prototype name))))
+                 ,(if prototype-form
+                      (eval prototype-form)
+                      ;; This is the default prototype value which
+                      ;; was used, without explanation, by the CMU CL
+                      ;; code we're derived from. Evidently it's safe
+                      ;; in all relevant cases.
+                      42))))
            (remove-if (lambda (kernel-bic-entry)
                         (member (first kernel-bic-entry)
                                 ;; I'm not sure why these are removed from

diff --git a/src/runtime/purify.c b/src/runtime/purify.c
index 7c04ed9..c4309e2 100644 (file)
--- a/src/runtime/purify.c
+++ b/src/runtime/purify.c
@@ -284,6 +284,7 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
 #ifdef LONG_FLOAT_WIDETAG
        case LONG_FLOAT_WIDETAG:
 #endif
+       case SIMPLE_ARRAY_NIL_WIDETAG:
        case SIMPLE_BASE_STRING_WIDETAG:
        case SIMPLE_BIT_VECTOR_WIDETAG:
        case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
@@ -924,6 +925,7 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
       case COMPLEX_WIDETAG:
       case SIMPLE_ARRAY_WIDETAG:
       case COMPLEX_BASE_STRING_WIDETAG:
+      case COMPLEX_BIT_VECTOR_WIDETAG:
       case COMPLEX_VECTOR_NIL_WIDETAG:
       case COMPLEX_VECTOR_WIDETAG:
       case COMPLEX_ARRAY_WIDETAG:
@@ -936,6 +938,9 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
       case SYMBOL_HEADER_WIDETAG:
         return ptrans_boxed(thing, header, 0);
 
+      case SIMPLE_ARRAY_NIL_WIDETAG:
+        return ptrans_vector(thing, 0, 0, 0, constant);
+
       case SIMPLE_BASE_STRING_WIDETAG:
         return ptrans_vector(thing, 8, 1, 0, constant);
 
@@ -1147,6 +1152,10 @@ pscav(lispobj *addr, int nwords, boolean constant)
                 count = 1;
                 break;
 
+             case SIMPLE_ARRAY_NIL_WIDETAG:
+               count = 2;
+               break;
+
               case SIMPLE_BASE_STRING_WIDETAG:
                 vector = (struct vector *)addr;
                 count = CEILING(NWORDS(fixnum_value(vector->length)+1,4)+2,2);

diff --git a/version.lisp-expr b/version.lisp-expr
index 6ad7cb7..80bb600 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.1.42"
+"0.8.1.43"