smalltalk: fix various things in the parser, add temporary variable support, clean up compiler

extra/smalltalk/ast/ast.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: strings arrays memoize kernel sequences accessors ;
+USING: strings arrays memoize kernel sequences accessors combinators ;
 IN: smalltalk.ast
 
 SINGLETONS: nil self super ;
 
 TUPLE: ast-comment { string string } ;
-TUPLE: ast-block { arguments array } { body array } ;
+TUPLE: ast-block { arguments array } { temporaries array } { body array } ;
 TUPLE: ast-message-send receiver { selector string } { arguments array } ;
 TUPLE: ast-message { selector string } { arguments array } ;
 TUPLE: ast-cascade receiver { messages array } ;
@@ -17,8 +17,28 @@ TUPLE: ast-local-variables { names array } ;
 TUPLE: ast-method { name string } { body ast-block } ;
 TUPLE: ast-class { name string } { superclass string } { ivars array } { methods array } ;
 TUPLE: ast-foreign { class string } { name string } ;
-TUPLE: ast-sequence { statements array } ;
+TUPLE: ast-sequence { temporaries array } { body array } ;
 
+! We treat a sequence of statements like a block in a few places to
+! simplify handling of top-level forms
+M: ast-sequence arguments>> drop { } ;
+
+: unclip-temporaries ( statements -- temporaries statements' )
+    {
+        { [ dup empty? ] [ { } ] }
+        { [ dup first ast-local-variables? not ] [ { } ] }
+        [ unclip names>> ]
+    } cond swap ;
+
+: <ast-block> ( arguments body -- block )
+    unclip-temporaries ast-block boa ;
+
+: <ast-sequence> ( body -- block )
+    unclip-temporaries ast-sequence boa ;
+
+! The parser parses normal message sends as cascades with one message, but
+! we represent them differently in the AST to simplify generated code in
+! the common case
 : <ast-cascade> ( receiver messages -- ast )
     dup length 1 =
     [ first [ selector>> ] [ arguments>> ] bi ast-message-send boa ]

extra/smalltalk/compiler/compiler-tests.factor

@@ -1,10 +1,13 @@
 USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
 smalltalk.compiler.lexenv stack-checker locals.rewrite.closures
-kernel accessors compiler.units sequences ;
+kernel accessors compiler.units sequences arrays ;
 IN: smalltalk.compiler.tests
 
 : test-compilation ( ast -- quot )
-    [ compile-smalltalk [ call ] append ] with-compilation-unit ;
+    [
+        1array ast-sequence new swap >>body
+        compile-smalltalk [ call ] append
+    ] with-compilation-unit ;
 
 : test-inference ( ast -- in# out# )
     test-compilation infer [ in>> ] [ out>> ] bi ;
@@ -46,6 +49,7 @@ IN: smalltalk.compiler.tests
 
 [ 0 1 ] [
     T{ ast-block f
+       { }
        { }
        {
            T{ ast-message-send
@@ -76,6 +80,7 @@ IN: smalltalk.compiler.tests
 
 [ "a" ] [
     T{ ast-block f
+       { }
        { }
        { { T{ ast-block { body { "a" } } } } }
     } test-compilation call first call

extra/smalltalk/compiler/compiler.factor

@@ -2,77 +2,12 @@
 ! 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
+generalizations slots locals.types splitting math
-locals.rewrite.closures generic words combinators smalltalk.ast
+locals.rewrite.closures generic words combinators locals smalltalk.ast
-smalltalk.compiler.lexenv smalltalk.selectors
+smalltalk.compiler.lexenv smalltalk.compiler.assignment
-smalltalk.classes ;
+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 ;
@@ -108,11 +43,39 @@ M: ast-return compile-ast
     value>> compile-ast
     [ return-continuation get continue-with ] append ;
 
-: compile-sequence ( lexenv asts -- quot )
+: (compile-sequence) ( lexenv asts -- quot )
-    [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
+    [ 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 -- ? )
 
@@ -135,48 +98,12 @@ 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> 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> '[ _ ] ;
+    compile-sequence <lambda> '[ _ ] ;
 
-: make-return ( quot n block -- quot )
+:: (compile-method-body) ( lexenv block -- lambda )
-    need-return-continuation? [
+    lexenv block compile-sequence
-        '[
+    [ lexenv self>> suffix ] dip <lambda> ;
-            [
-                _ _ ncurry
-                [ return-continuation set ] prepose callcc1
-            ] with-scope
-        ]
-    ] [ drop ] if
-    rewrite-closures first ;
-
-GENERIC: compile-smalltalk ( ast -- quot )
-
-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 -- quot )
     [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep
@@ -190,7 +117,8 @@ M: object compile-smalltalk ( statement -- quot )
 : <class-lexenv> ( class -- lexenv )
     <lexenv> swap >>class "self" <local-reader> >>self ;
 
-M: ast-class compile-smalltalk ( ast-class -- quot )
+M: ast-class compile-ast
+    nip
     [
         [ name>> ] [ superclass>> ] [ ivars>> ] tri
         define-class <class-lexenv> 
@@ -201,7 +129,12 @@ M: ast-class compile-smalltalk ( ast-class -- quot )
 
 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 ] ;
+
+: compile-smalltalk ( statement -- quot )
+    [ [ empty-lexenv ] dip compile-sequence nip 0 ]
+    keep make-return ;

extra/smalltalk/eval/eval-tests.factor

@@ -5,3 +5,5 @@ USING: smalltalk.eval tools.test io.streams.string ;
 [ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
 [ 7 ] [ "1+2+3;+4" eval-smalltalk ] unit-test
 [ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test
+[ 5 ] [ "|x| x:=5. x" eval-smalltalk ] unit-test
+[ 11 ] [ "[:i| |x| x:=5. i+x] value: 6" eval-smalltalk ] unit-test

extra/smalltalk/eval/eval.factor

@@ -1,8 +1,12 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.units smalltalk.parser smalltalk.compiler ;
+USING: io.files io.encodings.utf8
+compiler.units smalltalk.parser smalltalk.compiler ;
 IN: smalltalk.eval
 
 : eval-smalltalk ( string -- result )
     [ parse-smalltalk compile-smalltalk ] with-compilation-unit
     call( -- result ) ;
+
+: eval-smalltalk-file ( path -- result )
+    utf8 file-contents eval-smalltalk ;

extra/smalltalk/library/library.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel present io math sequences assocs math.ranges fry
+USING: kernel present io math sequences assocs math.ranges
-tools.time locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
+math.order fry tools.time locals smalltalk.selectors
+smalltalk.ast smalltalk.classes ;
 IN: smalltalk.library
 
 SELECTOR: print
@@ -10,6 +11,16 @@ SELECTOR: asString
 M: object selector-print dup present print ;
 M: object selector-asString present ;
 
+SELECTOR: print:
+SELECTOR: nextPutAll:
+SELECTOR: tab
+SELECTOR: nl
+
+M: object selector-print: [ present ] dip stream-print nil ;
+M: object selector-nextPutAll: selector-print: ;
+M: object selector-tab "    " swap selector-print: ;
+M: object selector-nl stream-nl nil ;
+
 SELECTOR: +
 SELECTOR: -
 SELECTOR: *
@@ -30,6 +41,12 @@ M: object selector-<= swap <= ;
 M: object selector->= swap >= ;
 M: object selector-=  swap =  ;
 
+SELECTOR: min:
+SELECTOR: max:
+
+M: object selector-min: min ;
+M: object selector-max: max ;
+
 SELECTOR: ifTrue:
 SELECTOR: ifFalse:
 SELECTOR: ifTrue:ifFalse:
@@ -38,6 +55,10 @@ M: object selector-ifTrue: [ call( -- result ) ] [ drop nil ] if ;
 M: object selector-ifFalse: [ drop nil ] [ call( -- result ) ] if ;
 M: object selector-ifTrue:ifFalse: [ drop call( -- result ) ] [ nip call( -- result ) ] if ;
 
+SELECTOR: isNil
+
+M: object selector-isNil nil eq? ;
+
 SELECTOR: at:
 SELECTOR: at:put:
 

extra/smalltalk/listener/listener.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel prettyprint io io.styles colors.constants compiler.units
 fry debugger sequences locals.rewrite.closures smalltalk.ast
-smalltalk.eval smalltalk.printer ;
+smalltalk.eval smalltalk.printer smalltalk.listener ;
 IN: smalltalk.listener
 
 : eval-interactively ( string -- )

extra/smalltalk/parser/parser-tests.factor

@@ -49,9 +49,9 @@ test         = <foreign parse-smalltalk Literal>
 [ B{ 1 2 3 4 } ] [ "#[1 2 3 4]" test-Literal ] unit-test
 [ { nil t f } ] [ "#(nil true false)" test-Literal ] unit-test
 [ { nil { t f } } ] [ "#(nil (true false))" test-Literal ] unit-test
-[ T{ ast-block f { } { } } ] [ "[]" test-Literal ] unit-test
+[ T{ ast-block f { } { } { } } ] [ "[]" test-Literal ] unit-test
-[ T{ ast-block f { "x" } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
+[ T{ ast-block f { "x" } { } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
-[ T{ ast-block f { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
+[ T{ ast-block f { } { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
 
 [
     T{ ast-block
@@ -190,6 +190,19 @@ test         = <foreign parse-smalltalk Expression>
 ]
 [ "12 sqrt + 1; + 2" test-Expression ] unit-test
 
+[
+    T{ ast-cascade
+       { receiver T{ ast-message-send f 12 "squared" } }
+       { messages
+         {
+           T{ ast-message f "to:" { 100 } }
+           T{ ast-message f "sqrt" }
+         }
+       }
+    }
+]
+[ "12 squared to: 100; sqrt" test-Expression ] unit-test
+
 [
     T{ ast-message-send f
         T{ ast-message-send f 1 "+" { 2 } }
@@ -228,12 +241,8 @@ test         = <foreign parse-smalltalk LocalVariableDeclarationList>
 [ T{ ast-local-variables f { "i" "j" } } ] [ " |  i j   |" test-LocalVariableDeclarationList ] unit-test
 
 
-EBNF: test-MessageSend
-test         = <foreign parse-smalltalk MessageSend>
-;EBNF
-
 [ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ]
-[ "x foo:1 bar:2" test-MessageSend ] unit-test
+[ "x foo:1 bar:2" test-Expression ] unit-test
 
 [
     T{ ast-message-send
@@ -247,12 +256,14 @@ test         = <foreign parse-smalltalk MessageSend>
         { 10 100 }
     }
 ]
-[ "3 factorial + 4 factorial between: 10 and: 100" test-MessageSend ] unit-test
+[ "3 factorial + 4 factorial between: 10 and: 100" test-Expression ] unit-test
 
-[ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
+[ T{ ast-sequence f { } { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
+
+[ T{ ast-sequence f { } { 1 2 } } ] [ "1. 2." parse-smalltalk ] unit-test
 
 [
-    T{ ast-sequence f
+    T{ ast-sequence f { }
         {
             T{ ast-class
                { name "Test" }
@@ -265,7 +276,7 @@ test         = <foreign parse-smalltalk MessageSend>
 [ "class Test [|a|]" parse-smalltalk ] unit-test
 
 [
-    T{ ast-sequence f
+    T{ ast-sequence f { }
         {
             T{ ast-class
                { name "Test1" }

extra/smalltalk/parser/parser.factor

@@ -105,7 +105,7 @@ BlockLiteral = "["
                  => [[ args ]]
                 )?:args
                 ExecutableCode:body
-                "]" => [[ args >array body ast-block boa ]]
+                "]" => [[ args >array body <ast-block> ]]
 
 Literal = (ConstantReference
                 | FloatingPointLiteral
@@ -129,7 +129,7 @@ UnaryMessage = OptionalWhiteSpace
 BinaryMessage = OptionalWhiteSpace
                 BinaryMessageSelector:selector
                 OptionalWhiteSpace
-                (MessageSend | Operand):rhs
+                (UnaryMessageSend | Operand):rhs
                 => [[ selector { rhs } ast-message boa ]]
                                    
 KeywordMessageSegment = Keyword:k OptionalWhiteSpace (BinaryMessageSend | UnaryMessageSend | Operand):arg => [[ { k arg } ]]
@@ -140,13 +140,13 @@ KeywordMessage = OptionalWhiteSpace
 
 Message = BinaryMessage | UnaryMessage | KeywordMessage
 
-UnaryMessageSend = (MessageSend | Operand):lhs
+UnaryMessageSend = (UnaryMessageSend | Operand):lhs
-              Message:h
+              UnaryMessage:h
               (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
               => [[ lhs t h prefix >array <ast-cascade> ]]
 
-BinaryMessageSend = (MessageSend | Operand):lhs
+BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
-              Message:h
+              BinaryMessage:h
               (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
               => [[ lhs t h prefix >array <ast-cascade> ]]
 
@@ -155,10 +155,8 @@ KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
               (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
               => [[ lhs t h prefix >array <ast-cascade> ]]
 
-MessageSend = BinaryMessageSend | UnaryMessageSend | KeywordMessageSend
-
 Expression = OptionalWhiteSpace
-             (MessageSend | Operand):e
+             (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
              => [[ e ]]
 
 AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
@@ -176,13 +174,15 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
                  => [[ t h prefix ]]
                 )?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
 
-ExecutableCode = (LocalVariableDeclarationList)?:locals
+EndStatement = "."
-                 ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h
-                 FinalStatement:t (".")? => [[ h t suffix ]])?:body
-                 OptionalWhiteSpace
-                 => [[ body locals [ suffix ] when* >array ]]
 
-TopLevelForm = ExecutableCode => [[ ast-sequence boa ]]
+ExecutableCode = (LocalVariableDeclarationList)?:locals
+                 (Statement:s OptionalWhiteSpace EndStatement => [[ s ]])*:h
+                 (FinalStatement:t (EndStatement)? => [[ t ]])?:t
+                 OptionalWhiteSpace
+                 => [[ h t [ suffix ] when* locals [ prefix ] when* >array ]]
+
+TopLevelForm = ExecutableCode => [[ <ast-sequence> ]]
 
 UnaryMethodHeader = UnaryMessageSelector:selector
                   => [[ { selector { } } ]]
@@ -200,7 +200,7 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:
         OptionalWhiteSpace "["
         ExecutableCode:code
         "]"
-        => [[ header first2 code ast-block boa ast-method boa ]]
+        => [[ header first2 code <ast-block> ast-method boa ]]
 
 ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
         OptionalWhiteSpace
@@ -209,9 +209,9 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
         (OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars
         (MethodDeclaration:h
          (OptionalWhiteSpace
-          "."
+          EndStatement
           OptionalWhiteSpace
-          MethodDeclaration:m => [[ m ]])*:t (".")?
+          MethodDeclaration:m => [[ m ]])*:t (EndStatement)?
           => [[ t h prefix ]]
          )?:methods
         OptionalWhiteSpace "]"

extra/smalltalk/parser/test.st

@@ -32,8 +32,8 @@ class TreeNode extends Object [
             nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
     ].
     
-    method binarytrees [
+    method binarytrees: arg [
-        self binarytrees: self arg to: self stdout.
+        self binarytrees: arg to: self stdout.
         ^''
     ].
 
@@ -63,4 +63,3 @@ class TreeNode extends Object [
     ]
 ].
 
-Tests binarytrees