1.0.36.11: Make slam.sh work on Win32.

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

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 9ffa2c0..e2df9b8 100644 (file)
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -916,11 +916,32 @@ code to be loaded.
 ;;;; loop types
 
 (defun loop-typed-init (data-type &optional step-var-p)
 ;;;; 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:array-type-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.
 
 (defun loop-optional-type (&optional variable)
   ;; No variable specified implies that no destructuring is permissible.

@@ -1024,7 +1045,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-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)))
          ;; 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 +1064,18 @@ code to be loaded.
              (loop-make-var (cdr name) nil tcdr))))
   name)
 
              (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)
   (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)
              (push `(type ,dtype ,name) *loop-declarations*))))
         ((consp name)
          (cond ((consp dtype)

@@ -1720,7 +1745,8 @@ code to be loaded.
                                  `(and ,indexv-type real)))))
            (:by
             (multiple-value-setq (form stepby-constantp stepby)
                                  `(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
             (unless stepby-constantp
               (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
                  form

@@ -1731,7 +1757,8 @@ code to be loaded.
               maybe invalid prepositions were specified in iteration path descriptor?"
                  prep)))
          (when (and odir dir (not (eq dir odir)))
               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"))
          (setq odir dir))
        (when (and sequence-variable (not sequencep))
          (loop-error "missing OF or IN phrase in sequence path"))

@@ -1749,8 +1776,9 @@ code to be loaded.
                                   :key #'type-declaration-of
                                   :from-end t)))
                  (sb!int:aver (eq decl %decl))
                                   :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
            ;; default start
            ;; DUPLICATE KLUDGE: loop-make-var generates a temporary
            ;; symbol for indexv if it is NIL. See also the comment in