1 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors classes.struct classes.tuple
5 classes.tuple.private combinators combinators.short-circuit
6 continuations generic kernel namespaces quotations sequences
7 stack-checker.backend stack-checker.dependencies
8 stack-checker.errors stack-checker.recursive-state
9 stack-checker.values stack-checker.visitor words ;
11 IN: stack-checker.transforms
13 : call-transformer ( stack quot -- newquot )
14 '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi ]
15 [ error-continuation get current-word get transform-expansion-error ]
18 :: apply-literal-values-transform ( quot values stack rstate -- )
19 rstate recursive-state [ stack quot call-transformer ] with-variable
20 values [ length shorten-d ] [ #drop, ] bi
23 : literal-values? ( values -- ? ) [ literal-value? ] all? ;
25 : input-values? ( values -- ? )
26 [ { [ literal-value? ] [ input-value? ] } 1|| ] all? ;
28 : (apply-transform) ( quot n -- )
30 { [ dup literal-values? ] [
31 dup empty? [ dup recursive-state get ] [
33 [ [ literal value>> ] map ]
34 [ first literal recursion>> ] tri
36 apply-literal-values-transform
38 { [ dup input-values? ] [ drop current-word get unknown-macro-input ] }
39 [ drop current-word get bad-macro-input ]
42 : apply-transform ( word -- )
44 [ "transform-quot" word-prop ]
45 [ "transform-n" word-prop ] tri
48 : apply-macro ( word -- )
51 [ "declared-effect" word-prop in>> length ] tri
54 : define-transform ( word quot n -- )
55 [ drop "transform-quot" set-word-prop ]
56 [ nip "transform-n" set-word-prop ]
60 \ cond [ cond>quot ] 1 define-transform
62 \ cond t "no-compile" set-word-prop
68 dup [ callable? ] find dup
69 [ [ head ] dip ] [ 2drop [ no-case ] ] if
74 \ case t "no-compile" set-word-prop
76 \ cleave [ cleave>quot ] 1 define-transform
78 \ cleave t "no-compile" set-word-prop
80 \ 2cleave [ 2cleave>quot ] 1 define-transform
82 \ 2cleave t "no-compile" set-word-prop
84 \ 3cleave [ 3cleave>quot ] 1 define-transform
86 \ 3cleave t "no-compile" set-word-prop
88 \ 4cleave [ 4cleave>quot ] 1 define-transform
90 \ 4cleave t "no-compile" set-word-prop
92 \ spread [ deep-spread>quot ] 1 define-transform
94 \ spread t "no-compile" set-word-prop
96 \ 0&& [ '[ _ 0 n&& ] ] 1 define-transform
98 \ 0&& t "no-compile" set-word-prop
100 \ 1&& [ '[ _ 1 n&& ] ] 1 define-transform
102 \ 1&& t "no-compile" set-word-prop
104 \ 2&& [ '[ _ 2 n&& ] ] 1 define-transform
106 \ 2&& t "no-compile" set-word-prop
108 \ 3&& [ '[ _ 3 n&& ] ] 1 define-transform
110 \ 3&& t "no-compile" set-word-prop
112 \ 0|| [ '[ _ 0 n|| ] ] 1 define-transform
114 \ 0|| t "no-compile" set-word-prop
116 \ 1|| [ '[ _ 1 n|| ] ] 1 define-transform
118 \ 1|| t "no-compile" set-word-prop
120 \ 2|| [ '[ _ 2 n|| ] ] 1 define-transform
122 \ 2|| t "no-compile" set-word-prop
124 \ 3|| [ '[ _ 3 n|| ] ] 1 define-transform
126 \ 3|| t "no-compile" set-word-prop
128 : add-next-method-dependency ( method -- )
129 [ "method-class" word-prop ]
130 [ "method-generic" word-prop ] bi
132 add-depends-on-next-method ;
134 \ (call-next-method) [
135 [ add-next-method-dependency ]
136 [ [ next-method-quot ] [ '[ _ no-next-method ] ] bi or ] bi
139 \ (call-next-method) t "no-compile" set-word-prop
144 { [ dup struct-class? ] [
145 dup dup struct-slots add-depends-on-struct-slots
146 '[ _ <struct-boa> ] ] }
147 { [ dup tuple-class? ] [
149 [ add-depends-on-tuple-layout ]
150 [ [ "boa-check" word-prop [ ] or ] dip ] 2bi
157 \ boa t "no-compile" set-word-prop