1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators continuations fry
4 generic kernel locals locals.types math quotations sequences
5 sequences.generalizations sets smalltalk.ast smalltalk.classes
6 smalltalk.compiler.assignment smalltalk.compiler.lexenv
7 smalltalk.compiler.return smalltalk.selectors splitting vocabs
11 GENERIC: compile-ast ( lexenv ast -- quot )
13 M: object compile-ast nip 1quotation ;
15 M: self compile-ast drop self>> 1quotation ;
17 ERROR: unbound-local name ;
19 M: ast-name compile-ast name>> swap lookup-reader ;
21 : compile-arguments ( lexenv ast -- quot )
22 arguments>> [ compile-ast ] with map [ ] join ;
24 : compile-new ( lexenv ast -- quot )
25 [ receiver>> compile-ast ]
26 [ compile-arguments ] 2bi
29 : compile-ifTrue:ifFalse: ( lexenv ast -- quot )
30 [ receiver>> compile-ast ]
31 [ compile-arguments ] 2bi
34 M: ast-message-send compile-ast
36 { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
37 { "new" [ compile-new ] }
41 [ receiver>> compile-ast ]
42 [ nip selector>> selector>generic ]
43 2tri [ append ] dip suffix
47 M: ast-cascade compile-ast
48 [ receiver>> compile-ast ]
51 [ compile-arguments \ dip ]
52 [ selector>> selector>generic ] bi
55 unclip-last [ [ [ drop ] append ] map ] dip suffix
59 M: ast-return compile-ast
60 [ value>> compile-ast ] [ drop return>> 1quotation ] 2bi
61 [ continue-with ] 3append ;
63 : (compile-sequence) ( lexenv asts -- quot )
65 [ compile-ast ] with map [ drop ] join
68 : block-lexenv ( block -- lexenv )
69 [ [ arguments>> ] [ temporaries>> ] bi append ]
70 [ body>> [ assigned-locals ] map concat unique ] bi
78 [ nip local-reader? ] assoc-filter
79 [ <local-writer> ] assoc-map
80 <lexenv> swap >>local-writers swap >>local-readers ;
82 : lookup-block-vars ( vars lexenv -- seq )
83 local-readers>> '[ _ at ] map ;
85 : make-temporaries ( block lexenv -- quot )
86 [ temporaries>> ] dip lookup-block-vars
87 [ <def> [ f ] swap suffix ] map [ ] join ;
89 :: compile-sequence ( lexenv block -- vars quot )
90 lexenv block block-lexenv lexenv-union :> lexenv
91 block arguments>> lexenv lookup-block-vars
92 lexenv block body>> (compile-sequence) block lexenv make-temporaries prepend ;
94 M: ast-sequence compile-ast
95 compile-sequence nip ;
97 GENERIC: contains-blocks? ( obj -- ? )
99 M: ast-block contains-blocks? drop t ;
101 M: object contains-blocks? drop f ;
103 M: array contains-blocks? [ contains-blocks? ] any? ;
106 dup contains-blocks? [
107 [ [ compile-ast ] with map [ ] join ] [ length ] bi
109 ] [ call-next-method ] if ;
111 GENERIC: compile-assignment ( lexenv name -- quot )
113 M: ast-name compile-assignment name>> swap lookup-writer ;
115 M: ast-assignment compile-ast
116 [ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
118 M: ast-block compile-ast
119 compile-sequence <lambda> '[ _ ] ;
121 :: (compile-method-body) ( lexenv block -- lambda )
122 lexenv block compile-sequence
123 [ lexenv self>> suffix ] dip <lambda> ;
125 : compile-method-body ( lexenv block -- quot )
126 [ [ (compile-method-body) ] [ arguments>> length 1 + ] bi ] 2keep
129 : compile-method ( lexenv ast-method -- )
130 [ [ class>> ] [ name>> selector>generic ] bi* create-method ]
131 [ body>> compile-method-body ]
134 : <class-lexenv> ( class -- lexenv )
135 <lexenv> swap >>class "self" <local> >>self "^" <local> >>return ;
137 M: ast-class compile-ast
140 [ name>> ] [ superclass>> ] [ ivars>> ] tri
141 define-class <class-lexenv>
144 [ compile-method ] with each
147 ERROR: no-word name ;
149 M: ast-foreign compile-ast
151 [ class>> dup ":" split1 lookup-word [ ] [ no-word ] ?if ]
152 [ name>> ] bi define-foreign
155 : compile-smalltalk ( statement -- quot )
156 [ empty-lexenv ] dip [ compile-sequence nip 0 ]