1 ! Copyright (C) 2007, 2009 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 locals
7 generalizations stack-checker.backend stack-checker.state
8 stack-checker.visitor stack-checker.errors stack-checker.values
9 stack-checker.recursive-state ;
10 IN: stack-checker.transforms
12 : give-up-transform ( word -- )
14 [ call-recursive-word ]
15 [ dup infer-word apply-word/effect ]
18 :: ((apply-transform)) ( word quot values stack rstate -- )
19 rstate recursive-state
20 [ stack quot with-datastack first ] with-variable
22 word inlined-dependency depends-on
23 values [ length meta-d shorten-by ] [ #drop, ] bi
25 ] [ word give-up-transform ] if* ;
27 : literals? ( values -- ? ) [ literal-value? ] all? ;
29 : (apply-transform) ( word quot n -- )
30 ensure-d dup literals? [
31 dup empty? [ dup recursive-state get ] [
33 [ [ literal value>> ] map ]
34 [ first literal recursion>> ] tri
37 ] [ 2drop give-up-transform ] if ;
39 : apply-transform ( word -- )
40 [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
43 : apply-macro ( word -- )
44 [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri
47 : define-transform ( word quot n -- )
48 [ drop "transform-quot" set-word-prop ]
49 [ nip "transform-n" set-word-prop ]
53 \ cond [ cond>quot ] 1 define-transform
60 dup peek swap but-last
67 \ cleave [ cleave>quot ] 1 define-transform
69 \ 2cleave [ 2cleave>quot ] 1 define-transform
71 \ 3cleave [ 3cleave>quot ] 1 define-transform
73 \ spread [ spread>quot ] 1 define-transform
75 \ (call-next-method) [
77 [ "method-class" word-prop ]
78 [ "method-generic" word-prop ] bi
79 [ inlined-dependency depends-on ] bi@
82 [ '[ _ no-next-method ] ] bi or
89 dup inlined-dependency depends-on
90 [ "boa-check" word-prop [ ] or ]
91 [ tuple-layout '[ _ <tuple-boa> ] ]
98 dup inlined-dependency depends-on
100 [ all-slots [ initial>> literalize , ] each ]
108 CONSTANT: bit-member-n 256
110 : bit-member? ( seq -- ? )
111 #! Can we use a fast byte array test here?
113 { [ dup length 8 < ] [ f ] }
114 { [ dup [ integer? not ] any? ] [ f ] }
115 { [ dup [ 0 < ] any? ] [ f ] }
116 { [ dup [ bit-member-n >= ] any? ] [ f ] }
120 : bit-member-seq ( seq -- flags )
121 bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
123 : exact-float? ( f -- ? )
124 dup float? [ dup >integer >float = ] [ drop f ] if ; inline
126 : bit-member-quot ( seq -- newquot )
131 { [ over fixnum? ] [ ?nth 1 eq? ] }
132 { [ over bignum? ] [ ?nth 1 eq? ] }
133 { [ over exact-float? ] [ ?nth 1 eq? ] }
139 : member-quot ( seq -- newquot )
143 [ literalize [ t ] ] { } map>assoc
144 [ drop f ] suffix [ case ] curry
148 dup sequence? [ member-quot ] [ drop f ] if
151 : memq-quot ( seq -- newquot )
152 [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
153 [ drop f ] suffix [ cond ] curry ;
156 dup sequence? [ memq-quot ] [ drop f ] if
160 : nths-quot ( indices -- quot )
161 [ [ '[ _ swap nth ] ] map ] [ length ] bi
162 '[ _ cleave _ narray ] ;
165 shuffle-mapping nths-quot