! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators.short-circuit
-continuations fry kernel namespaces quotations sequences sets
-generalizations slots locals.types generalizations smalltalk.ast
-smalltalk.compiler.lexenv smalltalk.selectors ;
+USING: accessors arrays assocs combinators continuations
+generic kernel locals.types math quotations sequences
+sequences.generalizations sets smalltalk.ast smalltalk.classes
+smalltalk.compiler.assignment smalltalk.compiler.lexenv
+smalltalk.compiler.return smalltalk.selectors splitting words ;
IN: smalltalk.compiler
-SYMBOL: return-continuation
-
-GENERIC: need-return-continuation? ( ast -- ? )
-
-M: ast-return need-return-continuation? drop t ;
-
-M: ast-block need-return-continuation? body>> need-return-continuation? ;
-
-M: ast-message-send need-return-continuation?
- {
- [ receiver>> need-return-continuation? ]
- [ arguments>> need-return-continuation? ]
- } 1&& ;
-
-M: ast-assignment need-return-continuation?
- value>> need-return-continuation? ;
+GENERIC: compile-ast ( lexenv ast -- quot )
-M: array need-return-continuation? [ need-return-continuation? ] any? ;
+M: object compile-ast nip 1quotation ;
-M: object need-return-continuation? drop f ;
+M: self compile-ast drop self>> 1quotation ;
-GENERIC: assigned-locals ( ast -- seq )
+ERROR: unbound-local name ;
-M: ast-return assigned-locals value>> assigned-locals ;
+M: ast-name compile-ast name>> swap lookup-reader ;
-M: ast-block assigned-locals
- [ body>> assigned-locals ] [ arguments>> ] bi diff ;
+: compile-arguments ( lexenv ast -- quot )
+ arguments>> [ compile-ast ] with map [ ] join ;
-M: ast-message-send assigned-locals
- [ arguments>> assigned-locals ]
- [ receiver>> assigned-locals ]
- bi append ;
+: compile-new ( lexenv ast -- quot )
+ [ receiver>> compile-ast ]
+ [ compile-arguments ] 2bi
+ [ new ] 3append ;
-M: ast-assignment assigned-locals
- [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
- [ value>> assigned-locals ] bi append ;
+: compile-ifTrue:ifFalse: ( lexenv ast -- quot )
+ [ receiver>> compile-ast ]
+ [ compile-arguments ] 2bi
+ [ if ] 3append ;
-M: array assigned-locals
- [ assigned-locals ] map concat ;
+M: ast-message-send compile-ast
+ dup selector>> {
+ { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
+ { "new" [ compile-new ] }
+ [
+ drop
+ [ compile-arguments ]
+ [ receiver>> compile-ast ]
+ [ nip selector>> selector>generic ]
+ 2tri [ append ] dip suffix
+ ]
+ } case ;
+
+M: ast-cascade compile-ast
+ [ receiver>> compile-ast ]
+ [
+ messages>> [
+ [ compile-arguments \ dip ]
+ [ selector>> selector>generic ] bi
+ [ ] 3sequence
+ ] with map
+ unclip-last [ [ [ drop ] append ] map ] dip suffix
+ cleave>quot
+ ] 2bi append ;
-M: object assigned-locals drop f ;
+M: ast-return compile-ast
+ [ value>> compile-ast ] [ drop return>> 1quotation ] 2bi
+ [ continue-with ] 3append ;
-GENERIC: compile-ast ( lexenv ast -- quot )
+: (compile-sequence) ( lexenv asts -- quot )
+ [ drop [ nil ] ] [
+ [ compile-ast ] with map [ drop ] join
+ ] if-empty ;
-M: object compile-ast nip 1quotation ;
+: block-lexenv ( block -- lexenv )
+ [ [ arguments>> ] [ temporaries>> ] bi append ]
+ [ body>> [ assigned-locals ] map concat fast-set ] bi
+ '[
+ dup dup _ in? [ <local-reader> ] [ <local> ] if
+ ] H{ } map>assoc
+ dup
+ [ nip local-reader? ] assoc-filter
+ [ <local-writer> ] assoc-map
+ <lexenv> swap >>local-writers swap >>local-readers ;
-ERROR: unbound-local name ;
+: lookup-block-vars ( vars lexenv -- seq )
+ local-readers>> '[ _ at ] map ;
-M: ast-name compile-ast
- name>> swap local-readers>> at 1quotation ;
+: make-temporaries ( block lexenv -- quot )
+ [ temporaries>> ] dip lookup-block-vars
+ [ <def> [ f ] swap suffix ] map [ ] join ;
-M: ast-message-send compile-ast
- [ arguments>> [ compile-ast ] with map [ ] join ]
- [ receiver>> compile-ast ]
- [ nip selector>> selector>generic ]
- 2tri [ append ] dip suffix ;
+:: compile-sequence ( lexenv block -- vars quot )
+ lexenv block block-lexenv lexenv-union :> lexenv
+ block arguments>> lexenv lookup-block-vars
+ lexenv block body>> (compile-sequence) block lexenv make-temporaries prepend ;
-M: ast-return compile-ast
- value>> compile-ast
- [ return-continuation get continue-with ] append ;
+M: ast-sequence compile-ast
+ compile-sequence nip ;
GENERIC: contains-blocks? ( obj -- ? )
dup contains-blocks? [
[ [ compile-ast ] with map [ ] join ] [ length ] bi
'[ @ _ narray ]
- ] [
- call-next-method
- ] if ;
+ ] [ call-next-method ] if ;
GENERIC: compile-assignment ( lexenv name -- quot )
-M: ast-name compile-assignment
- name>> swap local-writers>> at 1quotation ;
+M: ast-name compile-assignment name>> swap lookup-writer ;
M: ast-assignment compile-ast
[ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
-: block-lexenv ( block -- lexenv )
- [ arguments>> ] [ body>> [ assigned-locals ] map concat unique ] bi
- '[
- dup dup _ key?
- [ <local-reader> ]
- [ <local> ]
- if
- ] { } map>assoc
- dup
- [ nip local-reader? ] assoc-filter
- [ <local-writer> ] assoc-map
- <lexenv> ;
-
M: ast-block compile-ast
+ compile-sequence <lambda> '[ _ ] ;
+
+:: (compile-method-body) ( lexenv block -- lambda )
+ lexenv block compile-sequence
+ [ lexenv self>> suffix ] dip <lambda> ;
+
+: compile-method-body ( lexenv block -- quot )
+ [ [ (compile-method-body) ] [ arguments>> length 1 + ] bi ] 2keep
+ make-return ;
+
+: compile-method ( lexenv ast-method -- )
+ [ [ class>> ] [ name>> selector>generic ] bi* create-method ]
+ [ body>> compile-method-body ]
+ 2bi define ;
+
+: <class-lexenv> ( class -- lexenv )
+ <lexenv> swap >>class "self" <local> >>self "^" <local> >>return ;
+
+M: ast-class compile-ast
+ nip
[
- block-lexenv
- [ nip local-readers>> values ]
- [ lexenv-union ] 2bi
- ] [ body>> ] bi
- [ drop [ nil ] ] [
- unclip-last
- [ [ compile-ast [ drop ] append ] with map [ ] join ]
- [ compile-ast ]
- bi-curry* bi
- append
- ] if-empty
- <lambda> '[ _ ] ;
-
-: compile-method ( block -- quot )
- [ [ empty-lexenv ] dip compile-ast [ call ] compose ]
- [ arguments>> length ]
- [ need-return-continuation? ]
- tri
- [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
-
-: compile-statement ( statement -- quot )
- [ [ empty-lexenv ] dip compile-ast ] [ need-return-continuation? ] bi
- [ '[ [ [ return-continuation set @ ] callcc1 ] with-scope ] ] when ;
+ [ name>> ] [ superclass>> ] [ ivars>> ] tri
+ define-class <class-lexenv>
+ ]
+ [ methods>> ] bi
+ [ compile-method ] with each
+ [ nil ] ;
+
+ERROR: no-word name ;
+
+M: ast-foreign compile-ast
+ nip
+ [ class>> dup ":" split1 lookup-word [ ] [ no-word ] ?if ]
+ [ name>> ] bi define-foreign
+ [ nil ] ;
+
+: compile-smalltalk ( statement -- quot )
+ [ empty-lexenv ] dip [ compile-sequence nip 0 ]
+ 2keep make-return ;
projects / factor.git / blobdiff