X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=4f03dfc15b2d12e55fb52d25f7afd4ed1fab4562;hb=5dc28680e9cb2d598da02aed512aa49ea81fdade;hp=603ad6e1c7b47967d43137bb6aa8c1a7d7fdd168;hpb=06cb0db045562ab583358e2ee7090c606e1dfe42;p=sbcl.git

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 603ad6e..4f03dfc 100644
--- 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 @@
 
 ;;;; 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