! 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 splitting math
-locals.rewrite.closures generic words combinators smalltalk.ast
-smalltalk.compiler.lexenv smalltalk.selectors
-smalltalk.classes ;
+generalizations slots locals.types splitting math
+locals.rewrite.closures generic words combinators locals smalltalk.ast
+smalltalk.compiler.lexenv smalltalk.compiler.assignment
+smalltalk.compiler.return smalltalk.selectors smalltalk.classes ;
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-cascade need-return-continuation?
- {
- [ receiver>> need-return-continuation? ]
- [ messages>> need-return-continuation? ]
- } 1&& ;
-
-M: ast-message need-return-continuation?
- arguments>> need-return-continuation? ;
-
-M: ast-assignment need-return-continuation?
- value>> need-return-continuation? ;
-
-M: ast-sequence need-return-continuation?
- statements>> need-return-continuation? ;
-
-M: array need-return-continuation? [ need-return-continuation? ] any? ;
-
-M: object need-return-continuation? drop f ;
-
-GENERIC: assigned-locals ( ast -- seq )
-
-M: ast-return assigned-locals value>> assigned-locals ;
-
-M: ast-block assigned-locals
- [ body>> assigned-locals ] [ arguments>> ] bi diff ;
-
-M: ast-message-send assigned-locals
- [ receiver>> assigned-locals ]
- [ arguments>> assigned-locals ]
- bi append ;
-
-M: ast-cascade assigned-locals
- [ arguments>> assigned-locals ]
- [ messages>> assigned-locals ]
- bi append ;
-
-M: ast-message assigned-locals
- arguments>> assigned-locals ;
-
-M: ast-assignment assigned-locals
- [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
- [ value>> assigned-locals ] bi append ;
-
-M: ast-sequence assigned-locals
- statements>> assigned-locals ;
-
-M: array assigned-locals
- [ assigned-locals ] map concat ;
-
-M: object assigned-locals drop f ;
-
GENERIC: compile-ast ( lexenv ast -- quot )
M: object compile-ast nip 1quotation ;
: compile-arguments ( lexenv ast -- quot )
arguments>> [ compile-ast ] with map [ ] join ;
-M: ast-message-send compile-ast
- [ compile-arguments ]
+: compile-new ( lexenv ast -- quot )
[ receiver>> compile-ast ]
- [ nip selector>> selector>generic ]
- 2tri [ append ] dip suffix ;
+ [ compile-arguments ] 2bi
+ [ new ] 3append ;
+
+: compile-ifTrue:ifFalse: ( lexenv ast -- quot )
+ [ receiver>> compile-ast ]
+ [ compile-arguments ] 2bi
+ [ if ] 3append ;
+
+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 ]
] 2bi append ;
M: ast-return compile-ast
- value>> compile-ast
- [ return-continuation get continue-with ] append ;
+ [ value>> compile-ast ] [ drop return>> 1quotation ] 2bi
+ [ continue-with ] 3append ;
-: compile-sequence ( lexenv asts -- quot )
- [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
+: (compile-sequence) ( lexenv asts -- quot )
+ [ drop [ nil ] ] [
+ [ compile-ast ] with map [ drop ] join
+ ] if-empty ;
+
+: block-lexenv ( block -- lexenv )
+ [ [ arguments>> ] [ temporaries>> ] bi append ]
+ [ body>> [ assigned-locals ] map concat unique ] bi
+ '[
+ dup dup _ key?
+ [ <local-reader> ]
+ [ <local> ]
+ if
+ ] H{ } map>assoc
+ dup
+ [ nip local-reader? ] assoc-filter
+ [ <local-writer> ] assoc-map
+ <lexenv> swap >>local-writers swap >>local-readers ;
+
+: lookup-block-vars ( vars lexenv -- seq )
+ local-readers>> '[ _ at ] map ;
+
+: make-temporaries ( block lexenv -- quot )
+ [ temporaries>> ] dip lookup-block-vars
+ [ <def> [ f ] swap suffix ] map [ ] join ;
+
+:: 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-sequence compile-ast
- statements>> compile-sequence ;
+ compile-sequence nip ;
GENERIC: contains-blocks? ( obj -- ? )
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> swap >>local-writers swap >>local-readers ;
-
-: compile-block ( lexenv block -- vars body )
- [
- block-lexenv
- [ nip local-readers>> values ]
- [ lexenv-union ] 2bi
- ] [ body>> ] bi
- compile-sequence ;
-
M: ast-block compile-ast
- compile-block <lambda> '[ _ ] ;
-
-: make-return ( quot n block -- quot )
- need-return-continuation? [
- '[
- [
- _ _ ncurry
- [ return-continuation set ] prepose callcc1
- ] with-scope
- ]
- ] [ drop ] if
- rewrite-closures first ;
-
-GENERIC: compile-smalltalk ( ast -- quot )
+ compile-sequence <lambda> '[ _ ] ;
-M: object compile-smalltalk ( statement -- quot )
- [ [ empty-lexenv ] dip compile-ast 0 ] keep make-return ;
-
-: (compile-method-body) ( lexenv block -- lambda )
- [ drop self>> ] [ compile-block ] 2bi [ swap suffix ] dip <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 ] keep
+ [ [ (compile-method-body) ] [ arguments>> length 1 + ] bi ] 2keep
make-return ;
: compile-method ( lexenv ast-method -- )
2bi define ;
: <class-lexenv> ( class -- lexenv )
- <lexenv> swap >>class "self" <local-reader> >>self ;
+ <lexenv> swap >>class "self" <local> >>self "^" <local> >>return ;
-M: ast-class compile-smalltalk ( ast-class -- quot )
+M: ast-class compile-ast
+ nip
[
[ name>> ] [ superclass>> ] [ ivars>> ] tri
define-class <class-lexenv>
ERROR: no-word name ;
-M: ast-foreign compile-smalltalk
+M: ast-foreign compile-ast
+ nip
[ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ]
[ name>> ] bi define-foreign
- [ nil ] ;
\ No newline at end of file
+ [ nil ] ;
+
+: compile-smalltalk ( statement -- quot )
+ [ empty-lexenv ] dip [ compile-sequence nip 0 ]
+ 2keep make-return ;
projects / factor.git / blobdiff