Add STDCALL alien convention support for Windows

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

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 8a4ddfe..7122723 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -133,6 +133,28 @@
        (bit #.sb!vm:complex-bit-vector-widetag)
        (t #.sb!vm:complex-vector-widetag)))))
 
+(defglobal %%simple-array-n-bits%% (make-array (1+ sb!vm:widetag-mask)))
+#.(loop for info across sb!vm:*specialized-array-element-type-properties*
+        collect `(setf (aref %%simple-array-n-bits%% ,(sb!vm:saetp-typecode info))
+                       ,(sb!vm:saetp-n-bits info)) into forms
+        finally (return `(progn ,@forms)))
+
+(defun allocate-vector-with-widetag (widetag length &optional n-bits)
+  (declare (type (unsigned-byte 8) widetag)
+           (type index length))
+  (let ((n-bits (or n-bits (aref %%simple-array-n-bits%% widetag))))
+    (declare (type (integer 0 256) n-bits))
+    (allocate-vector widetag length
+                     (ceiling
+                      (* (if (or (= widetag sb!vm:simple-base-string-widetag)
+                                 #!+sb-unicode
+                                 (= widetag
+                                    sb!vm:simple-character-string-widetag))
+                             (1+ length)
+                             length)
+                         n-bits)
+                      sb!vm:n-word-bits))))
+
 (defun make-array (dimensions &key
                               (element-type t)
                               (initial-element nil initial-element-p)
@@ -159,18 +181,7 @@
           (declare (type (unsigned-byte 8) type)
                    (type (integer 0 256) n-bits))
           (let* ((length (car dimensions))
-                 (array (allocate-vector
-                         type
-                         length
-                         (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))))
+                 (array (allocate-vector-with-widetag type length n-bits)))
             (declare (type index length))
             (when initial-element-p
               (fill array initial-element))
@@ -189,7 +200,7 @@
         (let* ((total-size (reduce #'* dimensions))
                (data (or displaced-to
                          (data-vector-from-inits
-                          dimensions total-size element-type
+                          dimensions total-size element-type nil
                           initial-contents initial-contents-p
                           initial-element initial-element-p)))
                (array (make-array-header
@@ -289,18 +300,23 @@ of specialized arrays is supported."
 ;;; specified array characteristics. Dimensions is only used to pass
 ;;; to FILL-DATA-VECTOR for error checking on the structure of
 ;;; initial-contents.
-(defun data-vector-from-inits (dimensions total-size element-type
+(defun data-vector-from-inits (dimensions total-size
+                               element-type widetag
                                initial-contents initial-contents-p
                                initial-element initial-element-p)
   (when (and initial-contents-p initial-element-p)
     (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
             either MAKE-ARRAY or ADJUST-ARRAY."))
-  (let ((data (if initial-element-p
-                  (make-array total-size
-                              :element-type element-type
-                              :initial-element initial-element)
-                  (make-array total-size
-                              :element-type element-type))))
+  (let ((data (cond
+                (widetag
+                 (allocate-vector-with-widetag widetag total-size))
+                (initial-element-p
+                 (make-array total-size
+                             :element-type element-type
+                             :initial-element initial-element))
+                (t
+                 (make-array total-size
+                             :element-type element-type)))))
     (cond (initial-element-p
            (unless (simple-vector-p data)
              (unless (typep initial-element element-type)
@@ -871,7 +887,7 @@ of specialized arrays is supported."
 ;;;; ADJUST-ARRAY
 
 (defun adjust-array (array dimensions &key
-                           (element-type (array-element-type array))
+                           (element-type (array-element-type array) element-type-p)
                            (initial-element nil initial-element-p)
                            (initial-contents nil initial-contents-p)
                            fill-pointer
@@ -884,7 +900,8 @@ of specialized arrays is supported."
     (cond ((/= (the fixnum (length (the list dimensions)))
                (the fixnum (array-rank array)))
            (error "The number of dimensions not equal to rank of array."))
-          ((not (subtypep element-type (array-element-type array)))
+          ((and element-type-p
+                (not (subtypep element-type (array-element-type array))))
            (error "The new element type, ~S, is incompatible with old type."
                   element-type))
           ((and fill-pointer (not (array-has-fill-pointer-p array)))
@@ -903,7 +920,7 @@ of specialized arrays is supported."
                          the :INITIAL-ELEMENT or :DISPLACED-TO option."))
              (let* ((array-size (apply #'* dimensions))
                     (array-data (data-vector-from-inits
-                                 dimensions array-size element-type
+                                 dimensions array-size element-type nil
                                  initial-contents initial-contents-p
                                  initial-element initial-element-p)))
                (if (adjustable-array-p array)
@@ -957,9 +974,13 @@ of specialized arrays is supported."
                         (setf new-data
                               (data-vector-from-inits
                                dimensions new-length element-type
+                               (widetag-of old-data)
                                initial-contents initial-contents-p
                                initial-element initial-element-p))
+                        ;; Provide :END1 to avoid full call to LENGTH
+                        ;; inside REPLACE.
                         (replace new-data old-data
+                                 :end1 new-length
                                  :start2 old-start :end2 old-end))
                        (t (setf new-data
                                 (shrink-vector old-data new-length))))
@@ -981,7 +1002,8 @@ of specialized arrays is supported."
                                          (> new-length old-length))
                                      (data-vector-from-inits
                                       dimensions new-length
-                                      element-type () nil
+                                      element-type
+                                      (widetag-of old-data) () nil
                                       initial-element initial-element-p)
                                      old-data)))
                    (if (or (zerop old-length) (zerop new-length))