0.8.0.42:

[sbcl.git] / src / compiler / array-tran.lisp

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 9e04f7e..724440d 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -58,7 +58,8 @@
    array
    (make-array-type :complexp t
                     :element-type *wild-type*)
-   (lexenv-policy (node-lexenv (continuation-dest array)))))
+   (lexenv-policy (node-lexenv (continuation-dest array))))
+  nil)
 
 ;;; Return true if ARG is NIL, or is a constant-continuation whose
 ;;; value is NIL, false otherwise.
@@ -187,13 +188,13 @@
         ,n-vec))))
 
 ;;; Just convert it into a MAKE-ARRAY.
-(define-source-transform make-string (length &key
-                                            (element-type ''base-char)
-                                            (initial-element
-                                             '#.*default-init-char-form*))
-  `(make-array (the index ,length)
-              :element-type ,element-type
-              :initial-element ,initial-element))
+(deftransform make-string ((length &key
+                                  (element-type 'base-char)
+                                  (initial-element
+                                   #.*default-init-char-form*)))
+  '(make-array (the index length)
+               :element-type element-type
+               :initial-element initial-element))
 
 (defstruct (specialized-array-element-type-properties
            (:conc-name saetp-)
@@ -227,7 +228,10 @@
         (destructuring-bind (type-spec &rest rest) args
           (let ((ctype (specifier-type type-spec)))
             (apply #'!make-saetp ctype rest))))
-       `((base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag
+       `(;; Erm.  Yeah.  There aren't a lot of things that make sense
+        ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07
+        (nil '#:mu 0 ,sb!vm:simple-array-nil-widetag)
+        (base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag
                    ;; (SIMPLE-STRINGs are stored with an extra trailing
                    ;; #\NULL for convenience in calling out to C.)
                    :n-pad-elements 1)
@@ -366,14 +370,17 @@
                                   'length
                                   `(+ length ,n-pad-elements)))
           (n-words-form
-           (if (>= n-bits-per-element sb!vm:n-word-bits)
-               `(* ,padded-length-form
-                   (the fixnum ; i.e., not RATIO
-                     ,(/ n-bits-per-element sb!vm:n-word-bits)))
-               (let ((n-elements-per-word (/ sb!vm:n-word-bits
-                                             n-bits-per-element)))
-                 (declare (type index n-elements-per-word)) ; i.e., not RATIO
-                 `(ceiling ,padded-length-form ,n-elements-per-word)))))
+           (cond
+             ((= n-bits-per-element 0) 0)
+             ((>= n-bits-per-element sb!vm:n-word-bits)
+              `(* ,padded-length-form
+                (the fixnum ; i.e., not RATIO
+                  ,(/ n-bits-per-element sb!vm:n-word-bits))))
+             (t
+              (let ((n-elements-per-word (/ sb!vm:n-word-bits
+                                            n-bits-per-element)))
+                (declare (type index n-elements-per-word)) ; i.e., not RATIO
+                `(ceiling ,padded-length-form ,n-elements-per-word))))))
       (values
        `(truly-the ,result-type-spec
         (allocate-vector ,typecode length ,n-words-form))
@@ -502,9 +509,10 @@
 
 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
 ;;; compile-time constant.
-(deftransform vector-length ((vector) ((simple-array * (*))))
+(deftransform vector-length ((vector))
   (let ((vtype (continuation-type vector)))
-    (if (array-type-p vtype)
+    (if (and (array-type-p vtype)
+            (not (array-type-complexp vtype)))
        (let ((dim (first (array-type-dimensions vtype))))
          (when (eq dim '*) (give-up-ir1-transform))
          dim)
@@ -620,10 +628,7 @@
                                   (element-type '*)
                                   unsafe?
                                   fail-inline?)
-  (let ((size (gensym "SIZE-"))
-       (defaulted-end (gensym "DEFAULTED-END-"))
-       (data (gensym "DATA-"))
-       (cumulative-offset (gensym "CUMULATIVE-OFFSET-")))
+  (with-unique-names (size defaulted-end data cumulative-offset)
     `(let* ((,size (array-total-size ,array))
            (,defaulted-end
              (cond (,end
@@ -683,11 +688,17 @@
                  `(aref (the ,',type ,a) ,@i))
                (define-source-transform ,setter (a &rest i)
                  `(%aset (the ,',type ,a) ,@i)))))
-  (define-frob svref %svset simple-vector)
-  (define-frob schar %scharset simple-string)
-  (define-frob char %charset string)
   (define-frob sbit %sbitset (simple-array bit))
   (define-frob bit %bitset (array bit)))
+(macrolet ((define-frob (reffer setter type)
+            `(progn
+               (define-source-transform ,reffer (a i)
+                 `(aref (the ,',type ,a) ,i))
+               (define-source-transform ,setter (a i v)
+                 `(%aset (the ,',type ,a) ,i ,v)))))
+  (define-frob svref %svset simple-vector)
+  (define-frob schar %scharset simple-string)
+  (define-frob char %charset string))
 
 (macrolet (;; This is a handy macro for computing the row-major index
           ;; given a set of indices. We wrap each index with a call
@@ -811,7 +822,7 @@
       (cond ((csubtypep type (specifier-type '(simple-array * (*))))
             ;; no array header
             nil)
-           ((and (listp dims) (> (length dims) 1))
+           ((and (listp dims) (/= (length dims) 1))
             ;; multi-dimensional array, will have a header
             t)
            (t