[armedbear-cvs] r14356 - in branches/1.1.x: src/org/armedbear/lisp test/lisp/abcl

[mevenson at common-lisp.net]

Author: mevenson
Date: Wed Jan 16 02:48:24 2013
New Revision: 14356

Log:
Backport r14355 | mevenson | 2013-01-16 11:45:54 +0100 (Wed, 16 Jan 2013) | 5 lines.

Fix loop and default value for of-type problem.

Patch and (most of) test by Stas.

Fixes #293.

Modified:
   branches/1.1.x/src/org/armedbear/lisp/loop.lisp
   branches/1.1.x/test/lisp/abcl/bugs.lisp

Modified: branches/1.1.x/src/org/armedbear/lisp/loop.lisp
==============================================================================
--- branches/1.1.x/src/org/armedbear/lisp/loop.lisp	Wed Jan 16 02:45:54 2013	(r14355)
+++ branches/1.1.x/src/org/armedbear/lisp/loop.lisp	Wed Jan 16 02:48:24 2013	(r14356)
@@ -976,10 +976,23 @@
 
 (defun loop-typed-init (data-type &optional step-var-p)
   (when (and data-type (subtypep data-type 'number))
-    (if (or (subtypep data-type 'float)
-	    (subtypep data-type '(complex float)))
-	(coerce (if step-var-p 1 0) data-type)
-	(if step-var-p 1 0))))
+    ;; From SBCL
+    (let ((init (if step-var-p 1 0)))
+      (flet ((like (&rest types)
+               (coerce init (find-if (lambda (type)
+                                       (subtypep data-type type))
+                                     types))))
+        (cond ((subtypep data-type 'float)
+               (like 'single-float 'double-float
+                     'short-float 'long-float 'float))
+              ((subtypep data-type '(complex float))
+               (like '(complex single-float)
+                     '(complex double-float)
+                     '(complex short-float)
+                     '(complex long-float)
+                     '(complex float)))
+              (t
+               init))))))
 
 (defun loop-optional-type (&optional variable)
   ;; No variable specified implies that no destructuring is permissible.

Modified: branches/1.1.x/test/lisp/abcl/bugs.lisp
==============================================================================
--- branches/1.1.x/test/lisp/abcl/bugs.lisp	Wed Jan 16 02:45:54 2013	(r14355)
+++ branches/1.1.x/test/lisp/abcl/bugs.lisp	Wed Jan 16 02:48:24 2013	(r14356)
@@ -125,3 +125,11 @@
 (deftest bugs.pathname.make-pathname.2
   (probe-file (make-pathname :device (list "foo")))
 nil)
+
+;; http://trac.common-lisp.net/armedbear/ticket/293
+(deftest bugs.loop.1
+    (loop :with x :of-type (float 0) = 0.0
+       :for y :upto 1
+       :collecting (cons x y))
+  ((0.0 . 0) (0.0 . 1)))
+