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 stack-checker.dependencies ;
12 IN: stack-checker.transforms
14 : call-transformer ( stack quot -- newquot )
15 '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi ]
16 [ error-continuation get current-word get transform-expansion-error ]
19 :: ((apply-transform)) ( quot values stack rstate -- )
20 rstate recursive-state [ stack quot call-transformer ] with-variable
21 values [ length meta-d shorten-by ] [ #drop, ] bi
24 : literal-values? ( values -- ? ) [ literal-value? ] all? ;
26 : input-values? ( values -- ? )
27 [ { [ literal-value? ] [ input-value? ] } 1|| ] all? ;
29 : (apply-transform) ( quot n -- )
31 { [ dup literal-values? ] [
32 dup empty? [ dup recursive-state get ] [
34 [ [ literal value>> ] map ]
35 [ first literal recursion>> ] tri
39 { [ dup input-values? ] [ drop current-word get unknown-macro-input ] }
40 [ drop current-word get bad-macro-input ]
43 : apply-transform ( word -- )
45 [ "transform-quot" word-prop ]
46 [ "transform-n" word-prop ] tri
49 : apply-macro ( word -- )
51 [ "macro" word-prop '[ _ execute ] ]
52 [ "declared-effect" word-prop in>> length ] tri
55 : define-transform ( word quot n -- )
56 [ drop "transform-quot" set-word-prop ]
57 [ nip "transform-n" set-word-prop ]
61 \ cond [ cond>quot ] 1 define-transform
63 \ cond t "no-compile" set-word-prop
70 dup last swap but-last
77 \ case t "no-compile" set-word-prop
79 \ cleave [ cleave>quot ] 1 define-transform
81 \ cleave t "no-compile" set-word-prop
83 \ 2cleave [ 2cleave>quot ] 1 define-transform
85 \ 2cleave t "no-compile" set-word-prop
87 \ 3cleave [ 3cleave>quot ] 1 define-transform
89 \ 3cleave t "no-compile" set-word-prop
91 \ spread [ spread>quot ] 1 define-transform
93 \ spread t "no-compile" set-word-prop
95 \ 0&& [ '[ _ 0 n&& ] ] 1 define-transform
97 \ 0&& t "no-compile" set-word-prop
99 \ 1&& [ '[ _ 1 n&& ] ] 1 define-transform
101 \ 1&& t "no-compile" set-word-prop
103 \ 2&& [ '[ _ 2 n&& ] ] 1 define-transform
105 \ 2&& t "no-compile" set-word-prop
107 \ 3&& [ '[ _ 3 n&& ] ] 1 define-transform
109 \ 3&& t "no-compile" set-word-prop
111 \ 0|| [ '[ _ 0 n|| ] ] 1 define-transform
113 \ 0|| t "no-compile" set-word-prop
115 \ 1|| [ '[ _ 1 n|| ] ] 1 define-transform
117 \ 1|| t "no-compile" set-word-prop
119 \ 2|| [ '[ _ 2 n|| ] ] 1 define-transform
121 \ 2|| t "no-compile" set-word-prop
123 \ 3|| [ '[ _ 3 n|| ] ] 1 define-transform
125 \ 3|| t "no-compile" set-word-prop
127 : add-next-method-dependency ( method -- )
128 [ "method-class" word-prop ]
129 [ "method-generic" word-prop ] bi
131 depends-on-next-method ;
133 \ (call-next-method) [
134 [ add-next-method-dependency ]
135 [ [ next-method-quot ] [ '[ _ no-next-method ] ] bi or ] bi
138 \ (call-next-method) t "no-compile" set-word-prop
144 [ depends-on-tuple-layout ]
145 [ [ "boa-check" word-prop [ ] or ] dip ] 2bi
150 \ boa t "no-compile" set-word-prop