Merge branch 'master' of git://factorcode.org/git/factor
commit
2066adcfec
|
@ -20,6 +20,10 @@ ERROR: not-a-tuple object ;
|
|||
: all-slots ( class -- slots )
|
||||
superclasses [ "slots" word-prop ] map concat ;
|
||||
|
||||
PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
|
||||
#! Delegation
|
||||
all-slots rest-slice [ read-only>> ] all? ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: tuple-layout ( class -- layout )
|
||||
|
|
|
@ -165,13 +165,9 @@ GENERIC: boa ( ... class -- tuple )
|
|||
compose compose ; inline
|
||||
|
||||
! Booleans
|
||||
: not ( obj -- ? )
|
||||
#! Not inline because its special-cased by compiler.
|
||||
f eq? ;
|
||||
: not ( obj -- ? ) f t ? ; inline
|
||||
|
||||
: and ( obj1 obj2 -- ? )
|
||||
#! Not inline because its special-cased by compiler.
|
||||
over ? ;
|
||||
: and ( obj1 obj2 -- ? ) over ? ; inline
|
||||
|
||||
: >boolean ( obj -- ? ) t f ? ; inline
|
||||
|
||||
|
|
|
@ -135,6 +135,9 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
]
|
||||
} cond ;
|
||||
|
||||
: intervals-intersect? ( i1 i2 -- ? )
|
||||
interval-intersect empty-interval eq? not ;
|
||||
|
||||
: interval-union ( i1 i2 -- i3 )
|
||||
{
|
||||
{ [ dup empty-interval eq? ] [ drop ] }
|
||||
|
|
|
@ -8,13 +8,17 @@ IN: slots
|
|||
|
||||
TUPLE: slot-spec name offset class initial read-only reader writer ;
|
||||
|
||||
PREDICATE: reader < word "reader" word-prop ;
|
||||
|
||||
PREDICATE: writer < word "writer" word-prop ;
|
||||
|
||||
: <slot-spec> ( -- slot-spec )
|
||||
slot-spec new
|
||||
object bootstrap-word >>class ;
|
||||
|
||||
: define-typecheck ( class generic quot props -- )
|
||||
[ dup define-simple-generic create-method ] 2dip
|
||||
[ [ props>> ] [ drop ] [ [ t ] H{ } map>assoc ] tri* update ]
|
||||
[ [ props>> ] [ drop ] [ ] tri* update ]
|
||||
[ drop define ]
|
||||
3bi ;
|
||||
|
||||
|
@ -31,17 +35,23 @@ TUPLE: slot-spec name offset class initial read-only reader writer ;
|
|||
] [ ] make ;
|
||||
|
||||
: reader-word ( name -- word )
|
||||
">>" append (( object -- value )) create-accessor ;
|
||||
">>" append (( object -- value )) create-accessor
|
||||
dup t "reader" set-word-prop ;
|
||||
|
||||
: reader-props ( slot-spec -- seq )
|
||||
read-only>> { "foldable" "flushable" } { "flushable" } ? ;
|
||||
: reader-props ( slot-spec -- assoc )
|
||||
[
|
||||
[ "reading" set ]
|
||||
[ read-only>> [ t "foldable" set ] when ] bi
|
||||
t "flushable" set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: define-reader ( class slot-spec -- )
|
||||
[ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
|
||||
define-typecheck ;
|
||||
|
||||
: writer-word ( name -- word )
|
||||
"(>>" swap ")" 3append (( value object -- )) create-accessor ;
|
||||
"(>>" swap ")" 3append (( value object -- )) create-accessor
|
||||
dup t "writer" set-word-prop ;
|
||||
|
||||
ERROR: bad-slot-value value class ;
|
||||
|
||||
|
@ -77,8 +87,12 @@ ERROR: bad-slot-value value class ;
|
|||
} cond
|
||||
] [ ] make ;
|
||||
|
||||
: writer-props ( slot-spec -- assoc )
|
||||
[ "writing" set ] H{ } make-assoc ;
|
||||
|
||||
: define-writer ( class slot-spec -- )
|
||||
[ name>> writer-word ] [ writer-quot ] bi { } define-typecheck ;
|
||||
[ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
|
||||
define-typecheck ;
|
||||
|
||||
: setter-word ( name -- word )
|
||||
">>" prepend (( object value -- object )) create-accessor ;
|
||||
|
|
|
@ -187,6 +187,7 @@ M: word reset-word
|
|||
"parsing" "inline" "recursive" "foldable" "flushable"
|
||||
"predicating"
|
||||
"reading" "writing"
|
||||
"reader" "writer"
|
||||
"constructing"
|
||||
"declared-effect" "constructor-quot" "delimiter"
|
||||
} reset-props ;
|
||||
|
|
|
@ -183,7 +183,7 @@ M: object run-pipeline-element
|
|||
[ |dispose drop ]
|
||||
[
|
||||
swap >process
|
||||
[ swap in>> or ] change-stdout
|
||||
[ swap in>> or ] change-stdin
|
||||
run-detached
|
||||
]
|
||||
[ in>> dispose ]
|
||||
|
@ -200,8 +200,8 @@ M: object run-pipeline-element
|
|||
[ [ |dispose drop ] bi@ ]
|
||||
[
|
||||
rot >process
|
||||
[ swap out>> or ] change-stdout
|
||||
[ swap in>> or ] change-stdin
|
||||
[ swap out>> or ] change-stdout
|
||||
run-detached
|
||||
]
|
||||
[ [ out>> dispose ] [ in>> dispose ] bi* ]
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
IN: io.unix.launcher.tests
|
||||
USING: io.files tools.test io.launcher arrays io namespaces
|
||||
continuations math io.encodings.binary io.encodings.ascii
|
||||
accessors kernel sequences io.encodings.utf8 destructors ;
|
||||
accessors kernel sequences io.encodings.utf8 destructors
|
||||
io.streams.duplex ;
|
||||
|
||||
[ ] [
|
||||
[ "launcher-test-1" temp-file delete-file ] ignore-errors
|
||||
|
@ -111,4 +112,12 @@ accessors kernel sequences io.encodings.utf8 destructors ;
|
|||
"append-test" temp-file utf8 file-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [ "ls" utf8 <process-stream> contents drop ] unit-test
|
||||
[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
|
||||
|
||||
[ "Hello world.\n" ] [
|
||||
"cat" utf8 <process-stream> [
|
||||
"Hello world.\n" write
|
||||
output-stream get dispose
|
||||
input-stream get contents
|
||||
] with-stream
|
||||
] unit-test
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs classes classes.algebra kernel accessors math
|
||||
math.intervals namespaces sequences words combinators arrays
|
||||
compiler.tree.copy-equiv ;
|
||||
USING: assocs classes classes.algebra kernel
|
||||
accessors math math.intervals namespaces sequences words
|
||||
combinators arrays compiler.tree.copy-equiv ;
|
||||
IN: compiler.tree.propagation.info
|
||||
|
||||
SYMBOL: +interval+
|
||||
|
@ -17,13 +17,15 @@ M: complex eql? over complex? [ = ] [ 2drop f ] if ;
|
|||
|
||||
! Value info represents a set of objects. Don't mutate value infos
|
||||
! you receive, always construct new ones. We don't declare the
|
||||
! slots read-only to allow cloning followed by writing.
|
||||
! slots read-only to allow cloning followed by writing, and to
|
||||
! simplify constructors.
|
||||
TUPLE: value-info
|
||||
{ class initial: null }
|
||||
{ interval initial: empty-interval }
|
||||
class
|
||||
interval
|
||||
literal
|
||||
literal?
|
||||
length ;
|
||||
length
|
||||
slots ;
|
||||
|
||||
: class-interval ( class -- interval )
|
||||
dup real class<=
|
||||
|
@ -57,6 +59,7 @@ length ;
|
|||
null >>class
|
||||
empty-interval >>interval
|
||||
] [
|
||||
[ [-inf,inf] or ] change-interval
|
||||
dup class>> integer class<= [ [ integral-closure ] change-interval ] when
|
||||
dup [ class>> ] [ interval>> ] bi interval>literal
|
||||
[ >>literal ] [ >>literal? ] bi*
|
||||
|
@ -88,10 +91,15 @@ length ;
|
|||
: <sequence-info> ( value -- info )
|
||||
<value-info>
|
||||
object >>class
|
||||
[-inf,inf] >>interval
|
||||
swap value-info >>length
|
||||
init-value-info ; foldable
|
||||
|
||||
: <tuple-info> ( slots class -- info )
|
||||
<value-info>
|
||||
swap >>class
|
||||
swap >>slots
|
||||
init-value-info ;
|
||||
|
||||
: >literal< ( info -- literal literal? )
|
||||
[ literal>> ] [ literal?>> ] bi ;
|
||||
|
||||
|
@ -112,6 +120,11 @@ DEFER: value-info-intersect
|
|||
[ value-info-intersect ]
|
||||
} cond ;
|
||||
|
||||
: intersect-slots ( info1 info2 -- slots )
|
||||
[ slots>> ] bi@
|
||||
2dup [ length ] bi@ =
|
||||
[ [ value-info-intersect ] 2map ] [ 2drop f ] if ;
|
||||
|
||||
: (value-info-intersect) ( info1 info2 -- info )
|
||||
[ <value-info> ] 2dip
|
||||
{
|
||||
|
@ -119,6 +132,7 @@ DEFER: value-info-intersect
|
|||
[ [ interval>> ] bi@ interval-intersect >>interval ]
|
||||
[ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
|
||||
[ intersect-lengths >>length ]
|
||||
[ intersect-slots >>slots ]
|
||||
} 2cleave
|
||||
init-value-info ;
|
||||
|
||||
|
@ -143,6 +157,11 @@ DEFER: value-info-union
|
|||
[ value-info-union ]
|
||||
} cond ;
|
||||
|
||||
: union-slots ( info1 info2 -- slots )
|
||||
[ slots>> ] bi@
|
||||
2dup [ length ] bi@ =
|
||||
[ [ value-info-union ] 2map ] [ 2drop f ] if ;
|
||||
|
||||
: (value-info-union) ( info1 info2 -- info )
|
||||
[ <value-info> ] 2dip
|
||||
{
|
||||
|
@ -150,6 +169,7 @@ DEFER: value-info-union
|
|||
[ [ interval>> ] bi@ interval-union >>interval ]
|
||||
[ union-literals [ >>literal ] [ >>literal? ] bi* ]
|
||||
[ union-lengths >>length ]
|
||||
[ union-slots >>slots ]
|
||||
} 2cleave
|
||||
init-value-info ;
|
||||
|
||||
|
@ -167,7 +187,8 @@ DEFER: value-info-union
|
|||
SYMBOL: value-infos
|
||||
|
||||
: value-info ( value -- info )
|
||||
resolve-copy value-infos get at T{ value-info } or ;
|
||||
resolve-copy value-infos get at
|
||||
T{ value-info f null empty-interval } or ;
|
||||
|
||||
: set-value-info ( info value -- )
|
||||
resolve-copy value-infos get set-at ;
|
||||
|
|
|
@ -185,6 +185,27 @@ generic-comparison-ops [
|
|||
'[ , fold-comparison ] +outputs+ set-word-prop
|
||||
] each
|
||||
|
||||
: maybe-or-never ( ? -- info )
|
||||
[ object <class-info> ] [ \ f <class-info> ] if ;
|
||||
|
||||
: info-intervals-intersect? ( info1 info2 -- ? )
|
||||
[ interval>> ] bi@ intervals-intersect? ;
|
||||
|
||||
{ number= bignum= float= } [
|
||||
[
|
||||
info-intervals-intersect? maybe-or-never
|
||||
] +outputs+ set-word-prop
|
||||
] each
|
||||
|
||||
: info-classes-intersect? ( info1 info2 -- ? )
|
||||
[ class>> ] bi@ classes-intersect? ;
|
||||
|
||||
\ eq? [
|
||||
[ info-intervals-intersect? ]
|
||||
[ info-classes-intersect? ]
|
||||
bi or maybe-or-never
|
||||
] +outputs+ set-word-prop
|
||||
|
||||
{
|
||||
{ >fixnum fixnum }
|
||||
{ >bignum bignum }
|
||||
|
|
|
@ -3,7 +3,8 @@ compiler.tree.propagation compiler.tree.copy-equiv
|
|||
compiler.tree.def-use tools.test math math.order
|
||||
accessors sequences arrays kernel.private vectors
|
||||
alien.accessors alien.c-types sequences.private
|
||||
byte-arrays ;
|
||||
byte-arrays classes.algebra math.functions math.private
|
||||
strings ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
\ propagate must-infer
|
||||
|
@ -234,8 +235,100 @@ IN: compiler.tree.propagation.tests
|
|||
[ [ 1 ] [ 1 ] if 1 + ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ string string } ] [
|
||||
[
|
||||
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
! Array length propagation
|
||||
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
|
||||
|
||||
[ V{ t } ] [ [ [ 10 f <array> ] [ 10 <byte-array> ] if length 10 = ] final-literals ] unit-test
|
||||
|
||||
[ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
|
||||
|
||||
! Slot propagation
|
||||
TUPLE: prop-test-tuple { x integer } ;
|
||||
|
||||
[ V{ integer } ] [ [ { prop-test-tuple } declare x>> ] final-classes ] unit-test
|
||||
|
||||
TUPLE: another-prop-test-tuple { x ratio initial: 1/2 } ;
|
||||
|
||||
UNION: prop-test-union prop-test-tuple another-prop-test-tuple ;
|
||||
|
||||
[ t ] [
|
||||
[ { prop-test-union } declare x>> ] final-classes first
|
||||
rational class=
|
||||
] unit-test
|
||||
|
||||
TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
|
||||
|
||||
[ V{ T{ fold-boa-test-tuple f 1 2 3 } } ]
|
||||
[ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
|
||||
unit-test
|
||||
|
||||
TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
|
||||
|
||||
[ V{ T{ immutable-prop-test-tuple f "hey" } } ] [
|
||||
[ "hey" immutable-prop-test-tuple boa ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ { 1 2 } } ] [
|
||||
[ { 1 2 } immutable-prop-test-tuple boa x>> ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ array } ] [
|
||||
[ { array } declare immutable-prop-test-tuple boa x>> ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ complex } ] [
|
||||
[ <complex> ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ complex } ] [
|
||||
[ { float float } declare dup 0.0 <= [ "Oops" throw ] [ rect> ] if ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ float float } ] [
|
||||
[
|
||||
{ float float } declare
|
||||
dup 0.0 <= [ "Oops" throw ] when rect>
|
||||
[ real>> ] [ imaginary>> ] bi
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ complex } ] [
|
||||
[
|
||||
{ float float object } declare
|
||||
[ "Oops" throw ] [ <complex> ] if
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ number } ] [ [ [ "Oops" throw ] [ 2 + ] if ] final-classes ] unit-test
|
||||
[ V{ number } ] [ [ [ 2 + ] [ "Oops" throw ] if ] final-classes ] unit-test
|
||||
|
||||
[ V{ POSTPONE: f } ] [
|
||||
[ dup 1.0 <= [ drop f ] [ 0 number= ] if ] final-classes
|
||||
] unit-test
|
||||
|
||||
! Don't fold this
|
||||
TUPLE: mutable-tuple-test { x sequence } ;
|
||||
|
||||
[ V{ sequence } ] [
|
||||
[ "hey" mutable-tuple-test boa x>> ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ sequence } ] [
|
||||
[ T{ mutable-tuple-test f "hey" } x>> ] final-classes
|
||||
] unit-test
|
||||
|
||||
! Mixed mutable and immutable slots
|
||||
TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
||||
|
||||
[ V{ integer array } ] [
|
||||
[
|
||||
3 { 2 1 } mixed-mutable-immutable boa
|
||||
[ x>> ] [ y>> ] bi
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
|
|
@ -2,11 +2,13 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors kernel sequences sequences.private assocs
|
||||
words namespaces classes.algebra combinators classes
|
||||
continuations arrays byte-arrays strings
|
||||
classes.tuple classes.tuple.private continuations arrays
|
||||
byte-arrays strings math math.private slots
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.slots
|
||||
compiler.tree.propagation.constraints ;
|
||||
IN: compiler.tree.propagation.simple
|
||||
|
||||
|
@ -53,6 +55,17 @@ M: #declare propagate-before
|
|||
[ word>> +outputs+ word-prop ]
|
||||
bi with-datastack ;
|
||||
|
||||
: foldable-word? ( #call -- ? )
|
||||
dup word>> "foldable" word-prop [
|
||||
drop t
|
||||
] [
|
||||
dup word>> \ <tuple-boa> eq? [
|
||||
in-d>> peek value-info literal>> immutable-tuple-class?
|
||||
] [
|
||||
drop f
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: foldable-call? ( #call -- ? )
|
||||
dup word>> "foldable" word-prop [
|
||||
in-d>> [ value-info literal?>> ] all?
|
||||
|
@ -73,27 +86,11 @@ M: #declare propagate-before
|
|||
out-d>> length object <class-info> <repetition>
|
||||
] ?if ;
|
||||
|
||||
UNION: fixed-length-sequence array byte-array string ;
|
||||
|
||||
: sequence-constructor? ( node -- ? )
|
||||
word>> { <array> <byte-array> <string> } memq? ;
|
||||
|
||||
: propagate-sequence-constructor ( node -- infos )
|
||||
[ default-output-value-infos first ]
|
||||
[ in-d>> first <sequence-info> ]
|
||||
bi value-info-intersect 1array ;
|
||||
|
||||
: length-accessor? ( node -- ? )
|
||||
dup in-d>> first fixed-length-sequence value-is?
|
||||
[ word>> \ length eq? ] [ drop f ] if ;
|
||||
|
||||
: propagate-length ( node -- infos )
|
||||
in-d>> first value-info length>>
|
||||
[ array-capacity <class-info> ] unless* 1array ;
|
||||
|
||||
: output-value-infos ( node -- infos )
|
||||
{
|
||||
{ [ dup foldable-call? ] [ fold-call ] }
|
||||
{ [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
|
||||
{ [ dup word>> reader? ] [ reader-word-outputs ] }
|
||||
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
|
||||
{ [ dup length-accessor? ] [ propagate-length ] }
|
||||
{ [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
|
||||
|
@ -107,12 +104,16 @@ M: #call propagate-before
|
|||
|
||||
M: node propagate-before drop ;
|
||||
|
||||
: propagate-input-classes ( node -- )
|
||||
[ word>> "input-classes" word-prop class-infos ] [ in-d>> ] bi
|
||||
refine-value-infos ;
|
||||
|
||||
M: #call propagate-after
|
||||
dup word>> "input-classes" word-prop dup [
|
||||
class-infos swap in-d>> refine-value-infos
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
{
|
||||
{ [ dup reader? ] [ reader-word-inputs ] }
|
||||
{ [ dup word>> "input-classes" word-prop ] [ propagate-input-classes ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
M: node propagate-after drop ;
|
||||
|
||||
|
|
|
@ -0,0 +1,111 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry assocs arrays byte-arrays strings accessors sequences
|
||||
kernel slots classes.algebra classes.tuple classes.tuple.private
|
||||
words math math.private combinators sequences.private namespaces
|
||||
compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.slots
|
||||
|
||||
! Propagation of immutable slots and array lengths
|
||||
|
||||
! Revisit this code when delegation is removed and when complex
|
||||
! numbers become tuples.
|
||||
|
||||
UNION: fixed-length-sequence array byte-array string ;
|
||||
|
||||
: sequence-constructor? ( node -- ? )
|
||||
word>> { <array> <byte-array> <string> } memq? ;
|
||||
|
||||
: constructor-output-class ( word -- class )
|
||||
{
|
||||
{ <array> array }
|
||||
{ <byte-array> byte-array }
|
||||
{ <string> string }
|
||||
} at ;
|
||||
|
||||
: propagate-sequence-constructor ( node -- infos )
|
||||
[ word>> constructor-output-class <class-info> ]
|
||||
[ in-d>> first <sequence-info> ]
|
||||
bi value-info-intersect 1array ;
|
||||
|
||||
: length-accessor? ( node -- ? )
|
||||
dup in-d>> first fixed-length-sequence value-is?
|
||||
[ word>> \ length eq? ] [ drop f ] if ;
|
||||
|
||||
: propagate-length ( node -- infos )
|
||||
in-d>> first value-info length>>
|
||||
[ array-capacity <class-info> ] unless* 1array ;
|
||||
|
||||
: tuple-constructor? ( node -- ? )
|
||||
word>> { <tuple-boa> <complex> } memq? ;
|
||||
|
||||
: propagate-<tuple-boa> ( node -- info )
|
||||
#! Delegation
|
||||
in-d>> [ value-info ] map unclip-last
|
||||
literal>> class>> dup immutable-tuple-class? [
|
||||
over [ literal?>> ] all?
|
||||
[ [ , f , [ literal>> ] map % ] { } make >tuple <literal-info> ]
|
||||
[ <tuple-info> ]
|
||||
if
|
||||
] [ nip <class-info> ] if ;
|
||||
|
||||
: propagate-<complex> ( node -- info )
|
||||
in-d>> [ value-info ] map complex <tuple-info> ;
|
||||
|
||||
: propagate-tuple-constructor ( node -- infos )
|
||||
dup word>> {
|
||||
{ \ <tuple-boa> [ propagate-<tuple-boa> ] }
|
||||
{ \ <complex> [ propagate-<complex> ] }
|
||||
} case 1array ;
|
||||
|
||||
: relevant-methods ( node -- methods )
|
||||
[ word>> "methods" word-prop ]
|
||||
[ in-d>> first value-info class>> ] bi
|
||||
'[ drop , classes-intersect? ] assoc-filter ;
|
||||
|
||||
: relevant-slots ( node -- slots )
|
||||
relevant-methods [ nip "reading" word-prop ] { } assoc>map ;
|
||||
|
||||
: no-reader-methods ( input slots -- info )
|
||||
2drop null <class-info> ;
|
||||
|
||||
: same-offset ( slots -- slot/f )
|
||||
dup [ dup [ read-only>> ] when ] all? [
|
||||
[ offset>> ] map dup all-equal? [ first ] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: (reader-word-outputs) ( reader -- info )
|
||||
null
|
||||
[ [ class>> ] [ object ] if* class-or ] reduce
|
||||
<class-info> ;
|
||||
|
||||
: value-info-slot ( slot info -- info' )
|
||||
#! Delegation.
|
||||
[ class>> complex class<= 1 3 ? - ] keep
|
||||
dup literal?>> [
|
||||
literal>> {
|
||||
{ [ dup tuple? ] [
|
||||
tuple-slots 1 tail-slice nth <literal-info>
|
||||
] }
|
||||
{ [ dup complex? ] [
|
||||
[ real-part ] [ imaginary-part ] bi
|
||||
2array nth <literal-info>
|
||||
] }
|
||||
} cond
|
||||
] [ slots>> ?nth ] if ;
|
||||
|
||||
: reader-word-outputs ( node -- infos )
|
||||
[ relevant-slots ] [ in-d>> first ] bi
|
||||
over empty? [ no-reader-methods ] [
|
||||
over same-offset dup
|
||||
[ swap value-info value-info-slot ] [ 2drop f ] if
|
||||
[ ] [ (reader-word-outputs) ] ?if
|
||||
] if 1array ;
|
||||
|
||||
: reader-word-inputs ( node -- )
|
||||
[ in-d>> first ] [
|
||||
relevant-slots keys
|
||||
object [ class>> [ class-and ] when* ] reduce
|
||||
<class-info>
|
||||
] bi
|
||||
refine-value-info ;
|
|
@ -7,7 +7,7 @@ stack-checker.backend stack-checker.errors stack-checker.visitor
|
|||
IN: stack-checker.branches
|
||||
|
||||
: balanced? ( seq -- ? )
|
||||
[ first2 length - ] map all-equal? ;
|
||||
[ second ] filter [ first2 length - ] map all-equal? ;
|
||||
|
||||
: phi-inputs ( seq -- newseq )
|
||||
dup empty? [
|
||||
|
@ -16,7 +16,7 @@ IN: stack-checker.branches
|
|||
] unless ;
|
||||
|
||||
: unify-values ( values -- phi-out )
|
||||
dup [ known ] map dup all-eq?
|
||||
dup sift [ known ] map dup all-eq?
|
||||
[ nip first make-known ] [ 2drop <value> ] if ;
|
||||
|
||||
: phi-outputs ( phi-in -- stack )
|
||||
|
@ -25,7 +25,7 @@ IN: stack-checker.branches
|
|||
SYMBOL: quotations
|
||||
|
||||
: unify-branches ( ins stacks -- in phi-in phi-out )
|
||||
zip [ second ] filter dup empty? [ drop 0 { } { } ] [
|
||||
zip dup empty? [ drop 0 { } { } ] [
|
||||
dup balanced?
|
||||
[ [ keys supremum ] [ values phi-inputs dup phi-outputs ] bi ]
|
||||
[ quotations get unbalanced-branches-error ]
|
||||
|
|
Loading…
Reference in New Issue