"1.0.41.2": threads: Add memory-barrier framework.

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

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 9ffa2c0..eea95f8 100644 (file)
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -916,11 +916,33 @@ code to be loaded.
 ;;;; loop types
 
 (defun loop-typed-init (data-type &optional step-var-p)
-  (when (and data-type (sb!xc:subtypep data-type 'number))
-    (if (or (sb!xc:subtypep data-type 'float)
-            (sb!xc:subtypep data-type '(complex float)))
-        (coerce (if step-var-p 1 0) data-type)
-        (if step-var-p 1 0))))
+  (cond ((null data-type)
+         nil)
+        ((sb!xc:subtypep data-type 'number)
+         (let ((init (if step-var-p 1 0)))
+           (flet ((like (&rest types)
+                    (coerce init (find-if (lambda (type)
+                                            (sb!xc:subtypep data-type type))
+                                          types))))
+             (cond ((sb!xc:subtypep data-type 'float)
+                    (like 'single-float 'double-float
+                          'short-float 'long-float 'float))
+                   ((sb!xc:subtypep data-type '(complex float))
+                    (like '(complex single-float)
+                          '(complex double-float)
+                          '(complex short-float)
+                          '(complex long-float)
+                          '(complex float)))
+                   (t
+                    init)))))
+        ((sb!xc:subtypep data-type 'vector)
+         (let ((ctype (sb!kernel:specifier-type data-type)))
+           (when (sb!kernel:array-type-p ctype)
+             (let ((etype (sb!kernel:type-*-to-t
+                           (sb!kernel:array-type-specialized-element-type ctype))))
+               (make-array 0 :element-type (sb!kernel:type-specifier etype))))))
+        (t
+         nil)))
 
 (defun loop-optional-type (&optional variable)
   ;; No variable specified implies that no destructuring is permissible.
@@ -1024,7 +1046,7 @@ code to be loaded.
            (loop-error "duplicated variable ~S in a LOOP binding" name))
          (unless (symbolp name)
            (loop-error "bad variable ~S somewhere in LOOP" name))
-         (loop-declare-var name dtype step-var-p)
+         (loop-declare-var name dtype step-var-p initialization)
          ;; We use ASSOC on this list to check for duplications (above),
          ;; so don't optimize out this list:
          (push (list name (or initialization (loop-typed-init dtype step-var-p)))
@@ -1043,14 +1065,18 @@ code to be loaded.
              (loop-make-var (cdr name) nil tcdr))))
   name)
 
-(defun loop-declare-var (name dtype &optional step-var-p)
+(defun loop-declare-var (name dtype &optional step-var-p initialization)
   (cond ((or (null name) (null dtype) (eq dtype t)) nil)
         ((symbolp name)
-         (unless (sb!xc:subtypep t dtype)
-           (let ((dtype (let ((init (loop-typed-init dtype step-var-p)))
-                          (if (sb!xc:typep init dtype)
-                              dtype
-                              `(or (member ,init) ,dtype)))))
+         (unless (or (sb!xc:subtypep t dtype)
+                     (and (eq (find-package :cl) (symbol-package name))
+                          (eq :special (sb!int:info :variable :kind name))))
+           (let ((dtype (if initialization
+                            dtype
+                            (let ((init (loop-typed-init dtype step-var-p)))
+                              (if (sb!xc:typep init dtype)
+                                  dtype
+                                  `(or ,(type-of init) ,dtype))))))
              (push `(type ,dtype ,name) *loop-declarations*))))
         ((consp name)
          (cond ((consp dtype)
@@ -1720,7 +1746,8 @@ code to be loaded.
                                  `(and ,indexv-type real)))))
            (:by
             (multiple-value-setq (form stepby-constantp stepby)
-              (loop-constant-fold-if-possible form `(and ,indexv-type (real (0)))))
+              (loop-constant-fold-if-possible form
+                                              `(and ,indexv-type (real (0)))))
             (unless stepby-constantp
               (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
                  form
@@ -1731,7 +1758,8 @@ code to be loaded.
               maybe invalid prepositions were specified in iteration path descriptor?"
                  prep)))
          (when (and odir dir (not (eq dir odir)))
-           (loop-error "conflicting stepping directions in LOOP sequencing path"))
+           (loop-error
+             "conflicting stepping directions in LOOP sequencing path"))
          (setq odir dir))
        (when (and sequence-variable (not sequencep))
          (loop-error "missing OF or IN phrase in sequence path"))
@@ -1749,8 +1777,9 @@ code to be loaded.
                                   :key #'type-declaration-of
                                   :from-end t)))
                  (sb!int:aver (eq decl %decl))
-                 (setf (cadr decl)
-                       `(and real ,(cadr decl))))))
+                 (when decl
+                   (setf (cadr decl)
+                         `(and real ,(cadr decl)))))))
            ;; default start
            ;; DUPLICATE KLUDGE: loop-make-var generates a temporary
            ;; symbol for indexv if it is NIL. See also the comment in