compiler.tree.propagation.info: better code for wrap-interval

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

basis/compiler/tree/propagation/info/info-tests.factor

@@ -1,5 +1,6 @@
-USING: accessors alien byte-arrays classes.struct math math.intervals sequences
+USING: accessors alien arrays byte-arrays classes.algebra
-classes.algebra kernel tools.test compiler.tree.propagation.info arrays ;
+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

basis/compiler/tree/propagation/info/info.factor

@@ -108,12 +108,7 @@ UNION: fixed-length array byte-array string ;
     } case ;
 
 : wrap-interval ( interval class -- interval' )
-    {
+    class-interval 2dup interval-subset? [ drop ] [ nip ] if ;
-        { [ over empty-interval eq? ] [ drop ] }
-        { [ over full-interval eq? ] [ nip class-interval ] }
-        { [ 2dup class-interval interval-subset? not ] [ nip class-interval ] }
-        [ drop ]
-    } cond ;
 
 : init-interval ( info -- info )
     dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval