1 ! Copyright (C) 2009 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators continuations
4 generic kernel 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 words ;
10 GENERIC: compile-ast ( lexenv ast -- quot )
12 M: object compile-ast nip 1quotation ;
14 M: self compile-ast drop self>> 1quotation ;
16 ERROR: unbound-local name ;
18 M: ast-name compile-ast name>> swap lookup-reader ;
20 : compile-arguments ( lexenv ast -- quot )
21 arguments>> [ compile-ast ] with map [ ] join ;
23 : compile-new ( lexenv ast -- quot )
24 [ receiver>> compile-ast ]
25 [ compile-arguments ] 2bi
28 : compile-ifTrue:ifFalse: ( lexenv ast -- quot )
29 [ receiver>> compile-ast ]
30 [ compile-arguments ] 2bi
33 M: ast-message-send compile-ast
35 { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
36 { "new" [ compile-new ] }
40 [ receiver>> compile-ast ]
41 [ nip selector>> selector>generic ]
42 2tri [ append ] dip suffix
46 M: ast-cascade compile-ast
47 [ receiver>> compile-ast ]
50 [ compile-arguments \ dip ]
51 [ selector>> selector>generic ] bi
54 unclip-last [ [ [ drop ] append ] map ] dip suffix
58 M: ast-return compile-ast
59 [ value>> compile-ast ] [ drop return>> 1quotation ] 2bi
60 [ continue-with ] 3append ;
62 : (compile-sequence) ( lexenv asts -- quot )
64 [ compile-ast ] with map [ drop ] join
67 : block-lexenv ( block -- lexenv )
68 [ [ arguments>> ] [ temporaries>> ] bi append ]
69 [ body>> [ assigned-locals ] map concat fast-set ] bi
71 dup dup _ in? [ <local-reader> ] [ <local> ] if
74 [ local-reader? ] filter-values
75 [ <local-writer> ] assoc-map
76 <lexenv> swap >>local-writers swap >>local-readers ;
78 : lookup-block-vars ( vars lexenv -- seq )
79 local-readers>> '[ _ at ] map ;
81 : make-temporaries ( block lexenv -- quot )
82 [ temporaries>> ] dip lookup-block-vars
83 [ <def> [ f ] swap suffix ] map [ ] join ;
85 :: compile-sequence ( lexenv block -- vars quot )
86 lexenv block block-lexenv lexenv-union :> lexenv
87 block arguments>> lexenv lookup-block-vars
88 lexenv block body>> (compile-sequence) block lexenv make-temporaries prepend ;
90 M: ast-sequence compile-ast
91 compile-sequence nip ;
93 GENERIC: contains-blocks? ( obj -- ? )
95 M: ast-block contains-blocks? drop t ;
97 M: object contains-blocks? drop f ;
99 M: array contains-blocks? [ contains-blocks? ] any? ;
102 dup contains-blocks? [
103 [ [ compile-ast ] with map [ ] join ] [ length ] bi
105 ] [ call-next-method ] if ;
107 GENERIC: compile-assignment ( lexenv name -- quot )
109 M: ast-name compile-assignment name>> swap lookup-writer ;
111 M: ast-assignment compile-ast
112 [ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
114 M: ast-block compile-ast
115 compile-sequence <lambda> '[ _ ] ;
117 :: (compile-method-body) ( lexenv block -- lambda )
118 lexenv block compile-sequence
119 [ lexenv self>> suffix ] dip <lambda> ;
121 : compile-method-body ( lexenv block -- quot )
122 [ [ (compile-method-body) ] [ arguments>> length 1 + ] bi ] 2keep
125 : compile-method ( lexenv ast-method -- )
126 [ [ class>> ] [ name>> selector>generic ] bi* create-method ]
127 [ body>> compile-method-body ]
130 : <class-lexenv> ( class -- lexenv )
131 <lexenv> swap >>class "self" <local> >>self "^" <local> >>return ;
133 M: ast-class compile-ast
136 [ name>> ] [ superclass>> ] [ ivars>> ] tri
137 define-class <class-lexenv>
140 [ compile-method ] with each
143 ERROR: no-word name ;
145 M: ast-foreign compile-ast
147 [ class>> [ ":" split1 lookup-word ] [ no-word ] ?unless ]
148 [ name>> ] bi define-foreign
151 : compile-smalltalk ( statement -- quot )
152 [ empty-lexenv ] dip [ compile-sequence nip 0 ]