made debugger handle errors in printing *DEBUG-CONDITION*

[sbcl.git] / src / code / array.lisp

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 603ad6e..4f03dfc 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -11,9 +11,6 @@
 
 (in-package "SB!IMPL")
 
-(file-comment
-  "$Header$")
-
 #!-sb-fluid
 (declaim (inline fill-pointer array-has-fill-pointer-p adjustable-array-p
                 array-displacement))
@@ -323,69 +320,50 @@
 \f
 ;;;; accessor/setter functions
 
+(eval-when (:compile-toplevel :execute)
+  (defparameter *specialized-array-element-types*
+    '(t
+      character
+      bit
+      (unsigned-byte 2)
+      (unsigned-byte 4)
+      (unsigned-byte 8)
+      (unsigned-byte 16)
+      (unsigned-byte 32)
+      (signed-byte 8)
+      (signed-byte 16)
+      (signed-byte 30)
+      (signed-byte 32)
+      single-float
+      double-float
+      #!+long-float long-float
+      (complex single-float)
+      (complex double-float)
+      #!+long-float (complex long-float))))
+    
 (defun hairy-data-vector-ref (array index)
   (with-array-data ((vector array) (index index) (end))
     (declare (ignore end) (optimize (safety 3)))
-    (macrolet ((dispatch (&rest stuff)
-                `(etypecase vector
-                   ,@(mapcar #'(lambda (type)
-                                 (let ((atype `(simple-array ,type (*))))
-                                   `(,atype
-                                     (data-vector-ref (the ,atype vector)
-                                                      index))))
-                             stuff))))
-      (dispatch
-       t
-       bit
-       character
-       (unsigned-byte 2)
-       (unsigned-byte 4)
-       (unsigned-byte 8)
-       (unsigned-byte 16)
-       (unsigned-byte 32)
-       (signed-byte 8)
-       (signed-byte 16)
-       (signed-byte 30)
-       (signed-byte 32)
-       single-float
-       double-float
-       #!+long-float long-float
-       (complex single-float)
-       (complex double-float)
-       #!+long-float (complex long-float)))))
+    (etypecase vector .
+              #.(mapcar (lambda (type)
+                          (let ((atype `(simple-array ,type (*))))
+                            `(,atype
+                              (data-vector-ref (the ,atype vector)
+                                               index))))
+                        *specialized-array-element-types*))))
 
 (defun hairy-data-vector-set (array index new-value)
   (with-array-data ((vector array) (index index) (end))
     (declare (ignore end) (optimize (safety 3)))
-    (macrolet ((dispatch (&rest stuff)
-                `(etypecase vector
-                   ,@(mapcar #'(lambda (type)
-                                 (let ((atype `(simple-array ,type (*))))
-                                   `(,atype
-                                     (data-vector-set (the ,atype vector)
-                                                      index
-                                                      (the ,type
-                                                           new-value)))))
-                             stuff))))
-      (dispatch
-       t
-       bit
-       character
-       (unsigned-byte 2)
-       (unsigned-byte 4)
-       (unsigned-byte 8)
-       (unsigned-byte 16)
-       (unsigned-byte 32)
-       (signed-byte 8)
-       (signed-byte 16)
-       (signed-byte 30)
-       (signed-byte 32)
-       single-float
-       double-float
-       #!+long-float long-float
-       (complex single-float)
-       (complex double-float)
-       #!+long-float (complex long-float)))))
+    (etypecase vector .
+              #.(mapcar (lambda (type)
+                          (let ((atype `(simple-array ,type (*))))
+                            `(,atype
+                              (data-vector-set (the ,atype vector)
+                                               index
+                                               (the ,type
+                                                 new-value)))))
+                        *specialized-array-element-types*))))
 
 (defun %array-row-major-index (array subscripts
                                     &optional (invalid-index-error-p t))
@@ -684,20 +662,20 @@
           (setf (%array-fill-pointer array) (1+ fill-pointer))
           fill-pointer))))
 
-(defun vector-push-extend (new-el array &optional
-                                 (extension (if (zerop (length array))
-                                                1
-                                                (length array))))
+(defun vector-push-extend (new-element
+                          vector
+                          &optional
+                          (extension (1+ (length vector))))
   #!+sb-doc
   "Like Vector-Push except that if the fill pointer gets too large, the
-   Array is extended rather than Nil being returned."
-  (declare (vector array) (fixnum extension))
-  (let ((fill-pointer (fill-pointer array)))
+   Vector is extended rather than Nil being returned."
+  (declare (vector vector) (fixnum extension))
+  (let ((fill-pointer (fill-pointer vector)))
     (declare (fixnum fill-pointer))
-    (when (= fill-pointer (%array-available-elements array))
-      (adjust-array array (+ fill-pointer extension)))
-    (setf (aref array fill-pointer) new-el)
-    (setf (%array-fill-pointer array) (1+ fill-pointer))
+    (when (= fill-pointer (%array-available-elements vector))
+      (adjust-array vector (+ fill-pointer extension)))
+    (setf (aref vector fill-pointer) new-element)
+    (setf (%array-fill-pointer vector) (1+ fill-pointer))
     fill-pointer))
 
 (defun vector-pop (array)
@@ -856,10 +834,10 @@
         (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S"
                fill-pointer))))
 
-(defun shrink-vector (vector new-size)
+(defun shrink-vector (vector new-length)
   #!+sb-doc
-  "Destructively alters the Vector, changing its length to New-Size, which
-   must be less than or equal to its current size."
+  "Destructively alter VECTOR, changing its length to NEW-LENGTH, which
+   must be less than or equal to its current length."
   (declare (vector vector))
   (unless (array-header-p vector)
     (macrolet ((frob (name &rest things)
@@ -868,7 +846,7 @@
                                  `(,(car thing)
                                    (fill (truly-the ,(car thing) ,name)
                                          ,(cadr thing)
-                                         :start new-size)))
+                                         :start new-length)))
                              things))))
       (frob vector
        (simple-vector 0)
@@ -896,7 +874,7 @@
         (coerce 0 '(complex long-float))))))
   ;; Only arrays have fill-pointers, but vectors have their length
   ;; parameter in the same place.
-  (setf (%array-fill-pointer vector) new-size)
+  (setf (%array-fill-pointer vector) new-length)
   vector)
 
 (defun set-array-header (array data length fill-pointer displacement dimensions