From a3be724f5a149cde60d8d6fd8e89723b35569a5f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bj=C3=B6rn=20Lindqvist?= <bjourne@gmail.com>
Date: Mon, 16 Nov 2015 12:30:24 +0100
Subject: [PATCH] compiler.tree.propagation.info: better code for wrap-interval

---
 .../tree/propagation/info/info-docs.factor    |  4 +++
 .../tree/propagation/info/info-tests.factor   | 33 +++++++++++++++++--
 .../tree/propagation/info/info.factor         |  7 +---
 3 files changed, 36 insertions(+), 8 deletions(-)

diff --git a/basis/compiler/tree/propagation/info/info-docs.factor b/basis/compiler/tree/propagation/info/info-docs.factor
index 40c5e7bb6d..e6ebd783af 100644
--- a/basis/compiler/tree/propagation/info/info-docs.factor
+++ b/basis/compiler/tree/propagation/info/info-docs.factor
@@ -46,6 +46,10 @@ HELP: value-info-state
 HELP: value-infos
 { $var-description "Assoc stack of current value --> info mapping" } ;
 
+HELP: wrap-interval
+{ $values { "interval" interval } { "class" class } { "interval'" interval } }
+{ $description "Wraps an interval to the given numeric types interval." } ;
+
 ARTICLE: "compiler.tree.propagation.info" "Value info data type and operations"
 "Querying words:"
 { $subsections
diff --git a/basis/compiler/tree/propagation/info/info-tests.factor b/basis/compiler/tree/propagation/info/info-tests.factor
index 1f44aa40a0..6293d38bb2 100644
--- a/basis/compiler/tree/propagation/info/info-tests.factor
+++ b/basis/compiler/tree/propagation/info/info-tests.factor
@@ -1,5 +1,6 @@
-USING: accessors alien byte-arrays classes.struct math math.intervals sequences
-classes.algebra kernel tools.test compiler.tree.propagation.info arrays ;
+USING: accessors alien arrays byte-arrays classes.algebra
+classes.struct compiler.tree.propagation.info kernel literals math
+math.intervals sequences sequences.private tools.test ;
 IN: compiler.tree.propagation.info.tests
 
 { f } [ 0.0 -0.0 eql? ] unit-test
@@ -191,3 +192,31 @@ TUPLE: tup2 < tup1 bar ;
     tup2 <class-info> tup1 <class-info> value-info<=
     tup1 <class-info> tup2 <class-info> value-info<=
 ] unit-test
+
+! init-interval
+{
+    T{ value-info-state
+       { class array-capacity }
+       { interval $[ array-capacity-interval ] }
+    }
+} [
+    <value-info> -100 100 [a,b] >>interval array-capacity >>class
+    init-interval
+] unit-test
+
+! wrap-interval
+${
+    full-interval
+    empty-interval
+    fixnum-interval
+    array-capacity-interval
+    array-capacity-interval
+    -100 100 [a,b]
+} [
+    full-interval integer wrap-interval
+    empty-interval integer wrap-interval
+    full-interval fixnum wrap-interval
+    fixnum-interval array-capacity wrap-interval
+    -100 100 [a,b] array-capacity wrap-interval
+    -100 100 [a,b] integer wrap-interval
+] unit-test
diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index bb136be67e..6a4658f8d8 100644
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -108,12 +108,7 @@ UNION: fixed-length array byte-array string ;
     } case ;
 
 : wrap-interval ( interval class -- interval' )
-    {
-        { [ over empty-interval eq? ] [ drop ] }
-        { [ over full-interval eq? ] [ nip class-interval ] }
-        { [ 2dup class-interval interval-subset? not ] [ nip class-interval ] }
-        [ drop ]
-    } cond ;
+    class-interval 2dup interval-subset? [ drop ] [ nip ] if ;
 
 : init-interval ( info -- info )
     dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval