Fix WITH-STATIC-VECTOR when used with non-const element-type

src/constantp.lisp

@@ -39,12 +39,12 @@
          (length-spec (if (constantp length env)
                           `,(eval-constant length env)
                           '*))
-         (type-decl (if (eql '* element-type)
+         (type-decl (if (eql '* eltype-spec)
                         'simple-array
                         `(simple-array ,eltype-spec (,length-spec)))))
     (values (if (eql '* eltype-spec)
                 element-type
-                eltype-spec)
+                `(quote ,eltype-spec))
             (if (eql '* length-spec)
                 length
                 length-spec)

src/impl-abcl.lisp

@@ -83,12 +83,12 @@ VECTOR must be a vector created by MAKE-STATIC-VECTOR."
   "Bind PTR-VAR to a static vector of length LENGTH and execute BODY
 within its dynamic extent. The vector is freed upon exit."
   (declare (ignorable element-type initial-contents initial-element))
-  (multiple-value-bind (real-element-type length type)
+  (multiple-value-bind (real-element-type length type-spec)
       (canonicalize-args env element-type length)
     (remf args :element-type)
     `(let ((,var (make-static-vector ,length ,@args
-                                     :element-type ',real-element-type)))
-       ,.(if type `((declare (type ,type ,var))) nil)
+                                     :element-type ,real-element-type)))
+       (declare (type ,type-spec ,var))
        (unwind-protect
             (locally ,@body)
          (when ,var (free-static-vector ,var))))))

src/impl-allegro.lisp

@@ -42,12 +42,12 @@ VECTOR must be a vector created by MAKE-STATIC-VECTOR."
   "Bind PTR-VAR to a static vector of length LENGTH and execute BODY
 within its dynamic extent. The vector is freed upon exit."
   (declare (ignorable element-type initial-contents initial-element))
-  (multiple-value-bind (real-element-type length type)
+  (multiple-value-bind (real-element-type length type-spec)
       (canonicalize-args env element-type length)
     (remf args :element-type)
     `(let ((,var (make-static-vector ,length ,@args
-                                     :element-type ',real-element-type)))
-       ,.(if type `((declare (type ,type ,var))) nil)
+                                     :element-type ,real-element-type)))
+       (declare (type ,type-spec ,var))
        (unwind-protect
             (locally ,@body)
          (when ,var (free-static-vector ,var))))))

src/impl-clasp.lisp

@@ -47,12 +47,12 @@ VECTOR must be a vector created by MAKE-STATIC-VECTOR."
   "Bind PTR-VAR to a static vector of length LENGTH and execute BODY
 within its dynamic extent. The vector is freed upon exit."
   (declare (ignorable element-type initial-contents initial-element))
-  (multiple-value-bind (real-element-type length type)
+  (multiple-value-bind (real-element-type length type-spec)
       (canonicalize-args env element-type length)
     (remf args :element-type)
     `(let ((,var (make-static-vector ,length ,@args
-                                     :element-type ',real-element-type)))
-       ,.(if type `((declare (type ,type ,var))) nil)
+                                     :element-type ,real-element-type)))
+       (declare (type ,type-spec ,var))
        (unwind-protect
             (locally ,@body)
          (when ,var (free-static-vector ,var))))))

src/impl-clozure.lisp

@@ -44,12 +44,12 @@ VECTOR must be a vector created by MAKE-STATIC-VECTOR."
   "Bind PTR-VAR to a static vector of length LENGTH and execute BODY
 within its dynamic extent. The vector is freed upon exit."
   (declare (ignorable element-type initial-contents initial-element))
-  (multiple-value-bind (real-element-type length type)
+  (multiple-value-bind (real-element-type length type-spec)
       (canonicalize-args env element-type length)
     (remf args :element-type)
     `(let ((,var (make-static-vector ,length ,@args
-                                     :element-type ',real-element-type)))
-       ,.(if type `((declare (type ,type ,var))) nil)
+                                     :element-type ,real-element-type)))
+       (declare (type ,type-spec ,var))
        (unwind-protect
             (locally ,@body)
          (when ,var (free-static-vector ,var))))))

src/impl-cmucl.lisp

@@ -42,10 +42,10 @@ VECTOR must be a vector created by MAKE-STATIC-VECTOR."
   "Bind PTR-VAR to a static vector of length LENGTH and execute BODY
 within its dynamic extent. The vector is freed upon exit."
   (declare (ignorable element-type initial-contents initial-element))
-  (multiple-value-bind (real-element-type length type)
+  (multiple-value-bind (real-element-type length type-spec)
       (canonicalize-args env element-type length)
     (remf args :element-type)
     `(let ((,var (make-static-vector ,length ,@args
-                                     :element-type ',real-element-type)))
-       ,.(if type `((declare (type ,type ,var))) nil)
+                                     :element-type ,real-element-type)))
+       (declare (type ,type-spec ,var))
        ,@body)))

src/impl-ecl.lisp

@@ -49,10 +49,10 @@ VECTOR must be a vector created by MAKE-STATIC-VECTOR."
   "Bind PTR-VAR to a static vector of length LENGTH and execute BODY
 within its dynamic extent. The vector is freed upon exit."
   (declare (ignorable element-type initial-contents initial-element))
-  (multiple-value-bind (real-element-type length type)
+  (multiple-value-bind (real-element-type length type-spec)
       (canonicalize-args env element-type length)
     (remf args :element-type)
     `(let ((,var (make-static-vector ,length ,@args
-                                     :element-type ',real-element-type)))
-       ,.(if type `((declare (type ,type ,var))) nil)
+                                     :element-type ,real-element-type)))
+       (declare (type ,type-spec ,var))
        ,@body)))

src/impl-lispworks.lisp

@@ -43,10 +43,10 @@ VECTOR must be a vector created by MAKE-STATIC-VECTOR."
   "Bind PTR-VAR to a static vector of length LENGTH and execute BODY
 within its dynamic extent. The vector is freed upon exit."
   (declare (ignorable element-type initial-contents initial-element))
-  (multiple-value-bind (real-element-type length type)
+  (multiple-value-bind (real-element-type length type-spec)
       (canonicalize-args env element-type length)
     (remf args :element-type)
     `(let ((,var (make-static-vector ,length ,@args
-                                     :element-type ',real-element-type)))
-       ,.(if type `((declare (type ,type ,var))) nil)
+                                     :element-type ,real-element-type)))
+       (declare (type ,type-spec ,var))
        ,@body)))

src/impl-sbcl.lisp

@@ -89,13 +89,13 @@ VECTOR must be a vector created by MAKE-STATIC-VECTOR."
   "Bind PTR-VAR to a static vector of length LENGTH and execute BODY
 within its dynamic extent. The vector is freed upon exit."
   (declare (ignorable element-type initial-contents initial-element))
-  (multiple-value-bind (real-element-type length type)
+  (multiple-value-bind (real-element-type length type-spec)
       (canonicalize-args env element-type length)
     (remf args :element-type)
     `(sb-sys:without-interrupts
        (let ((,var (make-static-vector ,length ,@args
-                                       :element-type ',real-element-type)))
-         ,.(if type `((declare (type ,type ,var))) nil)
+                                       :element-type ,real-element-type)))
+         (declare (type ,type-spec ,var))
          (unwind-protect
               (sb-sys:with-local-interrupts ,@body)
            (when ,var (free-static-vector ,var)))))))

tests/static-vectors-tests.lisp

@@ -10,7 +10,24 @@
 
 (in-suite* :static-vectors)
 
-(test (make-static-vector.plain.notinline
+(test (make-static-vector.defaults
+       :compile-at :definition-time)
+  (let ((v (make-static-vector 5)))
+    (is (= 5 (length v)))
+    (is (equal (array-element-type v)
+               (upgraded-array-element-type
+                '(unsigned-byte 8))))))
+
+(test (make-static-vector.elemen-type.non-literal
+       :compile-at :definition-time)
+  (let* ((element-type '(unsigned-byte 16))
+         (v (make-static-vector 5 :element-type element-type)))
+    (is (= 5 (length v)))
+    (is (equal (array-element-type v)
+               (upgraded-array-element-type
+                '(unsigned-byte 16))))))
+
+(test (make-static-vector.defaults.notinline
        :compile-at :definition-time)
   (locally
       (declare (notinline make-static-vector))
@@ -49,6 +66,39 @@
                (upgraded-array-element-type
                 '(unsigned-byte 16))))))
 
+(test (with-static-vector.element-type.non-literal
+       :compile-at :definition-time)
+  (let ((element-type '(unsigned-byte 16)))
+    (with-static-vector (v 3 :element-type element-type)
+      (is (= 3 (length v)))
+      (is (equal (array-element-type v)
+                 (upgraded-array-element-type
+                  '(unsigned-byte 16)))))))
+
+(test (with-static-vector.initial-element.non-literal
+       :compile-at :definition-time)
+  (let ((element-type '(unsigned-byte 16))
+        (initial-element 5))
+    (with-static-vector (v 3 :element-type element-type
+                             :initial-element initial-element)
+      (is (= 3 (length v)))
+      (is (equal (array-element-type v)
+                 (upgraded-array-element-type
+                  '(unsigned-byte 16))))
+      (is (= 5 (aref v 0))))))
+
+(test (with-static-vector.initial-contents.non-literal
+       :compile-at :definition-time)
+  (let ((element-type '(unsigned-byte 16))
+        (initial-contents '(1 2 3)))
+    (with-static-vector (v 3 :element-type element-type
+                             :initial-contents initial-contents)
+      (is (= 3 (length v)))
+      (is (equal (array-element-type v)
+                 (upgraded-array-element-type
+                  '(unsigned-byte 16))))
+      (is (every #'= v initial-contents)))))
+
 (deftype eltype ()
   '(unsigned-byte 32))