1 ! Copyright (C) 2006, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays classes combinators kernel make math
4 math.order math.parser sequences sequences.private strings words ;
9 { out array read-only }
10 { terminated? read-only }
12 { out-var read-only } ;
14 : ?terminated ( out -- out terminated? )
15 dup { "*" } = [ drop { } t ] [ f ] if ;
17 : <effect> ( in out -- effect )
18 ?terminated f f effect boa ;
20 : <terminated-effect> ( in out terminated? -- effect )
21 f f effect boa ; inline
23 : <variable-effect> ( in-var in out-var out -- effect )
24 swap rotd [ ?terminated ] 2dip effect boa ;
26 : effect-height ( effect -- n )
27 [ out>> length ] [ in>> length ] bi - ; inline
29 : variable-effect? ( effect -- ? )
30 dup in-var>> [ drop t ] [ out-var>> ] if ;
32 : bivariable-effect? ( effect -- ? )
33 [ in-var>> ] [ out-var>> ] bi = not ;
35 : effect<= ( effect1 effect2 -- ? )
37 { [ over terminated?>> ] [ t ] }
38 { [ dup terminated?>> ] [ f ] }
39 { [ 2dup [ bivariable-effect? ] either? ] [ f ] }
40 { [ 2dup [ variable-effect? ] [ variable-effect? not ] bi* and ] [ f ] }
41 { [ 2dup [ in>> length ] bi@ > ] [ f ] }
42 { [ 2dup [ effect-height ] same? not ] [ f ] }
46 : effect= ( effect1 effect2 -- ? )
47 2dup [ in>> length ] same? [
48 2dup [ out>> length ] same? [
49 [ terminated?>> ] same?
53 GENERIC: effect>string ( obj -- str )
54 M: string effect>string ;
55 M: object effect>string drop "object" ;
56 M: word effect>string name>> ;
57 M: integer effect>string number>string ;
60 [ effect>string ] bi@ ": " glue
62 nip effect>string ":" prepend
67 : stack-picture% ( seq -- )
68 [ effect>string % CHAR: \s , ] each ;
70 : var-picture% ( var -- )
71 [ ".." % % CHAR: \s , ] when* ;
75 M: effect effect>string
78 dup in-var>> var-picture%
79 dup in>> stack-picture% "-- " %
80 dup out-var>> var-picture%
81 dup out>> stack-picture%
82 dup terminated?>> [ "* " % ] when
87 GENERIC: effect>type ( obj -- type )
88 M: object effect>type drop object ;
90 M: pair effect>type second-unsafe effect>type ;
91 M: classoid effect>type ;
93 : effect-in-types ( effect -- input-types )
94 in>> [ effect>type ] map ;
96 : effect-out-types ( effect -- input-types )
97 out>> [ effect>type ] map ;
99 GENERIC: stack-effect ( word -- effect/f )
102 dup "declared-effect" word-prop [ nip ] [
103 parent-word dup [ stack-effect ] when
106 M: deferred stack-effect call-next-method ( -- * ) or ;
115 } cleave effect boa ;
117 : stack-height ( word -- n )
118 stack-effect effect-height ; inline
120 : shuffle-mapping ( effect -- mapping )
121 [ out>> ] [ in>> ] bi [ index ] curry map ;
123 : shuffle ( stack shuffle -- newstack )
124 shuffle-mapping swap nths ;
126 : add-effect-input ( effect -- effect' )
127 [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri
128 <terminated-effect> ;
130 : compose-effects ( effect1 effect2 -- effect' )
134 [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
135 [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
136 [ nip terminated?>> ] 2tri
137 [ [ "x" <array> ] bi@ ] dip
141 : curry-effect ( effect -- effect' )
142 [ in>> length ] [ out>> length ] [ terminated?>> ] tri
143 pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
144 [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;
146 ERROR: bad-stack-effect word got expected ;
148 : check-stack-effect ( word effect -- )
149 over stack-effect 2dup effect=
150 [ 3drop ] [ bad-stack-effect ] if ;