smalltalk: Working on message cascade syntax

extra/smalltalk/ast/ast.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: strings arrays memoize kernel ;
+USING: strings arrays memoize kernel sequences accessors ;
 IN: smalltalk.ast
 
 SINGLETONS: nil self super ;
@@ -8,6 +8,8 @@ SINGLETONS: nil self super ;
 TUPLE: ast-comment { string string } ;
 TUPLE: ast-block { arguments 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 } ;
 TUPLE: ast-name { name string } ;
 TUPLE: ast-return value ;
 TUPLE: ast-assignment { name ast-name } value ;
@@ -15,6 +17,13 @@ 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 } ;
+
+: <ast-cascade> ( receiver messages -- ast )
+    dup length 1 =
+    [ first [ selector>> ] [ arguments>> ] bi ast-message-send boa ]
+    [ ast-cascade boa ]
+    if ;
 
 TUPLE: symbol { name string } ;
 MEMO: intern ( name -- symbol ) symbol boa ;

extra/smalltalk/compiler/compiler.factor

@@ -3,7 +3,7 @@
 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 smalltalk.ast
+locals.rewrite.closures generic words combinators smalltalk.ast
 smalltalk.compiler.lexenv smalltalk.selectors
 smalltalk.classes ;
 IN: smalltalk.compiler
@@ -22,9 +22,21 @@ M: ast-message-send 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 ;
@@ -37,14 +49,25 @@ M: ast-block assigned-locals
     [ body>> assigned-locals ] [ arguments>> ] bi diff ;
 
 M: ast-message-send assigned-locals
