From 77a5cd8fb0a23018f4b91df14739302b25023567 Mon Sep 17 00:00:00 2001
From: emarsden <emarsden>
Date: Mon, 24 Feb 2003 10:07:00 +0000
Subject: [PATCH] Change a number of error conditions signaled by the array
 routines from generic errors to conditions of type PROGRAM-ERROR.

---
 code/array.lisp | 64 ++++++++++++++++++++++++++-----------------------
 1 file changed, 34 insertions(+), 30 deletions(-)

diff --git a/code/array.lisp b/code/array.lisp
index ba7aac762..6be1d29b6 100644
--- a/code/array.lisp
+++ b/code/array.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.33 2002/07/10 16:15:58 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.34 2003/02/24 10:07:00 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -387,7 +387,7 @@
 	   (list subscripts))
   (let ((rank (array-rank array)))
     (unless (= rank (length subscripts))
-      (error "Wrong number of subscripts, ~D, for array of rank ~D"
+      (simple-program-error "Wrong number of subscripts, ~D, for array of rank ~D"
 	     (length subscripts) rank))
     (if (array-header-p array)
 	(do ((subs (nreverse subscripts) (cdr subs))
@@ -401,7 +401,7 @@
 	    (declare (fixnum index dim))
 	    (unless (< -1 index dim)
 	      (if invalid-index-error-p
-		  (error "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S"
+		  (simple-program-error "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S"
 			 index axis array)
 		  (return-from %array-row-major-index nil)))
 	    (incf result (* chunk-size index))
@@ -409,7 +409,7 @@
 	(let ((index (first subscripts)))
 	  (unless (< -1 index (length (the (simple-array * (*)) array)))
 	    (if invalid-index-error-p
-		(error "Invalid index ~D in ~S" index array)
+		(simple-program-error "Invalid index ~D in ~S" index array)
 		(return-from %array-row-major-index nil)))
 	  index))))
 
@@ -561,10 +561,10 @@
   (declare (array array) (type index axis-number))
   (cond ((not (array-header-p array))
 	 (unless (= axis-number 0)
-	   (error "Vector axis is not zero: ~S" axis-number))
+	   (simple-program-error "Vector axis is not zero: ~S" axis-number))
 	 (length (the (simple-array * (*)) array)))
 	((>= axis-number (%array-rank array))
-	 (error "~D is too big; ~S only has ~D dimension~:P"
+	 (simple-program-error "~D is too big; ~S only has ~D dimension~:P"
 		axis-number array (%array-rank array)))
 	(t
 	 (%array-dimension array axis-number))))
@@ -624,8 +624,9 @@
   (declare (vector vector) (fixnum new))
   (if (and (array-header-p vector) (%array-fill-pointer-p vector))
       (if (> new (%array-available-elements vector))
-	(error "New fill pointer, ~S, is larger than the length of the vector."
-	       new)
+	(simple-program-error
+         "New fill pointer, ~S, is larger than the length of the vector."
+         new)
 	(setf (%array-fill-pointer vector) new))
       (error 'simple-type-error
 	     :datum vector
@@ -671,7 +672,7 @@
   (let ((fill-pointer (fill-pointer array)))
     (declare (fixnum fill-pointer))
     (if (zerop fill-pointer)
-	(error "Nothing left to pop.")
+	(simple-program-error "Nothing left to pop.")
 	(aref array
 	      (setf (%array-fill-pointer array)
 		    (1- fill-pointer))))))
@@ -688,18 +689,18 @@
   (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
     (cond ((/= (the fixnum (length (the list dimensions)))
 	       (the fixnum (array-rank array)))
-	   (error "Number of dimensions not equal to rank of array."))
+	   (simple-program-error "Number of dimensions not equal to rank of array."))
 	  ((not (subtypep element-type (array-element-type array)))
-	   (error "New element type, ~S, is incompatible with old."
+	   (simple-program-error "New element type, ~S, is incompatible with old."
 		  element-type)))
     (let ((array-rank (length (the list dimensions))))
       (declare (fixnum array-rank))
       (when (and fill-pointer (> array-rank 1))
-	(error "Multidimensional arrays can't have fill pointers."))
+	(simple-program-error "Multidimensional arrays can't have fill pointers."))
       (cond (initial-contents
 	     ;; Array former contents replaced by initial-contents.
 	     (if (or initial-element-p displaced-to)
-		 (error "Initial contents may not be specified with ~
+		 (simple-program-error "Initial contents may not be specified with ~
 		 the :initial-element or :displaced-to option."))
 	     (let* ((array-size (apply #'* dimensions))
 		    (array-data (data-vector-from-inits
@@ -720,10 +721,10 @@
 	    (displaced-to
 	     ;; No initial-contents supplied is already established.
 	     (when initial-element
-	       (error "The :initial-element option may not be specified ~
+	       (simple-program-error "The :initial-element option may not be specified ~
 	       with :displaced-to."))
 	     (unless (subtypep element-type (array-element-type displaced-to))
-	       (error "One can't displace an array of type ~S into another of ~
+	       (simple-program-error "One can't displace an array of type ~S into another of ~
 	               type ~S."
 		      element-type (array-element-type displaced-to)))
 	     (let ((displacement (or displaced-index-offset 0))
@@ -731,7 +732,7 @@
 	       (declare (fixnum displacement array-size))
 	       (if (< (the fixnum (array-total-size displaced-to))
 		      (the fixnum (+ displacement array-size)))
-		   (error "The :displaced-to array is too small."))
+		   (simple-program-error "The :displaced-to array is too small."))
 	       (if (adjustable-array-p array)
 		   ;; None of the original contents appear in adjusted array.
 		   (set-array-header array displaced-to array-size
@@ -802,27 +803,30 @@
   (cond ((not fill-pointer)
 	 (when (array-has-fill-pointer-p old-array)
 	   (when (> (%array-fill-pointer old-array) new-array-size)
-	     (error "Cannot adjust-array an array (~S) to a size (~S) that is ~
+	     (simple-program-error
+                    "Cannot adjust-array an array (~S) to a size (~S) that is ~
 	            smaller than it's fill pointer (~S)."
 		    old-array new-array-size (fill-pointer old-array)))
 	   (%array-fill-pointer old-array)))
 	((not (array-has-fill-pointer-p old-array))
-	 (error "Cannot supply a non-NIL value (~S) for :fill-pointer ~
-		        in adjust-array unless the array (~S) was originally ~
- 			created with a fill pointer."
-		       fill-pointer
-		       old-array))
+	 (simple-program-error
+          "Cannot supply a non-NIL value (~S) for :fill-pointer ~
+	   in adjust-array unless the array (~S) was originally ~
+ 	   created with a fill pointer."
+          fill-pointer
+          old-array))
 	((numberp fill-pointer)
 	 (when (> fill-pointer new-array-size)
-	   (error "Cannot supply a value for :fill-pointer (~S) that is larger ~
-	          than the new length of the vector (~S)."
-		  fill-pointer new-array-size))
+	   (simple-program-error
+            "Cannot supply a value for :fill-pointer (~S) that is larger ~
+	     than the new length of the vector (~S)."
+            fill-pointer new-array-size))
 	 fill-pointer)
 	((eq fill-pointer t)
 	 new-array-size)
 	(t
-	 (error "Bogus value for :fill-pointer in adjust-array: ~S"
-		fill-pointer))))
+	 (simple-program-error "Bogus value for :fill-pointer in adjust-array: ~S"
+                               fill-pointer))))
 
 (defun shrink-vector (vector new-size)
   "Destructively alters the Vector, changing its length to New-Size, which
@@ -902,7 +906,7 @@
 	  (make-array length :initial-element t)))
   (when initial-element-p
     (unless (typep initial-element element-type)
-      (error "~S cannot be used to initialize an array of type ~S."
+      (simple-program-error "~S cannot be used to initialize an array of type ~S."
 	     initial-element element-type))
     (fill (the simple-vector *zap-array-data-temp*) initial-element
 	  :end length))
@@ -997,7 +1001,7 @@
     (t
      (unless (bit-array-same-dimensions-p bit-array-1
 					  result-bit-array)
-       (error "~S and ~S do not have the same dimensions."
+       (simple-program-error "~S and ~S do not have the same dimensions."
 	      bit-array-1 result-bit-array))
      result-bit-array)))
 
@@ -1013,7 +1017,7 @@
      (declare (type (array bit) bit-array-1 bit-array-2)
 	      (type (or (array bit) (member t nil)) result-bit-array))
      (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
-       (error "~S and ~S do not have the same dimensions."
+       (simple-program-error "~S and ~S do not have the same dimensions."
 	      bit-array-1 bit-array-2))
      (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
        (if (and (simple-bit-vector-p bit-array-1)
-- 
GitLab