1 ! Copyright (C) 2007, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: fry accessors arrays kernel words sequences generic math
4 namespaces make quotations assocs combinators classes.tuple
5 classes.tuple.private effects summary hashtables classes generic
6 sets definitions generic.standard slots.private continuations
7 stack-checker.backend stack-checker.state stack-checker.visitor
9 IN: stack-checker.transforms
11 : give-up-transform ( word -- )
13 [ call-recursive-word ]
14 [ dup infer-word apply-word/effect ]
17 : ((apply-transform)) ( word quot values stack -- )
18 rot with-datastack first2
22 [ length meta-d get '[ _ pop* ] times ]
29 3drop give-up-transform
32 : (apply-transform) ( word quot n -- )
33 ensure-d dup [ known literal? ] all? [
35 recursive-state get 1array
38 [ [ literal value>> ] map ]
39 [ first literal recursion>> ] tri
43 ] [ 2drop give-up-transform ] if ;
45 : apply-transform ( word -- )
46 [ inlined-dependency depends-on ] [
48 [ "transform-quot" word-prop ]
49 [ "transform-n" word-prop ]
54 : apply-macro ( word -- )
55 [ inlined-dependency depends-on ] [
58 [ "declared-effect" word-prop in>> length ]
63 : define-transform ( word quot n -- )
64 [ drop "transform-quot" set-word-prop ]
65 [ nip "transform-n" set-word-prop ]
69 \ cond [ cond>quot ] 1 define-transform
76 dup peek swap but-last
83 \ cleave [ cleave>quot ] 1 define-transform
85 \ 2cleave [ 2cleave>quot ] 1 define-transform
87 \ 3cleave [ 3cleave>quot ] 1 define-transform
89 \ spread [ spread>quot ] 1 define-transform
91 \ (call-next-method) [
92 [ [ inlined-dependency depends-on ] bi@ ] [ next-method-quot ] 2bi
98 dup inlined-dependency depends-on
99 [ "boa-check" word-prop ]
100 [ tuple-layout '[ _ <tuple-boa> ] ]
107 dup inlined-dependency depends-on
109 [ all-slots [ initial>> literalize , ] each ]
117 : bit-member-n 256 ; inline
119 : bit-member? ( seq -- ? )
120 #! Can we use a fast byte array test here?
122 { [ dup length 8 < ] [ f ] }
123 { [ dup [ integer? not ] contains? ] [ f ] }
124 { [ dup [ 0 < ] contains? ] [ f ] }
125 { [ dup [ bit-member-n >= ] contains? ] [ f ] }
129 : bit-member-seq ( seq -- flags )
130 bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
132 : exact-float? ( f -- ? )
133 dup float? [ dup >integer >float = ] [ drop f ] if ; inline
135 : bit-member-quot ( seq -- newquot )
140 { [ over fixnum? ] [ ?nth 1 eq? ] }
141 { [ over bignum? ] [ ?nth 1 eq? ] }
142 { [ over exact-float? ] [ ?nth 1 eq? ] }
148 : member-quot ( seq -- newquot )
152 [ literalize [ t ] ] { } map>assoc
153 [ drop f ] suffix [ case ] curry
157 dup sequence? [ member-quot ] [ drop f ] if
160 : memq-quot ( seq -- newquot )
161 [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
162 [ drop f ] suffix [ cond ] curry ;
165 dup sequence? [ memq-quot ] [ drop f ] if