0.7.7.20:

	Fix DATA-VECTOR-REF-C for small-data vectors on the SPARC (Raymond
		Toy cmucl-imp 2002-09-06)
	Fix bugs 47a-c and 171 (from Gerd Moellmann via cmucl-imp)

BUGS

@@ -277,13 +277,6 @@ WORKAROUND:
 
 47:
   DEFCLASS bugs reported by Peter Van Eynde July 25, 2000:
-	a: (DEFCLASS FOO () (A B A)) should signal a PROGRAM-ERROR, and
-	   doesn't.
-	b: (DEFCLASS FOO () (A B A) (:DEFAULT-INITARGS X A X B)) should
-	   signal a PROGRAM-ERROR, and doesn't.
-	c: (DEFCLASS FOO07 NIL ((A :ALLOCATION :CLASS :ALLOCATION :CLASS))),
-	   and other DEFCLASS forms with duplicate specifications in their
-	   slots, should signal a PROGRAM-ERROR, and doesn't.
 	d: (DEFGENERIC IF (X)) should signal a PROGRAM-ERROR, but instead
 	   causes a COMPILER-ERROR.
 
@@ -1041,11 +1034,6 @@ WORKAROUND:
   Since this is a reasonable user error, it shouldn't be reported as 
   an SBCL bug. 
 
-171:
-  (reported by Pierre Mai while investigating bug 47):
-    (DEFCLASS FOO () ((A :SILLY T))) 
-  signals a SIMPLE-ERROR, not a PROGRAM-ERROR.
-
 172:
   sbcl's treatment of at least macro lambda lists is too permissive;
   e.g., in sbcl-0.7.3.7:

NEWS

@@ -1266,6 +1266,8 @@ changes in sbcl-0.7.8 relative to sbcl-0.7.7:
   * fixed several bugs in compiler checking of type declarations, i.e.
     violations of the Python "declarations are assertions" principle
     (thanks to Alexey Dejneka)
+  * fixed several bugs in PCL's error checking (thanks to Gerd
+    Moellmann)
 
 planned incompatible changes in 0.7.x:
 * When the profiling interface settles down, maybe in 0.7.x, maybe

src/compiler/sparc/array.lisp

@@ -189,7 +189,8 @@
 	 (:result-types positive-fixnum)
 	 (:temporary (:scs (non-descriptor-reg)) temp)
 	 (:generator 15
-	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
+	   (multiple-value-bind (word extra) 
+               (floor index ,elements-per-word)
 	     (setf extra (logxor extra (1- ,elements-per-word)))
 	     (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
 			      other-pointer-lowtag)))
@@ -199,8 +200,7 @@
 		      (inst li temp offset)
 		      (inst ld result object temp))))
 	     (unless (zerop extra)
-	       (inst srl result
-		     (logxor (* extra ,bits) ,(1- elements-per-word))))
+	       (inst srl result (* extra ,bits)))
 	     (unless (= extra ,(1- elements-per-word))
 	       (inst and result ,(1- (ash 1 bits)))))))
        (define-vop (,(symbolicate 'data-vector-set/ type))

src/pcl/dlisp3.lisp

@@ -59,11 +59,6 @@
     (nil nil (class class) t)))
 ) ; EVAL-WHEN
 
-(defmacro make-checking-or-caching-function-list ()
-  `(list ,@(mapcar (lambda (key)
-		     `(cons ',key (emit-checking-or-caching-macro ,@key)))
-		   *checking-or-caching-list*)))
-
 ;;; Rather than compiling the constructors here, just tickle the range
 ;;; of shapes defined above, leaving the generation of the
 ;;; constructors to precompile-dfun-constructors.

src/pcl/init.lisp

@@ -41,8 +41,9 @@
   (let* ((info (initialize-info class initargs))
 	 (valid-p (initialize-info-valid-p info)))
     (when (and (consp valid-p) (eq (car valid-p) :invalid))
-      (error "Invalid initialization argument ~S for class ~S"
-	     (cdr valid-p) (class-name class))))
+      (error 'simple-program-error
+	     :format-control "Invalid initialization argument ~S for class ~S"
+	     :format-arguments (list (cdr valid-p) (class-name class)))))
   (let ((instance (apply #'allocate-instance class initargs)))
     (apply #'initialize-instance instance initargs)
     instance))
@@ -90,8 +91,9 @@
 	 (info (initialize-info class initargs))
 	 (valid-p (initialize-info-ri-valid-p info)))
     (when (and (consp valid-p) (eq (car valid-p) :invalid))
-      (error "Invalid initialization argument ~S for class ~S"
-	     (cdr valid-p) (class-name class))))
+      (error 'simple-program-error 
+	     :format-control "Invalid initialization argument ~S for class ~S"
+	     :format-arguments (list (cdr valid-p) (class-name class)))))
   (apply #'shared-initialize instance nil initargs)
   instance)
 
