1 ! Copyright (C) 2009, 2011 Doug Coleman, John Benediktsson.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators effects
4 generalizations kernel math sequences sequences.generalizations
5 stack-checker stack-checker.backend stack-checker.values
6 stack-checker.visitor words ;
9 GENERIC: infer-known* ( known -- effect )
11 : infer-known ( value -- effect )
12 known dup (literal-value?) [
13 (literal) [ infer-literal-quot ] with-infer drop
14 ] [ infer-known* ] if ;
16 IDENTITY-MEMO: inputs/outputs ( quot -- in out )
17 infer [ in>> ] [ out>> ] bi 2length ;
19 : inputs ( quot -- n ) inputs/outputs drop ; inline
21 : outputs ( quot -- n ) inputs/outputs nip ; inline
26 [ pop-d 1array #drop, ]
27 [ [ in>> ] [ out>> ] bi [ length apply-object ] bi@ ] bi*
29 \ inputs/outputs dup required-stack-effect apply-word/effect
31 [ [ input-parameter swap set-known ] [ push-d ] bi ] bi@
33 ] "special" set-word-prop
35 M: curried-effect infer-known*
36 quot>> infer-known dup [
42 M: composed-effect infer-known*
43 [ quot1>> ] [ quot2>> ] bi
45 2dup and [ compose-effects ] [ 2drop f ] if ;
47 M: declared-effect infer-known*
48 known>> infer-known* ;
50 M: input-parameter infer-known* drop f ;
52 M: object infer-known* drop f ;
54 : drop-inputs ( quot -- )
57 : drop-outputs ( quot -- )
58 [ call ] [ outputs ndrop ] bi ; inline
60 : keep-inputs ( quot -- )
61 [ ] [ inputs ] bi nkeep ; inline
63 : output>sequence ( quot exemplar -- seq )
64 [ [ call ] [ outputs ] bi ] dip nsequence ; inline
66 : output>array ( quot -- array )
67 { } output>sequence ; inline
69 MACRO: output>sequence-n ( quot exemplar n -- quot )
70 3dup nip [ outputs ] dip - -rot
71 '[ @ [ _ _ nsequence ] _ ndip ] ;
73 MACRO: output>array-n ( quot n -- array )
74 '[ _ { } _ output>sequence-n ] ;
76 : cleave>array ( obj quots -- array )
77 '[ _ cleave ] output>array ; inline
79 : cleave>sequence ( x seq exemplar -- array )
80 [ '[ _ cleave ] ] dip output>sequence ; inline
82 : input<sequence ( seq quot -- )
83 [ inputs firstn ] [ call ] bi ; inline
85 : input<sequence-unsafe ( seq quot -- )
86 [ inputs firstn-unsafe ] [ call ] bi ; inline
88 : reduce-outputs ( quot operation -- )
89 [ [ call ] [ [ drop ] compose outputs ] bi ] dip swap call-n ; inline
91 : sum-outputs ( quot -- n )
92 [ + ] reduce-outputs ; inline
94 : map-outputs ( quot mapper -- )
95 [ drop call ] [ swap outputs ] 2bi napply ; inline
97 MACRO: map-reduce-outputs ( quot mapper reducer -- quot )
98 [ '[ _ _ map-outputs ] ] dip '[ _ _ reduce-outputs ] ;
100 : append-outputs-as ( quot exemplar -- seq )
101 [ [ call ] [ outputs ] bi ] dip nappend-as ; inline
103 : append-outputs ( quot -- seq )
104 { } append-outputs-as ; inline
106 : preserving ( quot -- )
107 [ inputs ndup ] [ call ] bi ; inline
109 : dropping ( quot -- quot' )
110 inputs '[ _ ndrop ] ; inline
112 : nullary ( quot -- )
113 dropping call ; inline
115 : smart-if ( pred true false -- )
116 [ preserving ] 2dip if ; inline
118 : smart-when ( pred true -- )
119 [ ] smart-if ; inline
121 : smart-unless ( pred false -- )
122 [ [ ] ] dip smart-if ; inline
124 : smart-if* ( pred true false -- )
125 [ [ [ preserving ] [ dropping ] bi ] dip swap ] dip compose if ; inline
127 : smart-when* ( pred true -- )
128 [ ] smart-if* ; inline
130 : smart-unless* ( pred false -- )
131 [ [ ] ] dip smart-if* ; inline
133 : smart-apply ( quot n -- )
134 [ dup inputs ] dip mnapply ; inline
136 : smart-with ( param obj quot -- obj curry )
137 swapd dup inputs '[ [ _ -nrot ] dip call ] 2curry ; inline
139 MACRO: smart-reduce ( reduce-quots -- quot )
140 unzip [ [ ] like ] bi@ dup length dup '[
141 _ dip [ @ _ cleave-curry _ spread* ] each
144 MACRO: smart-map-reduce ( map-reduce-quots -- quot )
145 [ keys ] [ [ [ ] concat-as ] [ ] map-as ] bi dup length dup '[
146 [ first _ cleave ] keep
147 [ @ _ cleave-curry _ spread* ]
151 MACRO: smart-2reduce ( 2reduce-quots -- quot )
152 unzip [ [ ] like ] bi@ dup length dup '[
154 [ @ _ [ cleave-curry ] [ cleave-curry ] bi _ spread* ] 2each
157 MACRO: smart-2map-reduce ( 2map-reduce-quots -- quot )
158 [ keys ] [ [ [ ] concat-as ] [ ] map-as ] bi dup length dup '[
159 [ [ first ] bi@ _ 2cleave ] 2keep
160 [ @ _ [ cleave-curry ] [ cleave-curry ] bi _ spread* ]
164 : smart-loop ( ..a quot: ( ..a -- ..b ? ) -- ..b )
165 dup outputs [ ndrop ] curry while* ; inline