1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators.short-circuit
4 continuations fry kernel namespaces quotations sequences sets
5 generalizations sequences.generalizations slots locals.types
6 splitting math locals.rewrite.closures generic words combinators
7 locals smalltalk.ast smalltalk.compiler.lexenv
8 smalltalk.compiler.assignment smalltalk.compiler.return
9 smalltalk.selectors smalltalk.classes ;
10 IN: smalltalk.compiler
12 GENERIC: compile-ast ( lexenv ast -- quot )
14 M: object compile-ast nip 1quotation ;
16 M: self compile-ast drop self>> 1quotation ;
18 ERROR: unbound-local name ;
20 M: ast-name compile-ast name>> swap lookup-reader ;
22 : compile-arguments ( lexenv ast -- quot )
23 arguments>> [ compile-ast ] with map [ ] join ;
25 : compile-new ( lexenv ast -- quot )
26 [ receiver>> compile-ast ]
27 [ compile-arguments ] 2bi
30 : compile-ifTrue:ifFalse: ( lexenv ast -- quot )
31 [ receiver>> compile-ast ]
32 [ compile-arguments ] 2bi
35 M: ast-message-send compile-ast
37 { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
38 { "new" [ compile-new ] }
42 [ receiver>> compile-ast ]
43 [ nip selector>> selector>generic ]
44 2tri [ append ] dip suffix
48 M: ast-cascade compile-ast
49 [ receiver>> compile-ast ]
52 [ compile-arguments \ dip ]
53 [ selector>> selector>generic ] bi
56 unclip-last [ [ [ drop ] append ] map ] dip suffix
60 M: ast-return compile-ast
61 [ value>> compile-ast ] [ drop return>> 1quotation ] 2bi
62 [ continue-with ] 3append ;
64 : (compile-sequence) ( lexenv asts -- quot )
66 [ compile-ast ] with map [ drop ] join
69 : block-lexenv ( block -- lexenv )
70 [ [ arguments>> ] [ temporaries>> ] bi append ]
71 [ body>> [ assigned-locals ] map concat unique ] bi
79 [ nip local-reader? ] assoc-filter
80 [ <local-writer> ] assoc-map
81 <lexenv> swap >>local-writers swap >>local-readers ;
83 : lookup-block-vars ( vars lexenv -- seq )
84 local-readers>> '[ _ at ] map ;
86 : make-temporaries ( block lexenv -- quot )
87 [ temporaries>> ] dip lookup-block-vars
88 [ <def> [ f ] swap suffix ] map [ ] join ;
90 :: compile-sequence ( lexenv block -- vars quot )
91 lexenv block block-lexenv lexenv-union :> lexenv
92 block arguments>> lexenv lookup-block-vars
93 lexenv block body>> (compile-sequence) block lexenv make-temporaries prepend ;
95 M: ast-sequence compile-ast
96 compile-sequence nip ;
98 GENERIC: contains-blocks? ( obj -- ? )
100 M: ast-block contains-blocks? drop t ;
102 M: object contains-blocks? drop f ;
104 M: array contains-blocks? [ contains-blocks? ] any? ;
107 dup contains-blocks? [
108 [ [ compile-ast ] with map [ ] join ] [ length ] bi
110 ] [ call-next-method ] if ;
112 GENERIC: compile-assignment ( lexenv name -- quot )
114 M: ast-name compile-assignment name>> swap lookup-writer ;
116 M: ast-assignment compile-ast
117 [ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
119 M: ast-block compile-ast
120 compile-sequence <lambda> '[ _ ] ;
122 :: (compile-method-body) ( lexenv block -- lambda )
123 lexenv block compile-sequence
124 [ lexenv self>> suffix ] dip <lambda> ;
126 : compile-method-body ( lexenv block -- quot )
127 [ [ (compile-method-body) ] [ arguments>> length 1 + ] bi ] 2keep
130 : compile-method ( lexenv ast-method -- )
131 [ [ class>> ] [ name>> selector>generic ] bi* create-method ]
132 [ body>> compile-method-body ]
135 : <class-lexenv> ( class -- lexenv )
136 <lexenv> swap >>class "self" <local> >>self "^" <local> >>return ;
138 M: ast-class compile-ast
141 [ name>> ] [ superclass>> ] [ ivars>> ] tri
142 define-class <class-lexenv>
145 [ compile-method ] with each
148 ERROR: no-word name ;
150 M: ast-foreign compile-ast
152 [ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ]
153 [ name>> ] bi define-foreign
156 : compile-smalltalk ( statement -- quot )
157 [ empty-lexenv ] dip [ compile-sequence nip 0 ]