Menu
▾
▴
[Sbcl-commits] master: Fix loop with SUM and COUNT together.
|
From: stassats <sta...@us...> - 2014-05-30 18:35:59
|
The branch "master" has been updated in SBCL:
via 8753b4d4169cc0ff6bc4bf42131ce1492ba0ea83 (commit)
from c42076a971dab88d6b25a3b9a9723aff1465153e (commit)
- Log -----------------------------------------------------------------
commit 8753b4d4169cc0ff6bc4bf42131ce1492ba0ea83
Author: Stas Boukarev <sta...@gm...>
Date: Fri May 30 22:28:31 2014 +0400
Fix loop with SUM and COUNT together.
When the default types are used, NUMBER and FIXNUM respectively, they
can conflict. Use a union of the types for the collection variable,
but only if all cases are using default types.
Fixes lp#798388.
---
NEWS | 2 +-
src/code/loop.lisp | 68 +++++++++++++++++++++++++++++++++----------------
tests/loop.pure.lisp | 6 ++++
3 files changed, 53 insertions(+), 23 deletions(-)
diff --git a/NEWS b/NEWS
index 623dba4..4ad8870 100644
--- a/NEWS
+++ b/NEWS
@@ -8,7 +8,7 @@ changes relative to sbcl-1.2.0:
* bug fix: compiling SVREF on unknown types no longer produces scary errors.
(lp#1258716)
* bug fix: assorted LOOP fixes and enhancements. (lp#645534, lp#1322923,
- lp#700538, lp#613876, lp#695286)
+ lp#700538, lp#613876, lp#695286, lp#798388)
changes in sbcl-1.2.0 relative to sbcl-1.1.18:
* bug fix: read-time-eval backquote context mixup. (lp#1321047)
diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 7992fcc..88c5692 100644
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -1024,9 +1024,17 @@ code to be loaded.
class
(history nil)
(tempvars nil)
+ specified-type
dtype
(data nil)) ;collector-specific data
+(sb!int:defmacro-mundanely with-sum-count (lc &body body)
+ (let ((type (loop-collector-dtype lc))
+ (temp-var (car (loop-collector-tempvars lc))))
+ `(let ((,temp-var ,(loop-typed-init type)))
+ (declare (type ,type ,temp-var))
+ ,@body)))
+
(defun loop-get-collection-info (collector class default-type)
(let ((form (loop-get-form))
(name (when (loop-tequal (car *loop-source-code*) 'into)
@@ -1036,27 +1044,41 @@ code to be loaded.
(loop-error "The value accumulation recipient name, ~S, is not a symbol." name))
(unless name
(loop-disallow-aggregate-booleans))
- (let ((dtype (or (loop-optional-type) default-type))
- (cruft (find (the symbol name) *loop-collection-cruft*
- :key #'loop-collector-name)))
+ (let* ((specified-type (loop-optional-type))
+ (dtype (or specified-type default-type))
+ (cruft (find (the symbol name) *loop-collection-cruft*
+ :key #'loop-collector-name)))
(cond ((not cruft)
(check-var-name name " in INTO clause")
(push (setq cruft (make-loop-collector
- :name name :class class
- :history (list collector) :dtype dtype))
+ :name name :class class
+ :history (list collector)
+ :specified-type specified-type
+ :dtype dtype))
*loop-collection-cruft*))
(t (unless (eq (loop-collector-class cruft) class)
(loop-error
- "incompatible kinds of LOOP value accumulation specified for collecting~@
+ "incompatible kinds of LOOP value accumulation specified for collecting~@
~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S"
- name (car (loop-collector-history cruft)) collector))
- (unless (equal dtype (loop-collector-dtype cruft))
- (loop-warn
- "unequal datatypes specified in different LOOP value accumulations~@
- into ~S: ~S and ~S"
- name dtype (loop-collector-dtype cruft))
- (when (eq (loop-collector-dtype cruft) t)
- (setf (loop-collector-dtype cruft) dtype)))
+ name (car (loop-collector-history cruft)) collector))
+ (cond ((equal dtype (loop-collector-dtype cruft)))
+ ((and (null specified-type)
+ (null (loop-collector-specified-type cruft)))
+ ;; Unionize types only for default types, most
+ ;; likely, SUM and COUNT which have number and
+ ;; fixnum respectively.
+ (setf (loop-collector-dtype cruft)
+ (sb!kernel:type-specifier
+ (sb!kernel:type-union
+ (sb!kernel:specifier-type dtype)
+ (sb!kernel:specifier-type (loop-collector-dtype cruft))))))
+ (t
+ (loop-warn
+ "unequal datatypes specified in different LOOP value accumulations~@
+ into ~S: ~S and ~S"
+ name dtype (loop-collector-dtype cruft))
+ (when (eq (loop-collector-dtype cruft) t)
+ (setf (loop-collector-dtype cruft) dtype))))
(push collector (loop-collector-history cruft))))
(values cruft form))))
@@ -1090,12 +1112,11 @@ code to be loaded.
(let ((tempvars (loop-collector-tempvars lc)))
(unless tempvars
(setf (loop-collector-tempvars lc)
- (setq tempvars (list (loop-make-var
- (or (loop-collector-name lc)
- (gensym "LOOP-SUM-"))
- nil (loop-collector-dtype lc)))))
+ (setq tempvars (list (or (loop-collector-name lc)
+ (gensym "LOOP-SUM-")))))
(unless (loop-collector-name lc)
- (loop-emit-final-value (car (loop-collector-tempvars lc)))))
+ (loop-emit-final-value (car (loop-collector-tempvars lc))))
+ (push `(with-sum-count ,lc) *loop-wrappers*))
(loop-emit-body
(if (eq specifically 'count)
`(when ,form
@@ -1780,10 +1801,13 @@ code to be loaded.
(nconc (loop-list-collection nconc))
(nconcing (loop-list-collection nconc))
(count (loop-sum-collection count
- real
- fixnum))
+ ;; This could be REAL, but when
+ ;; combined with SUM, it has to be
+ ;; NUMBER.
+ number
+ fixnum))
(counting (loop-sum-collection count
- real
+ number
fixnum))
(sum (loop-sum-collection sum number number))
(summing (loop-sum-collection sum number number))
diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp
index 27aa115..aa4962c 100644
--- a/tests/loop.pure.lisp
+++ b/tests/loop.pure.lisp
@@ -342,3 +342,9 @@
(with-test (:name :destructuring-less)
(assert (equal (loop with (a b) = '() repeat 1 collect (list a b))
'((NIL NIL)))))
+
+(with-test (:name :count-with-sum)
+ (assert (= (loop repeat 1 count 1 sum #c(1 2))
+ #c(2 2)))
+ (assert (= (loop repeat 1 sum 1 count 1)
+ 2)))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|