1 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: fry accessors arrays kernel kernel.private combinators.private
4 words sequences generic math math.order namespaces quotations
5 assocs combinators combinators.short-circuit classes.tuple
6 classes.tuple.private effects summary hashtables classes sets
7 definitions generic.standard slots.private continuations locals
8 sequences.private generalizations stack-checker.backend
9 stack-checker.state stack-checker.visitor stack-checker.errors
10 stack-checker.values stack-checker.recursive-state ;
11 IN: stack-checker.transforms
13 : call-transformer ( word stack quot -- newquot )
14 '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
15 [ transform-expansion-error ]
18 :: ((apply-transform)) ( word quot values stack rstate -- )
19 rstate recursive-state
20 [ word stack quot call-transformer ] with-variable
22 values [ length meta-d shorten-by ] [ #drop, ] bi
24 ] [ word infer-word ] if* ;
26 : literals? ( values -- ? ) [ literal-value? ] all? ;
28 : (apply-transform) ( word quot n -- )
29 ensure-d dup literals? [
30 dup empty? [ dup recursive-state get ] [
32 [ [ literal value>> ] map ]
33 [ first literal recursion>> ] tri
36 ] [ 2drop infer-word ] if ;
38 : apply-transform ( word -- )
39 [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
42 : apply-macro ( word -- )
43 [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri
46 : define-transform ( word quot n -- )
47 [ drop "transform-quot" set-word-prop ]
48 [ nip "transform-n" set-word-prop ]
52 \ cond [ cond>quot ] 1 define-transform
54 \ cond t "no-compile" set-word-prop
61 dup last swap but-last
68 \ case t "no-compile" set-word-prop
70 \ cleave [ cleave>quot ] 1 define-transform
72 \ cleave t "no-compile" set-word-prop
74 \ 2cleave [ 2cleave>quot ] 1 define-transform
76 \ 2cleave t "no-compile" set-word-prop
78 \ 3cleave [ 3cleave>quot ] 1 define-transform
80 \ 3cleave t "no-compile" set-word-prop
82 \ spread [ spread>quot ] 1 define-transform
84 \ spread t "no-compile" set-word-prop
86 \ (call-next-method) [
88 [ "method-class" word-prop ]
89 [ "method-generic" word-prop ] bi
90 [ inlined-dependency depends-on ] bi@
93 [ '[ _ no-next-method ] ] bi or
97 \ (call-next-method) t "no-compile" set-word-prop
102 dup inlined-dependency depends-on
103 [ "boa-check" word-prop [ ] or ]
104 [ tuple-layout '[ _ <tuple-boa> ] ]
109 \ boa t "no-compile" set-word-prop
113 dup inlined-dependency depends-on
114 [ all-slots [ initial>> literalize ] map ]
115 [ tuple-layout '[ _ <tuple-boa> ] ]
120 ! Fast at for integer maps
121 CONSTANT: lookup-table-at-max 256
123 : lookup-table-at? ( assoc -- ? )
124 #! Can we use a fast byte array test here?
128 [ keys [ integer? ] all? ]
129 [ keys [ 0 lookup-table-at-max between? ] all? ]
132 : lookup-table-seq ( assoc -- table )
133 [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
135 : lookup-table-quot ( seq -- newquot )
140 nth-unsafe dup >boolean
145 : fast-lookup-table-at? ( assoc -- ? )
147 [ [ integer? ] all? ]
148 [ [ 0 254 between? ] all? ]
151 : fast-lookup-table-seq ( assoc -- table )
152 lookup-table-seq [ 255 or ] B{ } map-as ;
154 : fast-lookup-table-quot ( seq -- newquot )
155 fast-lookup-table-seq
159 nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
164 : at-quot ( assoc -- quot )
165 dup lookup-table-at? [
166 dup fast-lookup-table-at? [
167 fast-lookup-table-quot
173 \ at* [ at-quot ] 1 define-transform
176 : member-quot ( seq -- newquot )
179 [ literalize [ t ] ] { } map>assoc linear-case-quot
181 unique [ key? ] curry
185 dup sequence? [ member-quot ] [ drop f ] if
188 : memq-quot ( seq -- newquot )
189 [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
190 [ drop f ] suffix [ cond ] curry ;
193 dup sequence? [ memq-quot ] [ drop f ] if
200 dup length zip >hashtable '[ _ at ]
206 : nths-quot ( indices -- quot )
207 [ [ '[ _ swap nth ] ] map ] [ length ] bi
208 '[ _ cleave _ narray ] ;
211 shuffle-mapping nths-quot