X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=9f1eb0f748f7534def3306fa5064a09721cbef2a;hb=731d5dd65a7b94b5d49d1663d9b60c3a406ce38c;hp=1399a42e97fb92ae01e5739d6e6f93ded78f8cf1;hpb=771b864c8f32af7734bc0550aeaf1539fc4df194;p=sbcl.git

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 1399a42..9f1eb0f 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -91,8 +91,11 @@
     ;; and for all in any reasonable user programs.)
     ((t)
      (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
-    ((base-char standard-char)
+    ((base-char standard-char #!-sb-unicode character)
      (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits))
+    #!+sb-unicode
+    ((character)
+     (values #.sb!vm:simple-character-string-widetag #.sb!vm:n-word-bits))
     ((bit)
      (values #.sb!vm:simple-bit-vector-widetag 1))
     ;; OK, we have to wade into SUBTYPEPing after all.
@@ -110,8 +113,11 @@
     ;; Pick off some easy common cases.
     ((t)
      #.sb!vm:complex-vector-widetag)
-    ((base-char)
+    ((base-char #!-sb-unicode character)
      #.sb!vm:complex-base-string-widetag)
+    #!+sb-unicode
+    ((character)
+     #.sb!vm:complex-character-string-widetag)
     ((nil)
      #.sb!vm:complex-vector-nil-widetag)
     ((bit)
@@ -120,7 +126,12 @@
     (t
      (pick-vector-type type
        (nil #.sb!vm:complex-vector-nil-widetag)
+       #!-sb-unicode
+       (character #.sb!vm:complex-base-string-widetag)
+       #!+sb-unicode
        (base-char #.sb!vm:complex-base-string-widetag)
+       #!+sb-unicode
+       (character #.sb!vm:complex-character-string-widetag)
        (bit #.sb!vm:complex-bit-vector-widetag)
        (t #.sb!vm:complex-vector-widetag)))))
 
@@ -148,11 +159,15 @@
 		 (array (allocate-vector
 			 type
 			 length
-			 (ceiling (* (if (= type sb!vm:simple-base-string-widetag)
-					 (1+ length)
-					 length)
-				     n-bits)
-				  sb!vm:n-word-bits))))
+			 (ceiling
+			  (* (if (or (= type sb!vm:simple-base-string-widetag)
+                                     #!+sb-unicode
+                                     (= type
+                                        sb!vm:simple-character-string-widetag))
+                                 (1+ length)
+                                 length)
+                             n-bits)
+                          sb!vm:n-word-bits))))
 	    (declare (type index length))
 	    (when initial-element-p
 	      (fill array initial-element))
@@ -220,6 +235,51 @@
 	      (incf axis)))
 	  array))))
 
+(defun make-static-vector (length &key 
+			   (element-type '(unsigned-byte 8))
+			   (initial-contents nil initial-contents-p)
+			   (initial-element nil initial-element-p))
+  "Allocate vector of LENGTH elements in static space. Only allocation
+of specialized arrays is supported."
+  ;; STEP 1: check inputs fully
+  ;;
+  ;; This way of doing explicit checks before the vector is allocated
+  ;; is expensive, but probably worth the trouble as once we've allocated
+  ;; the vector we have no way to get rid of it anymore... 
+  (when (eq t (upgraded-array-element-type element-type))
+    (error "Static arrays of type ~S not supported." 
+	   element-type))
+  (when initial-contents-p
+    (when initial-element-p
+      (error "can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
+    (unless (= length (length initial-contents))
+      (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
+              vector length is ~W."
+	     (length initial-contents)
+	     length))
+    (unless (every (lambda (x) (typep x element-type)) initial-contents)
+      (error ":INITIAL-CONTENTS contains elements not of type ~S."
+	     element-type)))
+  (when initial-element-p
+    (unless (typep initial-element element-type)
+      (error ":INITIAL-ELEMENT ~S is not of type ~S." 
+	     initial-element element-type)))
+  ;; STEP 2
+  ;;
+  ;; Allocate and possibly initialize the vector.
+  (multiple-value-bind (type n-bits)
+      (sb!impl::%vector-widetag-and-n-bits element-type)
+    (let ((vector 
+	   (allocate-static-vector type length
+				   (ceiling (* length n-bits) 
+					    sb!vm:n-word-bits))))
+      (cond (initial-element-p
+	     (fill vector initial-element))
+	    (initial-contents-p
+	     (replace vector initial-contents))
+	    (t
+	     vector)))))
+
 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
 ;;; specified array characteristics. Dimensions is only used to pass
 ;;; to FILL-DATA-VECTOR for error checking on the structure of
@@ -318,6 +378,7 @@
 			sb!vm:*specialized-array-element-type-properties*)
 		       #'> :key #'sb!vm:saetp-importance)))))
 
+;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
 (defun %array-row-major-index (array subscripts
 				     &optional (invalid-index-error-p t))
   (declare (array array)
@@ -368,14 +429,17 @@
       t))
 
 (defun array-row-major-index (array &rest subscripts)
+  (declare (dynamic-extent subscripts))
   (%array-row-major-index array subscripts))
 
 (defun aref (array &rest subscripts)
   #!+sb-doc
   "Return the element of the ARRAY specified by the SUBSCRIPTS."
+  (declare (dynamic-extent subscripts))
   (row-major-aref array (%array-row-major-index array subscripts)))
 
 (defun %aset (array &rest stuff)
+  (declare (dynamic-extent stuff))
   (let ((subscripts (butlast stuff))
 	(new-value (car (last stuff))))
     (setf (row-major-aref array (%array-row-major-index array subscripts))
@@ -408,6 +472,7 @@
 
 #!-sb-fluid (declaim (inline (setf aref)))
 (defun (setf aref) (new-value array &rest subscripts)
+  (declare (dynamic-extent subscripts))
   (declare (type array array))
   (setf (row-major-aref array (%array-row-major-index array subscripts))
 	new-value))
@@ -854,7 +919,9 @@
 	  ,@(map 'list
 		 (lambda (saetp)
 		   `((simple-array ,(sb!vm:saetp-specifier saetp) (*))
-		     ,(if (eq (sb!vm:saetp-specifier saetp) 'base-char)
+		     ,(if (or (eq (sb!vm:saetp-specifier saetp) 'character)
+                              #!+sb-unicode
+			      (eq (sb!vm:saetp-specifier saetp) 'base-char))
 			  *default-init-char-form*
 			  (sb!vm:saetp-initial-element-default saetp))))
 		 (remove-if-not