1 ! Copyright (C) 2009, 2010, 2011 Joe Groff, Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays classes classes.algebra classes.tuple
4 classes.struct combinators combinators.short-circuit definitions
5 effects effects.parser fry generalizations kernel kernel.private
6 locals.parser quotations sequences slots stack-checker.dependencies
8 FROM: classes.tuple.private => tuple-layout ;
11 ERROR: type-mismatch-error value expected-type word expected-types ;
12 ERROR: input-mismatch-error < type-mismatch-error ;
13 ERROR: output-mismatch-error < type-mismatch-error ;
14 ERROR: no-types-specified word effect ;
16 PREDICATE: typed-gensym < word "typed-gensym" word-prop >boolean ;
17 PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
21 : unboxable-tuple-class? ( type -- ? )
23 [ only-classoid? not ]
24 [ all-slots empty? not ]
25 [ immutable-tuple-class? ]
27 [ struct-class? not ] ! for struct boa change
32 : typed-stack-effect? ( effect -- ? )
33 [ object = ] all? not ;
35 : add-depends-on-unboxing ( class -- )
36 [ dup tuple-layout add-depends-on-tuple-layout ]
37 [ add-depends-on-final ]
40 : (unboxer) ( type -- quot )
41 dup unboxable-tuple-class? [
42 dup add-depends-on-unboxing
44 [ name>> reader-word 1quotation ]
45 [ class>> (unboxer) ] bi compose
46 ] map [ cleave ] curry
49 :: unboxer ( error-quot word types type -- quot )
50 type word? [ type "coercer" word-prop ] [ f ] if [ ] or
51 type type word types error-quot '[ dup _ instance? [ _ _ _ @ ] unless ]
55 : make-unboxer ( error-quot word types -- quot )
56 dup [ unboxer ] 3 nwith
57 [ swap \ dip [ ] 2sequence prepend ] map-reduce ;
59 : (unboxed-types) ( type -- types )
60 dup unboxable-tuple-class?
62 dup add-depends-on-unboxing
63 all-slots [ class>> (unboxed-types) ] map concat
67 : unboxed-types ( types -- types' )
68 [ (unboxed-types) ] map concat ;
70 :: typed-inputs ( quot word types -- quot' )
71 types unboxed-types :> unboxed-types
73 [ input-mismatch-error ] word types make-unboxer
74 unboxed-types quot '[ _ declare @ ]
79 :: typed-outputs ( quot word types -- quot' )
80 [ output-mismatch-error ] word types make-unboxer
85 : boxer ( type -- quot )
86 dup unboxable-tuple-class?
88 dup add-depends-on-unboxing
89 [ all-slots [ class>> ] map make-boxer ]
95 : make-boxer ( types -- quot )
97 [ [ boxer ] [ swap '[ @ _ dip ] ] map-reduce ] if-empty ;
99 ! defining typed words
101 MACRO: (typed) ( word def effect -- quot )
104 nip effect-in-types swap
105 [ [ unboxed-types ] [ make-boxer ] bi ] dip
110 dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
113 : <typed-gensym> ( parent-word -- word )
114 [ name>> "( typed " " )" surround f <word> dup ]
115 [ "typed-gensym" set-word-prop ] bi ;
117 : unboxed-effect ( effect -- effect' )
118 [ effect-in-types unboxed-types [ "in" swap 2array ] map ]
119 [ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi <effect> ;
121 M: typed-gensym stack-effect call-next-method unboxed-effect ;
122 M: typed-gensym parent-word "typed-gensym" word-prop ;
123 M: typed-gensym crossref? parent-word crossref? ;
124 M: typed-gensym where parent-word where ;
126 : define-typed-gensym ( word def effect -- gensym )
127 [ 2drop <typed-gensym> dup ]
128 [ [ (typed) ] 3curry ]
129 [ 2nip ] 3tri define-declared ;
131 MACRO: typed ( quot word effect -- quot' )
132 [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
134 nip effect-out-types dup typed-stack-effect?
135 [ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if
138 : (typed-def) ( word def effect -- quot )
139 [ define-typed-gensym ] 3keep
140 [ drop [ swap "typed-word" set-word-prop ] [ [ 1quotation ] dip ] 2bi ] dip
143 : typed-def? ( effect -- quot )
145 [ effect-in-types typed-stack-effect? ]
146 [ effect-out-types typed-stack-effect? ]
149 : typed-def ( word def effect -- quot )
151 [ (typed-def) ] [ nip no-types-specified ] if ;
153 M: typed-word subwords
155 [ "typed-word" word-prop ] bi suffix ;
159 : define-typed ( word def effect -- )
160 [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
161 [ drop "typed-def" set-word-prop ]
162 [ 2drop "typed-word" word-prop set-last-word ] 3tri ;
171 { "typed" "prettyprint" } "typed.prettyprint" require-when
172 { "typed" "compiler.cfg.debugger" } "typed.debugger" require-when