Changeset 15366

Timestamp:

08/13/20 19:24:23 (3 years ago)

Author:

Mark Evenson

Message:

compiler: emit make-array for top-level specialized vector forms

When compiling top-level DEFVAR/DEFPARAMETER/DEFCONSTANT forms for
specialized vectors, preserve type information by emitting
CL:MAKE-ARRAY calls.

Fixes <​https://github.com/armedbear/abcl/issues/266>.

File:

• trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (modified) (3 diffs)

trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

@@ -1 @@
-
 ;;; compile-file.lisp
 ;;;
@@ -268 +267 @@
   (note-toplevel-form form)
   (eval form)
+      ;;; emit make-array  when initial-value is a specialized vector
+  (let ((initial-value (third form)))
+    (when (and (atom initial-value)
+               (arrayp initial-value)
+               (= (length (array-dimensions initial-value)) 1)
+               (not (eq (array-element-type initial-value) t)))
+      (setf (third form)
+            `(common-lisp:make-array
+              ',(array-dimensions initial-value)
+              :element-type ',(array-element-type initial-value)
+              :initial-contents ',(coerce initial-value 'list)))))
   `(progn
      (put ',(second form) 'sys::source (cons '(,(second form) ,(namestring *source*) ,*source-position*) (get ',(second form)  'sys::source nil)))
@@ -375 +385 @@
       (let ((name (second form)))
         (%defvar name)))
-  (let ((name (second form)))
+  (let ((name (second form))
+        (initial-value (third form)))
+    ;;; emit make-array  when initial-value is a specialized vector
+    (when (and (atom initial-value)
+               (arrayp initial-value)
+               (= (length (array-dimensions initial-value)) 1)
+               (not (eq (array-element-type initial-value) t)))
+      (setf (third form)
+            `(common-lisp:make-array
+              ',(array-dimensions initial-value)
+              :element-type ',(array-element-type initial-value)
+              :initial-contents ',(coerce initial-value 'list))))
     `(progn 
        (put ',name 'sys::source (cons (list :variable ,(namestring *source*) ,*source-position*) (get ',name  'sys::source nil)))
-      ,form)))
+       ,form)))
+
 
 (declaim (ftype (function (t t t) t) process-toplevel-defpackage/in-package))