diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 2281c140a4..d0f418f3c9 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -59,10 +59,38 @@ slots ; : ( -- info ) \ value-info new ; +: read-only-slots ( values class -- slots ) + #! Delegation. + all-slots rest-slice + [ read-only>> [ drop f ] unless ] 2map + { f f } prepend ; + +DEFER: + +: init-literal-info ( info -- info ) + #! Delegation. + dup literal>> class >>class + dup literal>> dup real? [ [a,a] >>interval ] [ + [ [-inf,inf] >>interval ] dip + { + { [ dup complex? ] [ + [ real-part ] + [ imaginary-part ] bi + 2array >>slots + ] } + { [ dup tuple? ] [ + [ + tuple-slots rest-slice + [ ] map + ] [ class ] bi read-only-slots >>slots + ] } + [ drop ] + } cond + ] if ; inline + : init-value-info ( info -- info ) dup literal?>> [ - dup literal>> class >>class - dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval + init-literal-info ] [ dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [ null >>class @@ -73,7 +101,7 @@ slots ; dup [ class>> ] [ interval>> ] bi interval>literal [ >>literal ] [ >>literal? ] bi* ] if - ] if ; + ] if ; inline : ( class interval -- info ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 503c633077..559a9bf60b 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -411,6 +411,14 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] final-classes ] unit-test +[ V{ integer array } ] [ + [ + [ 2drop T{ mixed-mutable-immutable f 3 { } } ] + [ { array } declare mixed-mutable-immutable boa ] if + [ x>> ] [ y>> ] bi + ] final-classes +] unit-test + ! Recursive propagation : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive @@ -573,6 +581,14 @@ MIXIN: empty-mixin [ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test +[ V{ float } ] [ + [ + [ { float float } declare ] + [ 2drop C{ 0.0 0.0 } ] + if real-part + ] final-classes +] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 5e3480be2f..a4bd48ecc0 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -31,12 +31,6 @@ UNION: fixed-length-sequence array byte-array string ; : tuple-constructor? ( word -- ? ) { } memq? ; -: read-only-slots ( values class -- slots ) - #! Delegation. - all-slots rest-slice - [ read-only>> [ drop f ] unless ] 2map - { f f } prepend ; - : fold- ( values class -- info ) [ , f , [ literal>> ] map % ] { } make >tuple ;