@@ -227,9 +229,9 @@
     (doplist (key val) initargs
       (unless (memq key legal)
 	(if error-p
-	    (error "Invalid initialization argument ~S for class ~S"
-		   key
-		   (class-name class))
+	    (error 'simple-program-error
+		   :format-control "Invalid initialization argument ~S for class ~S"
+		   :format-arguments (list key (class-name class)))
 	    (return-from check-initargs-2-plist nil)))))
   t)
 
@@ -240,9 +242,9 @@
     (dolist (key initkeys)
       (unless (memq key legal)
 	(if error-p
-	    (error "Invalid initialization argument ~S for class ~S"
-		   key
-		   (class-name class))
+	    (error 'simple-program-error
+		   :format-control "Invalid initialization argument ~S for class ~S"
+		   :format-arguments (list key (class-name class)))
 	    (return-from check-initargs-2-list nil)))))
   t)
 

src/pcl/std-class.lisp

@@ -375,6 +375,40 @@
 		  *the-class-standard-class*)
 		 (t
 		  (class-of class)))))
+    ;; KLUDGE: It seemed to me initially that there ought to be a way
+    ;; of collecting all the erroneous problems in one go, rather than
+    ;; this way of solving the problem of signalling the errors that
+    ;; we are required to, which stops at the first bogus input.
+    ;; However, after playing around a little, I couldn't find that
+    ;; way, so I've left it as is, but if someone does come up with a
+    ;; better way... -- CSR, 2002-09-08
+    (loop for (slot . more) on (getf initargs :direct-slots)
+	  for slot-name = (getf slot :name)
+	  if (some (lambda (s) (eq slot-name (getf s :name))) more) 
+	  ;; FIXME: It's quite possible that we ought to define an
+	  ;; SB-INT:PROGRAM-ERROR function to signal these and other
+	  ;; errors throughout the code base that are required to be
+	  ;; of type PROGRAM-ERROR.
+	  do (error 'simple-program-error 
+		    :format-control "More than one direct slot with name ~S."
+		    :format-arguments (list slot-name))
+	  else 
+	  do (loop for (option value . more) on slot by #'cddr
+		   when (and (member option 
+				     '(:allocation :type 
+				       :initform :documentation))
+			     (not (eq unsupplied
+				      (getf more option unsupplied)))) 
+		   do (error 'simple-program-error 
+			     :format-control "Duplicate slot option ~S for slot ~S."
+			     :format-arguments (list option slot-name))))
+    (loop for (initarg . more) on (getf initargs :direct-default-initargs)
+	  for name = (car initarg) 
+	  when (some (lambda (a) (eq (car a) name)) more) 
+	  do (error 'simple-program-error 
+		    :format-control "Duplicate initialization argument ~
+                                     name ~S in :default-initargs of class ~A."
+		    :format-arguments (list name class)))
     (loop (unless (remf initargs :metaclass) (return)))
     (loop (unless (remf initargs :direct-superclasses) (return)))
     (loop (unless (remf initargs :direct-slots) (return)))

tests/array.pure.lisp

@@ -62,3 +62,12 @@
 							 (aref x 12))))))
 	  (error "error not thrown in COMPILED-DECLARED-AREF ~S" form))))))
 
+;;; On the SPARC, until sbcl-0.7.7.20, there was a bug in array references 
+;;; for small vector elements (spotted by Raymond Toy).
+(assert (= (funcall 
+            (lambda (rmdr) 
+              (declare (type (simple-array bit (*)) rmdr)
+                       (optimize (speed 3) (safety 0)))
+              (aref rmdr 0))
+            #*00000000000000000000000000000001000000000)
+           0))

tests/clos.impure.lisp

@@ -277,6 +277,22 @@
 (defmethod gf (obj)
   obj)
 
+;;; Until sbcl-0.7.7.20, some conditions weren't being signalled, and
+;;; some others were of the wrong type:
+(macrolet ((assert-program-error (form)
+	     `(multiple-value-bind (value error)
+	          (ignore-errors ,form)
+	        (assert (null value))
+	        (assert (typep error 'program-error)))))
+  (assert-program-error (defclass foo001 () (a b a)))
+  (assert-program-error (defclass foo002 () 
+			  (a b) 
+			  (:default-initargs x 'a x 'b)))
+  (assert-program-error (defclass foo003 ()
+			  ((a :allocation :class :allocation :class))))
+  (assert-program-error (defclass foo004 ()
+			  ((a :silly t)))))
+
 ;;;; success
 
 (sb-ext:quit :unix-status 104)

version.lisp-expr

@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.7.19"
+"0.7.7.20"