From bcbcc0d0660b3b3741203b3dfdd3443b201bf690 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 9 Sep 2002 08:45:55 +0000 Subject: [PATCH] 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 | 12 ------------ NEWS | 2 ++ src/compiler/sparc/array.lisp | 6 +++--- src/pcl/dlisp3.lisp | 5 ----- src/pcl/init.lisp | 22 ++++++++++++---------- src/pcl/std-class.lisp | 34 ++++++++++++++++++++++++++++++++++ tests/array.pure.lisp | 9 +++++++++ tests/clos.impure.lisp | 16 ++++++++++++++++ version.lisp-expr | 2 +- 9 files changed, 77 insertions(+), 31 deletions(-) diff --git a/BUGS b/BUGS index a4cf1a8..60c6505 100644 --- a/BUGS +++ b/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: diff --git a/NEWS b/NEWS index 08a464c..0300b56 100644 --- a/NEWS +++ b/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 diff --git a/src/compiler/sparc/array.lisp b/src/compiler/sparc/array.lisp index b40e455..eac0f62 100644 --- a/src/compiler/sparc/array.lisp +++ b/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)) diff --git a/src/pcl/dlisp3.lisp b/src/pcl/dlisp3.lisp index c3209ac..0cef2d6 100644 --- a/src/pcl/dlisp3.lisp +++ b/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. diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 9614439..9d84f31 100644 --- a/src/pcl/init.lisp +++ b/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) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 3a7da7b..f79a78c 100644 --- a/src/pcl/std-class.lisp +++ b/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))) diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp index 8a65351..65a8a60 100644 --- a/tests/array.pure.lisp +++ b/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)) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 60815d0..d3a76aa 100644 --- a/tests/clos.impure.lisp +++ b/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) diff --git a/version.lisp-expr b/version.lisp-expr index 6a310bc..cc51d59 100644 --- a/version.lisp-expr +++ b/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" -- 1.7.10.4