-    [ arguments>> 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 ;
 
@@ -60,16 +83,37 @@ ERROR: unbound-local name ;
 
 M: ast-name compile-ast name>> swap lookup-reader ;
 
+: compile-arguments ( lexenv ast -- quot )
+    arguments>> [ compile-ast ] with map [ ] join ;
+
 M: ast-message-send compile-ast
-    [ arguments>> [ compile-ast ] with map [ ] join ]
+    [ compile-arguments ]
     [ receiver>> compile-ast ]
     [ nip selector>> selector>generic ]
     2tri [ append ] dip suffix ;
 
+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: ast-return compile-ast
     value>> compile-ast
     [ return-continuation get continue-with ] append ;
 
+: compile-sequence ( lexenv asts -- quot )
+    [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
+
+M: ast-sequence compile-ast
+    statements>> compile-sequence ;
+
 GENERIC: contains-blocks? ( obj -- ? )
 
 M: ast-block contains-blocks? drop t ;
@@ -110,7 +154,7 @@ M: ast-assignment compile-ast
         [ nip local-readers>> values ]
         [ lexenv-union ] 2bi
     ] [ body>> ] bi
-    [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
+    compile-sequence ;
 
 M: ast-block compile-ast
     compile-block <lambda> '[ _ ] ;

extra/smalltalk/compiler/lexenv/lexenv.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel accessors quotations slots words
 sequences namespaces combinators combinators.short-circuit
-smalltalk.classes ;
+summary smalltalk.classes ;
 IN: smalltalk.compiler.lexenv
 
 ! local-readers: assoc string => word
@@ -39,6 +39,8 @@ CONSTANT: empty-lexenv T{ lexenv }
 
 ERROR: bad-identifier name ;
 
+M: bad-identifier summary drop "Unknown identifier" ;
+
 : lookup-reader ( name lexenv -- reader-quot )
     {
         [ local-reader ]

extra/smalltalk/eval/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/smalltalk/eval/eval-tests.factor

@@ -0,0 +1,5 @@
+IN: smalltalk.eval.tests
+USING: smalltalk.eval tools.test ;
+
+[ 3 ] [ "1+2" eval-smalltalk ] unit-test
+[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test

extra/smalltalk/eval/eval.factor

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

extra/smalltalk/library/library.factor

@@ -1,17 +1,15 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel present io math sequences assocs math.ranges
-locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
+USING: kernel present io math sequences assocs math.ranges fry
+tools.time locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
 IN: smalltalk.library
 
-! Some unary selectors
 SELECTOR: print
 SELECTOR: asString
 
 M: object selector-print dup present print ;
 M: object selector-asString present ;
 
-! Some binary selectors
 SELECTOR: +
 SELECTOR: -
 SELECTOR: *
@@ -32,7 +30,6 @@ M: object selector-<= swap <= ;
 M: object selector->= swap >= ;
 M: object selector-=  swap =  ;
 
-! Some keyword selectors
 SELECTOR: ifTrue:
 SELECTOR: ifFalse:
 SELECTOR: ifTrue:ifFalse:
@@ -76,4 +73,8 @@ M: object selector-value:value:value:value: call( input input input input -- res
 
 SELECTOR: new
 
-M: object selector-new new ;
+M: object selector-new new ;
+
+SELECTOR: time
+
+M: object selector-time '[ _ call( -- result ) ] time ;

extra/smalltalk/listener/listener.factor

@@ -2,17 +2,17 @@
 ! 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.parser smalltalk.compiler smalltalk.printer ;
+smalltalk.eval smalltalk.printer ;
 IN: smalltalk.listener
 
-: eval-smalltalk ( string -- )
-    [
-        parse-smalltalk compile-smalltalk
-    ] with-compilation-unit call( -- result )
-    dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ;
+: eval-interactively ( string -- )
+    '[
+        _ eval-smalltalk
+        dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if
+    ] try ;
 
 : smalltalk-listener ( -- )
     "Smalltalk>" { { background COLOR: light-blue } } format bl flush readln
-    [ '[ _ eval-smalltalk ] try smalltalk-listener ] when* ;
+    [ eval-interactively smalltalk-listener ] when* ;
 
 MAIN: smalltalk-listener

extra/smalltalk/parser/parser-tests.factor

@@ -164,6 +164,41 @@ test         = <foreign parse-smalltalk Expression>
 ]
 [ "((1 < 10) ifTrue: [ 'HI' ] ifFalse: [ 'BYE' ]) print" test-Expression ] unit-test
 
+[
+    T{ ast-cascade
+       { receiver 12 }
+       { messages
+         {
+           T{ ast-message f "sqrt" }
+           T{ ast-message f "+" { 2 } }
+         }
+       }
+    }
+]
+[ "12 sqrt; + 2" test-Expression ] unit-test
+
+[
+    T{ ast-cascade
+       { receiver T{ ast-message-send f 12 "sqrt" } }
+       { messages
+         {
+           T{ ast-message f "+" { 1 } }
+           T{ ast-message f "+" { 2 } }
+         }
+       }
+    }
+]
+[ "12 sqrt + 1; + 2" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 1 "+" { 2 } }
+        "*"
+        { 3 }
+    }
+]
+[ "1+2*3" test-Expression ] unit-test
+
 [
     T{ ast-message-send
        { receiver
@@ -214,15 +249,38 @@ test         = <foreign parse-smalltalk KeywordMessageSend>
 ]
 [ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
 
-[ { 1 2 } ] [ "1. 2" parse-smalltalk ] unit-test
+[ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
 
 [
-    T{ ast-class
-       { name "Test" }
-       { superclass "Object" }
-       { ivars { "a" } }
+    T{ ast-sequence f
+        {
+            T{ ast-class
+               { name "Test" }
+               { superclass "Object" }
+               { ivars { "a" } }
+            }
+        }
     }
 ]
 [ "class Test [|a|]" parse-smalltalk ] unit-test
 
+[
+    T{ ast-sequence f
+        {
+            T{ ast-class
+               { name "Test1" }
+               { superclass "Object" }
+               { ivars { "a" } }
+            }
+
+            T{ ast-class
+               { name "Test2" }
+               { superclass "Test1" }
+               { ivars { "b" } }
+            }
+        }
+    }
+]
+[ "class Test1 [|a|]. class Test2 extends Test1 [|b|]" parse-smalltalk ] unit-test
+
 [ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test

extra/smalltalk/parser/parser.factor

@@ -4,6 +4,8 @@ USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings
 math.parser kernel arrays byte-arrays math assocs accessors ;
 IN: smalltalk.parser
 
+! :mode=text:noTabs=true:
+
 ! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html
 
 ERROR: bad-number str ;
@@ -120,43 +122,52 @@ Operand =       Literal
                 | Reference
                 | NestedExpression
 
-UnaryMessage = UnaryMessageSelector
+UnaryMessage = OptionalWhiteSpace
+               UnaryMessageSelector:s !(":")
+               => [[ s { } ast-message boa ]]
 UnaryMessageOperand = UnaryMessageSend | Operand
 UnaryMessageSend = UnaryMessageOperand:receiver
-                   OptionalWhiteSpace UnaryMessageSelector:selector !(":")
-                   => [[ receiver selector { } ast-message-send boa ]]
+                   UnaryMessage:h
+                   (OptionalWhiteSpace ";" UnaryMessage:m => [[ m ]])*:t
+                   => [[ receiver t h prefix >array <ast-cascade> ]]
 
-BinaryMessage = BinaryMessageSelector OptionalWhiteSpace BinaryMessageOperand
+BinaryMessage = OptionalWhiteSpace
+                BinaryMessageSelector:selector
+                OptionalWhiteSpace
+                BinaryMessageOperand:rhs
+                => [[ selector { rhs } ast-message boa ]]
+                                   
 BinaryMessageOperand = BinaryMessageSend | UnaryMessageSend | Operand
-BinaryMessageSend-1 = BinaryMessageOperand:lhs
-                    OptionalWhiteSpace
-                    BinaryMessageSelector:selector
-                    OptionalWhiteSpace
-                    UnaryMessageOperand:rhs
-                    => [[ lhs selector { rhs } ast-message-send boa ]]
-BinaryMessageSend = (BinaryMessageSend:lhs
-                    OptionalWhiteSpace
-                    BinaryMessageSelector:selector
-                    OptionalWhiteSpace
-                    UnaryMessageOperand:rhs
-                    => [[ lhs selector { rhs } ast-message-send boa ]])
-                    | BinaryMessageSend-1
+BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+                    BinaryMessage:h
+                   (OptionalWhiteSpace ";" BinaryMessage:m => [[ m ]])*:t
+                   => [[ lhs t h prefix >array <ast-cascade> ]]
 
 KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
+KeywordMessage = OptionalWhiteSpace
+                 KeywordMessageSegment:h
+                 (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
+                 => [[ t h prefix unzip [ concat ] dip ast-message boa ]]
 KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):receiver
                      OptionalWhiteSpace
-                     KeywordMessageSegment:h
-                     (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
-                     => [[ receiver t h prefix unzip [ concat ] dip ast-message-send boa ]]
+                     KeywordMessage:m
+                     => [[ receiver m 1array <ast-cascade> ]]
+
+Message = BinaryMessage | UnaryMessage | KeywordMessage
+
+MessageSend = (MessageSend | Operand):lhs
+              Message:h
+              (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+              => [[ lhs t h prefix >array <ast-cascade> ]]
 
 Expression = OptionalWhiteSpace
-             (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
+             (MessageSend | Operand):e
              => [[ e ]]
 
 AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
                       OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
 AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment boa ]]
-Statement = AssignmentStatement | Expression
+Statement = ClassDeclaration | ForeignClassDeclaration | AssignmentStatement | Expression
 
 MethodReturnOperator = OptionalWhiteSpace "^"
 FinalStatement = (MethodReturnOperator Statement:s => [[ s ast-return boa ]])
@@ -168,10 +179,12 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
                  => [[ t h prefix ]]
                 )?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
 
-ExecutableCode = (LocalVariableDeclarationList)?
-                 ((Statement:s OptionalWhiteSpace "." => [[ s ]])*
-                 FinalStatement:f (".")? => [[ f ]])?
-                 => [[ sift >array ]]
+ExecutableCode = (LocalVariableDeclarationList)?:locals
+                 ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h
+                 FinalStatement:t (".")? => [[ h t suffix ]])?:body
+                 => [[ body locals [ suffix ] when* >array ]]
+
+TopLevelForm = ExecutableCode => [[ ast-sequence boa ]]
 
 UnaryMethodHeader = UnaryMessageSelector:selector
                   => [[ { selector { } } ]]
@@ -206,6 +219,6 @@ ForeignClassDeclaration = OptionalWhiteSpace "foreign"
                           => [[ class name ast-foreign boa ]]
 End = !(.)
 
-Program = (ClassDeclaration|ForeignClassDeclaration|ExecutableCode) => [[ nil or ]] End
+Program = TopLevelForm End
 
 ;EBNF

extra/smalltalk/parser/test.st

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