1 ! Copyright (C) 2009, 2011 Doug Coleman, John Benediktsson.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators effects fry
4 generalizations kernel macros math math.order memoize sequences
5 sequences.generalizations sequences.private stack-checker
6 stack-checker.backend stack-checker.errors stack-checker.values
7 stack-checker.visitor words ;
10 GENERIC: infer-known* ( known -- effect )
12 : infer-known ( value -- effect )
13 known dup (literal-value?) [
14 (literal) [ infer-literal-quot ] with-infer drop
15 ] [ infer-known* ] if ;
17 IDENTITY-MEMO: inputs/outputs ( quot -- in out )
18 infer [ in>> ] [ out>> ] bi [ length ] bi@ ;
20 : inputs ( quot -- n ) inputs/outputs drop ; inline
22 : outputs ( quot -- n ) inputs/outputs nip ; inline
27 [ pop-d 1array #drop, ]
28 [ [ in>> ] [ out>> ] bi [ length apply-object ] bi@ ] bi*
30 \ inputs/outputs dup required-stack-effect apply-word/effect
32 [ [ input-parameter swap set-known ] [ push-d ] bi ] bi@
34 ] "special" set-word-prop
36 M: curried-effect infer-known*
37 quot>> infer-known dup [
43 M: composed-effect infer-known*
44 [ quot1>> ] [ quot2>> ] bi
46 2dup and [ compose-effects ] [ 2drop f ] if ;
48 M: declared-effect infer-known*
49 known>> infer-known* ;
51 M: input-parameter infer-known* drop f ;
53 M: object infer-known* drop f ;
55 : drop-inputs ( quot -- )
58 : drop-outputs ( quot -- )
59 [ call ] [ outputs ndrop ] bi ; inline
61 : keep-inputs ( quot -- )
62 [ ] [ inputs ] bi nkeep ; inline
64 : output>sequence ( quot exemplar -- seq )
65 [ [ call ] [ outputs ] bi ] dip nsequence ; inline
67 : output>array ( quot -- array )
68 { } output>sequence ; inline
70 MACRO: output>sequence-n ( quot exemplar n -- quot )
71 3dup nip [ outputs ] dip - -rot
72 '[ @ [ _ _ nsequence ] _ ndip ] ;
74 MACRO: output>array-n ( quot n -- array )
75 '[ _ { } _ output>sequence-n ] ;
77 : cleave>array ( obj quots -- array )
78 '[ _ cleave ] output>array ; inline
80 : cleave>sequence ( x seq exemplar -- array )
81 [ '[ _ cleave ] ] dip output>sequence ; inline
83 : input<sequence ( seq quot -- )
84 [ inputs firstn ] [ call ] bi ; inline
86 : input<sequence-unsafe ( seq quot -- )
87 [ inputs firstn-unsafe ] [ call ] bi ; inline
89 : reduce-outputs ( quot operation -- )
90 [ [ call ] [ [ drop ] compose outputs ] bi ] dip swap call-n ; inline
92 : sum-outputs ( quot -- n )
93 [ + ] reduce-outputs ; inline
95 : map-outputs ( quot mapper -- )
96 [ drop call ] [ swap outputs ] 2bi napply ; inline
98 MACRO: map-reduce-outputs ( quot mapper reducer -- quot )
99 [ '[ _ _ map-outputs ] ] dip '[ _ _ reduce-outputs ] ;
101 : append-outputs-as ( quot exemplar -- seq )
102 [ [ call ] [ outputs ] bi ] dip nappend-as ; inline
104 : append-outputs ( quot -- seq )
105 { } append-outputs-as ; inline
107 : preserving ( quot -- )
108 [ inputs ndup ] [ call ] bi ; inline
110 : dropping ( quot -- quot' )
111 inputs '[ _ ndrop ] ; inline
113 : nullary ( quot -- )
114 dropping call ; inline
116 : smart-if ( pred true false -- )
117 [ preserving ] 2dip if ; inline
119 : smart-when ( pred true -- )
120 [ ] smart-if ; inline
122 : smart-unless ( pred false -- )
123 [ [ ] ] dip smart-if ; inline
125 : smart-if* ( pred true false -- )
126 [ [ [ preserving ] [ dropping ] bi ] dip swap ] dip compose if ; inline
128 : smart-when* ( pred true -- )
129 [ ] smart-if* ; inline
131 : smart-unless* ( pred false -- )
132 [ [ ] ] dip smart-if* ; inline
134 : smart-apply ( quot n -- )
135 [ dup inputs ] dip mnapply ; inline
137 : smart-with ( param obj quot -- obj curry )
138 swapd dup inputs '[ [ _ -nrot ] dip call ] 2curry ; inline
140 MACRO: smart-reduce ( reduce-quots -- quot )
141 unzip [ [ ] like ] bi@ dup length dup '[
142 [ @ ] dip [ @ _ cleave-curry _ spread* ] each
145 MACRO: smart-map-reduce ( map-reduce-quots -- quot )
146 [ keys ] [ [ [ ] concat-as ] [ ] map-as ] bi dup length dup '[
147 [ first _ cleave ] keep
148 [ @ _ cleave-curry _ spread* ]
152 MACRO: smart-2reduce ( 2reduce-quots -- quot )
153 unzip [ [ ] like ] bi@ dup length dup '[
155 [ @ _ [ cleave-curry ] [ cleave-curry ] bi _ spread* ] 2each
158 MACRO: smart-2map-reduce ( 2map-reduce-quots -- quot )
159 [ keys ] [ [ [ ] concat-as ] [ ] map-as ] bi dup length dup '[
160 [ [ first ] bi@ _ 2cleave ] 2keep
161 [ @ _ [ cleave-curry ] [ cleave-curry ] bi _ spread* ]