From e43ebe3057bd62a58987b22f53c386ca7f5740f8 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 4 Nov 2002 14:59:35 +0000 Subject: [PATCH] 0.7.9.29: Ensure that ELT signals an error of type TYPE-ERROR when its index is too big or too small ... make the internal error signal a SIMPLE-TYPE-ERROR ... make %ARRAY-ROW-MAJOR-INDEX signal TYPE-ERRORs where appropriate ... also fix END-TOO-LARGE-ERROR Implement some AMOP Class readers on FORWARD-REFERENCED-CLASSES as per Gerd Moellmann cmucl-imp 2002-10-28 ... but with nicer format strings --- NEWS | 32 ++++++++++++++++++++++---------- src/code/array.lisp | 21 ++++++++++++++++----- src/code/condition.lisp | 7 ++++++- src/code/interr.lisp | 6 ++++-- src/code/seq.lisp | 2 +- src/pcl/std-class.lisp | 11 +++++++++++ tests/mop.impure.lisp | 7 +++++++ tests/seq.impure.lisp | 10 ++++++++++ version.lisp-expr | 2 +- 9 files changed, 78 insertions(+), 20 deletions(-) diff --git a/NEWS b/NEWS index 739f51d..01fdb25 100644 --- a/NEWS +++ b/NEWS @@ -1357,16 +1357,28 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9: primary methods with no specializers; ** the MOP generic function GENERIC-FUNCTION-DECLARATIONS is now implemented; - * fixed some bugs, shown by Paul Dietz' test suite: - ** DOLIST puts its body in TAGBODY - ** SET-EXCLUSIVE-OR sends arguments to :TEST function in the - correct order - ** MULTIPLE-VALUE-SETQ evaluates side-effectful places before - value producing form - ** if more variables are given to PROGV than values, extra - variables are bound and made to have no value - * fixed bug 166: compiler preserves "there is a way to go" - invariant when deleting code + ** the Readers for Class Metaobjects methods CLASS-DIRECT-SLOTS + and CLASS-DIRECT-DEFAULT-INITARGS have been implemented for + FORWARD-REFERENCED-CLASSes; error reporting on + CLASS-DEFAULT-INITARGS, CLASS-PRECEDENCE-LIST and CLASS-SLOTS + has been improved; + * fixed some bugs, shown by Paul Dietz' test suite: + ** DOLIST puts its body in TAGBODY + ** SET-EXCLUSIVE-OR sends arguments to :TEST function in the + correct order + ** MULTIPLE-VALUE-SETQ evaluates side-effectful places before + value producing form + ** if more variables are given to PROGV than values, extra + variables are bound and made to have no value + ** NSUBSTITUTE on list arguments gets the right answer with + :FROM-END + ** ELT signals an error of type TYPE-ERROR when the index argument + is not a valid sequence index; + * fixed bug 166: compiler preserves "there is a way to go" + invariant when deleting code. + * fixed bug 172: macro lambda lists with required arguments after + &REST arguments now cause an error to be signalled. (thanks to + Matthew Danish) planned incompatible changes in 0.7.x: * When the profiling interface settles down, maybe in 0.7.x, maybe diff --git a/src/code/array.lisp b/src/code/array.lisp index f4791de..10f81e8 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -378,15 +378,26 @@ (declare (fixnum index dim)) (unless (< -1 index dim) (if invalid-index-error-p - (error "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S" - index axis array) + (error 'simple-type-error + :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S" + :format-arguments (list index axis array) + :datum index + :expected-type `(integer 0 (,dim))) (return-from %array-row-major-index nil))) (incf result (* chunk-size index)) (setf chunk-size (* chunk-size dim)))) - (let ((index (first subscripts))) - (unless (< -1 index (length (the (simple-array * (*)) array))) + (let ((index (first subscripts)) + (length (length (the (simple-array * (*)) array)))) + (unless (< -1 index length) (if invalid-index-error-p - (error "invalid index ~W in ~S" index array) + ;; FIXME: perhaps this should share a format-string + ;; with INVALID-ARRAY-INDEX-ERROR or + ;; INDEX-TOO-LARGE-ERROR? + (error 'simple-type-error + :format-control "invalid index ~W in ~S" + :format-arguments (list index array) + :datum index + :expected-type `(integer 0 (,length))) (return-from %array-row-major-index nil))) index)))) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 1e5c7c7..428c7dd 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -691,7 +691,12 @@ ;;; Out-of-range &KEY END arguments are similar to, but off by one ;;; from out-of-range indices into the sequence. -(define-condition index-too-large-error (type-error) +;;; +;;; FIXME: Uh, but it isn't used for &KEY END things -- in fact, this +;;; is only used in one place, in SUBSEQ. Is it really necessary? Is +;;; it here so that we can actually go round seq.lisp decorating all +;;; the sequence functions with extra checks? -- CSR, 2002-11-01 +(define-condition end-too-large-error (type-error) () (:report (lambda (condition stream) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 0e7cde6..4ee10ee 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -250,10 +250,12 @@ :format-arguments (list key-name))) (deferr invalid-array-index-error (array bound index) - (error 'simple-error + (error 'simple-type-error :format-control "invalid array index ~W for ~S (should be nonnegative and <~W)" - :format-arguments (list index array bound))) + :format-arguments (list index array bound) + :datum index + :expected-type `(integer 0 (,bound)))) (deferr object-not-simple-array-error (object) (error 'type-error diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 0c9448b..fe09338 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -246,7 +246,7 @@ (if (null end) (setf end (length sequence)) (unless (<= end (length sequence)) - (signal-index-too-large-error sequence end))) + (signal-end-too-large-error sequence end))) (do ((old-index start (1+ old-index)) (new-index 0 (1+ new-index)) (copy (make-sequence-like sequence (- end start)))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index cfa1c62..5e5f933 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -1306,6 +1306,17 @@ (or (eq s *the-class-t*) (eq s *the-class-stream*))) +;;; Some necessary methods for FORWARD-REFERENCED-CLASS +(defmethod class-direct-slots ((class forward-referenced-class)) ()) +(defmethod class-direct-default-initargs ((class forward-referenced-class)) ()) +(macrolet ((def (method) + `(defmethod ,method ((class forward-referenced-class)) + (error "~@<~I~S was called on a forward referenced class:~2I~_~S~:>" + ',method class)))) + (def class-default-initargs) + (def class-precedence-list) + (def class-slots)) + (defmethod validate-superclass ((c slot-class) (f forward-referenced-class)) t) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 84a7e32..e038b6c 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -22,6 +22,13 @@ (in-package "MOP-TEST") +;;; Readers for Class Metaobjects (pp. 212--214 of AMOP) +(defclass red-herring (forward-ref) ()) + +(assert (null (sb-pcl:class-direct-slots (sb-pcl:find-class 'forward-ref)))) +(assert (null (sb-pcl:class-direct-default-initargs + (sb-pcl:find-class 'forward-ref)))) + ;;; Readers for Generic Function Metaobjects (pp. 216--218 of AMOP) (defgeneric fn-with-odd-arg-precedence (a b c) (:argument-precedence-order b c a)) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index dc5a6e3..4ed1cf4 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -326,5 +326,15 @@ ;; the analogous type checking for MAP/%MAP. )) +;;; ELT should signal an error of type TYPE-ERROR if its index +;;; argument isn't a valid sequence index for sequence: +(defun test-elt-signal (x) + (elt x 3)) +(multiple-value-bind (result error) + (ignore-errors (test-elt-signal "foo")) + (assert (null result)) + (assert (typep error 'type-error))) +(assert (eql (test-elt-signal "foob") #\b)) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 2cac6a9..d7be55c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.9.28" +"0.7.9.29" -- 1.7.10.4