From 00c9cde8e2edaf806d31b7ef676e16219f53b06a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 30 Mar 2009 05:31:50 -0500
Subject: [PATCH 01/12] First checkin of extra/smalltalk

---
 extra/smalltalk/ast/ast.factor                |  18 ++
 extra/smalltalk/ast/authors.txt               |   1 +
 extra/smalltalk/authors.txt                   |   1 +
 extra/smalltalk/compiler/authors.txt          |   1 +
 .../smalltalk/compiler/compiler-tests.factor  |  45 ++++
 extra/smalltalk/compiler/compiler.factor      | 102 +++++++++
 extra/smalltalk/compiler/lexenv/authors.txt   |   1 +
 extra/smalltalk/compiler/lexenv/lexenv.factor |  14 ++
 extra/smalltalk/parser/authors.txt            |   1 +
 extra/smalltalk/parser/parser-tests.factor    | 137 ++++++++++++
 extra/smalltalk/parser/parser.factor          | 203 ++++++++++++++++++
 extra/smalltalk/parser/test.st                |  66 ++++++
 extra/smalltalk/selectors/authors.txt         |   1 +
 extra/smalltalk/selectors/selectors.factor    |  26 +++
 extra/smalltalk/smalltalk.factor              |   4 +
 15 files changed, 621 insertions(+)
 create mode 100644 extra/smalltalk/ast/ast.factor
 create mode 100644 extra/smalltalk/ast/authors.txt
 create mode 100644 extra/smalltalk/authors.txt
 create mode 100644 extra/smalltalk/compiler/authors.txt
 create mode 100644 extra/smalltalk/compiler/compiler-tests.factor
 create mode 100644 extra/smalltalk/compiler/compiler.factor
 create mode 100644 extra/smalltalk/compiler/lexenv/authors.txt
 create mode 100644 extra/smalltalk/compiler/lexenv/lexenv.factor
 create mode 100644 extra/smalltalk/parser/authors.txt
 create mode 100644 extra/smalltalk/parser/parser-tests.factor
 create mode 100644 extra/smalltalk/parser/parser.factor
 create mode 100644 extra/smalltalk/parser/test.st
 create mode 100644 extra/smalltalk/selectors/authors.txt
 create mode 100644 extra/smalltalk/selectors/selectors.factor
 create mode 100644 extra/smalltalk/smalltalk.factor

diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
new file mode 100644
index 0000000000..83e6d0ae84
--- /dev/null
+++ b/extra/smalltalk/ast/ast.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: strings arrays memoize kernel ;
+IN: smalltalk.ast
+
+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-name { name string } ;
+TUPLE: ast-return value ;
+TUPLE: ast-assignment { name ast-name } value ;
+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: symbol { name string } ;
+MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
diff --git a/extra/smalltalk/ast/authors.txt b/extra/smalltalk/ast/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/ast/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/authors.txt b/extra/smalltalk/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/authors.txt b/extra/smalltalk/compiler/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
new file mode 100644
index 0000000000..ee944baf02
--- /dev/null
+++ b/extra/smalltalk/compiler/compiler-tests.factor
@@ -0,0 +1,45 @@
+USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
+stack-checker locals.rewrite.closures kernel accessors
+compiler.units sequences ;
+IN: smalltalk.compiler.tests
+
+[ 2 1 ] [
+    [
+        T{ ast-block f
+           { "a" "b" }
+           {
+               T{ ast-message-send f
+                  T{ ast-name f "a" }
+                  "+"
+                  { T{ ast-name f "b" } }
+               }
+           }
+        } compile-method
+        [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
+    ] with-compilation-unit
+] unit-test
+
+[ 3 1 ] [
+    [
+        T{ ast-block f
+           { "a" "b" "c" }
+           {
+               T{ ast-assignment f
+                  T{ ast-name f "a" }
+                  T{ ast-message-send f
+                     T{ ast-name f "a" }
+                     "+"
+                     { T{ ast-name f "b" } }
+                  }
+               }
+               T{ ast-message-send f
+                  T{ ast-name f "b" }
+                  "blah:"
+                  { 123.456 }
+               }
+               T{ ast-return f T{ ast-name f "c" } }
+           }
+        } compile-method
+        [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
+    ] with-compilation-unit
+] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
new file mode 100644
index 0000000000..1f3b0f94e5
--- /dev/null
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -0,0 +1,102 @@
+! 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
+slots locals.types generalizations smalltalk.ast
+smalltalk.compiler.lexenv smalltalk.selectors ;
+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? ] any? ;
+
+M: ast-message-send need-return-continuation?
+    {
+        [ receiver>> need-return-continuation? ]
+        [ arguments>> [ need-return-continuation? ] any? ]
+    } 1&& ;
+
+M: ast-assignment need-return-continuation?
+    value>> need-return-continuation? ;
+
+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 ] map concat ] [ arguments>> ] bi diff ;
+
+M: ast-message-send assigned-locals
+    [ receiver>> assigned-locals ]
+    [ arguments>> [ assigned-locals ] map ] bi append ;
+
+M: ast-assignment assigned-locals
+    [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
+    [ value>> assigned-locals ] bi append ;
+
+M: object assigned-locals drop f ;
+
+GENERIC: compile-ast ( lexenv ast -- quot )
+
+M: object compile-ast nip 1quotation ;
+
+ERROR: unbound-local name ;
+
+M: ast-name compile-ast
+    name>> swap local-readers>> at 1quotation ;
+
+M: ast-message-send compile-ast
+    [ receiver>> compile-ast ]
+    [ arguments>> [ compile-ast ] with map concat ]
+    [ nip selector>> selector>generic ]
+    2tri [ append ] dip suffix ;
+
+M: ast-return compile-ast
+    value>> compile-ast
+    [ return-continuation get continue-with ] append ;
+
+GENERIC: compile-assignment ( lexenv name -- quot )
+
+M: ast-name compile-assignment
+    name>> swap local-writers>> at 1quotation ;
+
+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
+    [
+        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 ] [ arguments>> length ] [ need-return-continuation? ] tri
+    [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/authors.txt b/extra/smalltalk/compiler/lexenv/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/lexenv/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
new file mode 100644
index 0000000000..2488a54c5f
--- /dev/null
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel accessors ;
+IN: smalltalk.compiler.lexenv
+
+TUPLE: lexenv local-readers local-writers ;
+
+C: <lexenv> lexenv
+
+CONSTANT: empty-lexenv T{ lexenv }
+
+: lexenv-union ( lexenv1 lexenv2 -- lexenv )
+    [ [ local-readers>> ] bi@ assoc-union ]
+    [ [ local-writers>> ] bi@ assoc-union ] 2bi <lexenv> ;
diff --git a/extra/smalltalk/parser/authors.txt b/extra/smalltalk/parser/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/parser/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
new file mode 100644
index 0000000000..9a6614aa07
--- /dev/null
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -0,0 +1,137 @@
+IN: smalltalk.parser.tests
+USING: smalltalk.parser smalltalk.ast peg.ebnf tools.test accessors
+io.files io.encodings.ascii kernel ;
+
+EBNF: test-Character
+test         = <foreign parse-smalltalk Character>
+;EBNF
+
+[ CHAR: a ] [ "a" test-Character ] unit-test
+
+EBNF: test-Comment
+test         = <foreign parse-smalltalk Comment>
+;EBNF
+
+[ T{ ast-comment f "Hello, this is a comment." } ]
+[ "\"Hello, this is a comment.\"" test-Comment ]
+unit-test
+
+[ T{ ast-comment f "Hello, \"this\" is a comment." } ]
+[ "\"Hello, \"\"this\"\" is a comment.\"" test-Comment ]
+unit-test
+
+EBNF: test-Identifier
+test         = <foreign parse-smalltalk Identifier>
+;EBNF
+
+[ "OrderedCollection" ] [ "OrderedCollection" test-Identifier ] unit-test
+
+EBNF: test-Literal
+test         = <foreign parse-smalltalk Literal>
+;EBNF
+
+[ nil ] [ "nil" test-Literal ] unit-test
+[ 123 ] [ "123" test-Literal ] unit-test
+[ HEX: deadbeef ] [ "16rdeadbeef" test-Literal ] unit-test
+[ -123 ] [ "-123" test-Literal ] unit-test
+[ 1.2 ] [ "1.2" test-Literal ] unit-test
+[ -1.24 ] [ "-1.24" test-Literal ] unit-test
+[ 12.4e7 ] [ "12.4e7" test-Literal ] unit-test
+[ 12.4e-7 ] [ "12.4e-7" test-Literal ] unit-test
+[ -12.4e7 ] [ "-12.4e7" test-Literal ] unit-test
+[ CHAR: x ] [ "$x" test-Literal ] unit-test
+[ "Hello, world" ] [ "'Hello, world'" test-Literal ] unit-test
+[ "Hello, 'funny' world" ] [ "'Hello, ''funny'' world'" test-Literal ] unit-test
+[ T{ symbol f "foo" } ] [ "#foo" test-Literal ] unit-test
+[ T{ symbol f "+" } ] [ "#+" test-Literal ] unit-test
+[ T{ symbol f "at:put:" } ] [ "#at:put:" test-Literal ] unit-test
+[ T{ symbol f "Hello world" } ] [ "#'Hello world'" test-Literal ] unit-test
+[ 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 { "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
+
+EBNF: test-FormalBlockArgumentDeclarationList
+test         = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
+;EBNF
+
+[ V{ "x" "y" "elt" } ] [ ":x :y :elt" test-FormalBlockArgumentDeclarationList ] unit-test
+
+EBNF: test-Operand
+test         = <foreign parse-smalltalk Operand>
+;EBNF
+
+[ { 123 15.6 { t f } } ] [ "#(123 15.6 (true false))" test-Operand ] unit-test
+[ T{ ast-name f "x" } ] [ "x" test-Operand ] unit-test
+
+EBNF: test-Expression
+test         = <foreign parse-smalltalk Expression>
+;EBNF
+
+[ self ] [ "self" test-Expression ] unit-test
+[ { 123 15.6 { t f } } ] [ "#(123 15.6 (true false))" test-Expression ] unit-test
+[ T{ ast-name f "x" } ] [ "x" test-Expression ] unit-test
+[ T{ ast-message-send f 5 "print" { } } ] [ "5 print" test-Expression ] unit-test
+[ T{ ast-message-send f T{ ast-message-send f 5 "squared" { } } "print" { } } ] [ "5 squared print" test-Expression ] unit-test
+[ T{ ast-message-send f 2 "+" { 2 } } ] [ "2+2" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 3 "factorial" { } }
+        "+"
+        { T{ ast-message-send f 4 "factorial" { } } }
+    }
+]
+[ "3 factorial + 4 factorial" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f
+            T{ ast-message-send f 3 "factorial" { } }
+            "+"
+            { 4 }
+        }
+        "factorial"
+        { }
+    }
+]
+[ "(3 factorial + 4) factorial" test-Expression ] unit-test
+EBNF: test-FinalStatement
+test         = <foreign parse-smalltalk FinalStatement>
+;EBNF
+
+[ T{ ast-return f T{ ast-name f "value" } } ] [ "value" test-FinalStatement ] unit-test
+[ T{ ast-return f T{ ast-name f "value" } } ] [ "^value" test-FinalStatement ] unit-test
+[ T{ ast-return f T{ ast-assignment f T{ ast-name f "value" } 5 } } ] [ "value:=5" test-FinalStatement ] unit-test
+
+EBNF: test-LocalVariableDeclarationList
+test         = <foreign parse-smalltalk LocalVariableDeclarationList>
+;EBNF
+
+[ T{ ast-local-variables f { "i" "j" } } ] [ " |  i j   |" test-LocalVariableDeclarationList ] unit-test
+
+
+EBNF: test-KeywordMessageSend
+test         = <foreign parse-smalltalk KeywordMessageSend>
+;EBNF
+
+[ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ]
+[ "x foo:1 bar:2" test-KeywordMessageSend ] unit-test
+
+[
+    T{ ast-message-send
+        f
+        T{ ast-message-send f
+            T{ ast-message-send f 3 "factorial" { } }
+            "+"
+            { T{ ast-message-send f 4 "factorial" { } } }
+        }
+        "between:and:"
+        { 10 100 }
+    }
+]
+[ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
+
+[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
new file mode 100644
index 0000000000..2822165938
--- /dev/null
+++ b/extra/smalltalk/parser/parser.factor
@@ -0,0 +1,203 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings
+math.parser kernel arrays byte-arrays math assocs ;
+IN: smalltalk.parser
+
+! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html
+
+ERROR: bad-number str ;
+
+: check-number ( str -- n )
+    >string dup string>number [ ] [ bad-number ] ?if ;
+
+EBNF: parse-smalltalk
+
+Character = .
+WhitespaceCharacter = (" " | "\t" | "\n" | "\r" )
+DecimalDigit = [0-9]
+Letter = [A-Za-z]
+
+CommentCharacter = [^"] | '""' => [[ CHAR: " ]]
+Comment = '"' (CommentCharacter)*:s '"' => [[ s >string ast-comment boa ]]
+
+OptionalWhiteSpace = (WhitespaceCharacter | Comment)*
+Whitespace = (WhitespaceCharacter | Comment)+
+
+LetterOrDigit = DecimalDigit | Letter
+Identifier = (Letter | "_"):h (LetterOrDigit | "_")*:t => [[ { h t } flatten >string ]]
+Reference = Identifier => [[ ast-name boa ]]
+
+ConstantReference =   "nil" => [[ nil ]]
+                    | "false" => [[ f ]]
+                    | "true" => [[ t ]]
+PseudoVariableReference =   "self" => [[ self ]]
+                          | "super" => [[ super ]]
+ReservedIdentifier = PseudoVariableReference | ConstantReference
+
+BindableIdentifier = Identifier
+
+UnaryMessageSelector = Identifier
+
+Keyword = Identifier:i ":" => [[ i ":" append ]]
+
+KeywordMessageSelector = Keyword+ => [[ concat ]]
+BinarySelectorChar =   "~" | "!" | "@" | "%" | "&" | "*" | "-" | "+"
+                     | "=" | "|" | "\" | "<" | ">" | "," | "?" | "/"
+BinaryMessageSelector = BinarySelectorChar+ => [[ concat ]]
+
+OptionalMinus = ("-" => [[ CHAR: - ]])?
+IntegerLiteral = (OptionalMinus:m UnsignedIntegerLiteral:i) => [[ i m [ neg ] when ]]
+UnsignedIntegerLiteral =   Radix:r "r" BaseNIntegerLiteral:b => [[ b >string r base> ]]
+                         | DecimalIntegerLiteral => [[ check-number ]]
+DecimalIntegerLiteral = DecimalDigit+
+Radix = DecimalIntegerLiteral => [[ check-number ]]
+BaseNIntegerLiteral = LetterOrDigit+
+FloatingPointLiteral = (OptionalMinus
+                        DecimalIntegerLiteral
+                        ("." => [[ CHAR: . ]] DecimalIntegerLiteral Exponent? | Exponent))
+                        => [[ flatten check-number ]]
+Exponent = "e" => [[ CHAR: e ]] (OptionalMinus DecimalIntegerLiteral)?
+
+CharacterLiteral = "$" Character:c => [[ c ]]
+
+StringLiteral = "'" (StringLiteralCharacter | "''" => [[ CHAR: ' ]])*:s "'"
+                => [[ s >string ]]
+StringLiteralCharacter = [^']
+
+SymbolInArrayLiteral =   KeywordMessageSelector
+                       | UnaryMessageSelector
+                       | BinaryMessageSelector
+SymbolLiteral = "#" (SymbolInArrayLiteral | StringLiteral):s => [[ s intern ]]
+
+ArrayLiteral = (ObjectArrayLiteral | ByteArrayLiteral)
+ObjectArrayLiteral = "#" NestedObjectArrayLiteral:elts => [[ elts ]]
+NestedObjectArrayLiteral = "(" OptionalWhiteSpace
+                           (LiteralArrayElement:h
+                            (Whitespace LiteralArrayElement:e => [[ e ]])*:t
+                            => [[ t h prefix ]]
+                           )?:elts OptionalWhiteSpace ")" => [[ elts >array ]]
+
+LiteralArrayElement =   Literal
+                      | NestedObjectArrayLiteral
+                      | SymbolInArrayLiteral
+                      | ConstantReference
+
+ByteArrayLiteral = "#[" OptionalWhiteSpace
+                        (UnsignedIntegerLiteral:h
+                         (Whitespace UnsignedIntegerLiteral:i => [[ i ]])*:t
+                         => [[ t h prefix ]]
+                        )?:elts OptionalWhiteSpace "]" => [[ elts >byte-array ]]
+
+FormalBlockArgumentDeclaration = ":" BindableIdentifier:i => [[ i ]]
+FormalBlockArgumentDeclarationList =
+                FormalBlockArgumentDeclaration:h
+                (Whitespace FormalBlockArgumentDeclaration:v => [[ v ]])*:t
+                => [[ t h prefix ]]
+
+BlockLiteral = "["
+                (OptionalWhiteSpace
+                 FormalBlockArgumentDeclarationList:args
+                 OptionalWhiteSpace
+                 "|"
+                 => [[ args ]]
+                )?:args
+                ExecutableCode:body OptionalWhiteSpace
+                "]" => [[ args >array body ast-block boa ]]
+
+Literal = (ConstantReference
+                | FloatingPointLiteral
+                | IntegerLiteral
+                | CharacterLiteral
+                | StringLiteral
+                | ArrayLiteral
+                | SymbolLiteral
+                | BlockLiteral)
+
+NestedExpression = "(" Statement:s OptionalWhiteSpace ")" => [[ s ]]
+Operand =       Literal
+                | PseudoVariableReference
+                | Reference
+                | NestedExpression
+
+UnaryMessage = UnaryMessageSelector
+UnaryMessageOperand = UnaryMessageSend | Operand
+UnaryMessageSend = UnaryMessageOperand:receiver
+                   OptionalWhiteSpace UnaryMessageSelector:selector !(":")
+                   => [[ receiver selector { } ast-message-send boa ]]
+
+BinaryMessage = BinaryMessageSelector OptionalWhiteSpace BinaryMessageOperand
+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
+
+KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
+KeywordMessageSend = BinaryMessageOperand:receiver
+                     OptionalWhiteSpace
+                     KeywordMessageSegment:h
+                     (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
+                     => [[ receiver t h prefix unzip [ concat ] dip ast-message-send boa ]]
+
+Expression = KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand
+
+AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
+                      OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
+AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment boa ]]
+Statement = AssignmentStatement | Expression
+
+MethodReturnOperator = OptionalWhiteSpace "^"
+FinalStatement = (MethodReturnOperator)? Statement:s => [[ s ast-return boa ]]
+
+LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
+                (BindableIdentifier:h
+                 (Whitespace BindableIdentifier:b => [[ b ]])*:t
+                 => [[ t h prefix ]]
+                )?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
+
+ExecutableCode = (LocalVariableDeclarationList)?
+                 ((Statement:s OptionalWhiteSpace "." => [[ s ]])*
+                 FinalStatement:f (".")? => [[ f ]])?
+                 => [[ sift >array ]]
+
+UnaryMethodHeader = UnaryMessageSelector:selector
+                  => [[ { selector { } } ]]
+BinaryMethodHeader = BinaryMessageSelector:selector OptionalWhiteSpace BindableIdentifier:identifier
+                   => [[ { selector { identifier } } ]]
+KeywordMethodHeaderSegment = Keyword:keyword
+                             OptionalWhiteSpace
+                             BindableIdentifier:identifier => [[ { keyword identifier } ]]
+KeywordMethodHeader = KeywordMethodHeaderSegment:h (Whitespace KeywordMethodHeaderSegment:s => [[ s ]])*:t
+                    => [[ t h prefix unzip [ concat ] dip 2array ]]
+MethodHeader =   KeywordMethodHeader
+               | BinaryMethodHeader
+               | UnaryMethodHeader
+MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:header
+        OptionalWhiteSpace "["
+        ExecutableCode:code
+        OptionalWhiteSpace "]"
+        => [[ header first2 "self" suffix code ast-block boa ast-method boa ]]
+
+ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
+        OptionalWhiteSpace
+        ("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
+        OptionalWhiteSpace "["
+        (OptionalWhiteSpace LocalVariableDeclarationList)?:ivars
+        (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix >array ]])?:methods
+        OptionalWhiteSpace "]"
+        => [[ name superclass "Object" or ivars methods ast-class boa ]]
+
+End = !(.)
+
+Program = ClassDeclaration* End
+;EBNF
\ No newline at end of file
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
new file mode 100644
index 0000000000..7771ee2b9c
--- /dev/null
+++ b/extra/smalltalk/parser/test.st
@@ -0,0 +1,66 @@
+class TreeNode extends Object [
+    |left right item|
+
+    method binarytrees: n to: output [
+        | minDepth maxDepth stretchDepth check longLivedTree iterations |
+        minDepth := 4.
+        maxDepth := minDepth + 2 max: n.
+        stretchDepth := maxDepth + 1.
+
+        check := (TreeNode bottomUpTree: 0 depth: stretchDepth) itemCheck.
+        output
+            nextPutAll: 'stretch tree of depth '; print: stretchDepth; tab;
+            nextPutAll: ' check: '; print: check; nl.
+
+        longLivedTree := TreeNode bottomUpTree: 0 depth: maxDepth.
+        minDepth to: maxDepth by: 2 do: [:depth|
+            iterations := 1 bitShift: maxDepth - depth + minDepth.
+
+            check := 0.
+            1 to: iterations do: [:i|
+                check := check + (TreeNode bottomUpTree: i depth: depth) itemCheck.
+                check := check + (TreeNode bottomUpTree: -1*i depth: depth) itemCheck
+            ].
+            output
+                print:  (2*iterations); tab;
+                nextPutAll: ' trees of depth '; print: depth; tab;
+                nextPutAll: ' check: '; print: check; nl
+            ].
+
+        output
+            nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
+            nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
+    ]
+
+    binarytrees [
+        self binarytrees: self arg to: self stdout.
+        ^''
+    ]
+
+    method left: leftChild right: rightChild item: anItem [
+        left := leftChild.
+        right := rightChild.
+        item := anItem
+    ]
+
+    method itemCheck [
+        ^left isNil
+            ifTrue: [item] ifFalse: [item + (left itemCheck - right itemCheck)]
+    ]
+
+    method bottomUpTree: anItem depth: anInteger [
+        ^(anInteger > 0)
+            ifTrue: [
+                self
+                    left: (self bottomUpTree: 2*anItem - 1 depth: anInteger - 1)
+                    right: (self bottomUpTree: 2*anItem depth: anInteger - 1)
+                    item: anItem
+            ] ifFalse: [self left: nil right: nil item: anItem]
+    ]
+
+    method left: leftChild right: rightChild item: anItem [
+        ^(super new) left: leftChild right: rightChild item: anItem
+    ]
+]
+
+Tests binarytrees.
diff --git a/extra/smalltalk/selectors/authors.txt b/extra/smalltalk/selectors/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/selectors/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/selectors/selectors.factor b/extra/smalltalk/selectors/selectors.factor
new file mode 100644
index 0000000000..51b2132dbe
--- /dev/null
+++ b/extra/smalltalk/selectors/selectors.factor
@@ -0,0 +1,26 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators effects generic generic.standard
+kernel sequences words ;
+IN: smalltalk.selectors
+
+SYMBOLS: unary binary keyword ;
+
+: selector-type ( selector -- type )
+    {
+        { [ dup [ "+-*/%^&*|@" member? ] all? ] [ binary ] }
+        { [ CHAR: : over member? ] [ keyword ] }
+        [ unary ]
+    } cond nip ;
+
+: selector>effect ( selector -- effect )
+    dup selector-type {
+        { unary [ drop 0 ] }
+        { binary [ drop 1 ] }
+        { keyword [ [ CHAR: : = ] count ] }
+    } case "receiver" suffix { "result" } <effect> ;
+
+: selector>generic ( selector -- generic )
+    [ "selector-" prepend "smalltalk.selectors" create dup ]
+    [ selector>effect ]
+    bi define-simple-generic ;
diff --git a/extra/smalltalk/smalltalk.factor b/extra/smalltalk/smalltalk.factor
new file mode 100644
index 0000000000..27cd9912ed
--- /dev/null
+++ b/extra/smalltalk/smalltalk.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: smalltalk

From 381dbb957c44f8f17cd975329b1ca6f0277cc5dc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 30 Mar 2009 20:45:01 -0500
Subject: [PATCH 02/12] smalltalk: adding a small library, fix various bugs

---
 .../smalltalk/compiler/compiler-tests.factor  | 105 ++++++++++++------
 extra/smalltalk/compiler/compiler.factor      |  47 ++++++--
 extra/smalltalk/compiler/lexenv/lexenv.factor |  10 +-
 extra/smalltalk/library/authors.txt           |   1 +
 extra/smalltalk/library/library.factor        |  75 +++++++++++++
 extra/smalltalk/listener/authors.txt          |   1 +
 extra/smalltalk/listener/listener.factor      |  18 +++
 extra/smalltalk/parser/parser-tests.factor    |  77 ++++++++++++-
 extra/smalltalk/parser/parser.factor          |  19 +++-
 extra/smalltalk/printer/authors.txt           |   1 +
 extra/smalltalk/printer/printer.factor        |  34 ++++++
 extra/smalltalk/selectors/selectors.factor    |   6 +-
 12 files changed, 343 insertions(+), 51 deletions(-)
 create mode 100644 extra/smalltalk/library/authors.txt
 create mode 100644 extra/smalltalk/library/library.factor
 create mode 100644 extra/smalltalk/listener/authors.txt
 create mode 100644 extra/smalltalk/listener/listener.factor
 create mode 100644 extra/smalltalk/printer/authors.txt
 create mode 100644 extra/smalltalk/printer/printer.factor

diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
index ee944baf02..a8e918fcf4 100644
--- a/extra/smalltalk/compiler/compiler-tests.factor
+++ b/extra/smalltalk/compiler/compiler-tests.factor
@@ -3,43 +3,82 @@ stack-checker locals.rewrite.closures kernel accessors
 compiler.units sequences ;
 IN: smalltalk.compiler.tests
 
-[ 2 1 ] [
+: test-compilation ( ast -- quot )
     [
-        T{ ast-block f
-           { "a" "b" }
-           {
-               T{ ast-message-send f
-                  T{ ast-name f "a" }
-                  "+"
-                  { T{ ast-name f "b" } }
-               }
+        compile-method rewrite-closures first
+    ] with-compilation-unit ;
+
+: test-inference ( ast -- in# out# )
+    test-compilation infer [ in>> ] [ out>> ] bi ;
+
+[ 2 1 ] [
+    T{ ast-block f
+       { "a" "b" }
+       {
+           T{ ast-message-send f
+              T{ ast-name f "a" }
+              "+"
+              { T{ ast-name f "b" } }
            }
-        } compile-method
-        [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
-    ] with-compilation-unit
+       }
+    } test-inference
 ] unit-test
 
 [ 3 1 ] [
-    [
-        T{ ast-block f
-           { "a" "b" "c" }
-           {
-               T{ ast-assignment f
-                  T{ ast-name f "a" }
-                  T{ ast-message-send f
-                     T{ ast-name f "a" }
-                     "+"
-                     { T{ ast-name f "b" } }
-                  }
-               }
-               T{ ast-message-send f
-                  T{ ast-name f "b" }
-                  "blah:"
-                  { 123.456 }
-               }
-               T{ ast-return f T{ ast-name f "c" } }
+    T{ ast-block f
+       { "a" "b" "c" }
+       {
+           T{ ast-assignment f
+              T{ ast-name f "a" }
+              T{ ast-message-send f
+                 T{ ast-name f "asmal" }
+                 "+"
+                 { T{ ast-name f "b" } }
+              }
            }
-        } compile-method
-        [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
-    ] with-compilation-unit
+           T{ ast-message-send f
+              T{ ast-name f "b" }
+              "blah:"
+              { 123.456 }
+           }
+           T{ ast-return f T{ ast-name f "c" } }
+       }
+    } test-inference
+] unit-test
+
+[ 0 1 ] [
+    T{ ast-block f
+       { }
+       {
+           T{ ast-message-send
+              { receiver 1 }
+              { selector "to:do:" }
+              { arguments
+                {
+                    10
+                    T{ ast-block
+                       { arguments { "i" } }
+                       { body
+                         {
+                             T{ ast-message-send
+                                { receiver
+                                  T{ ast-name { name "i" } }
+                                }
+                                { selector "print" }
+                             }
+                         }
+                       }
+                    }
+                }
+              }
+           }
+       }
+    } test-inference
+] unit-test
+
+[ "a" ] [
+    T{ ast-block f
+       { }
+       { { T{ ast-block { body { "a" } } } } }
+    } test-compilation call first call
 ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 1f3b0f94e5..b72b218f82 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators.short-circuit
 continuations fry kernel namespaces quotations sequences sets
-slots locals.types generalizations smalltalk.ast
+generalizations slots locals.types generalizations smalltalk.ast
 smalltalk.compiler.lexenv smalltalk.selectors ;
 IN: smalltalk.compiler
 
@@ -12,17 +12,19 @@ GENERIC: need-return-continuation? ( ast -- ? )
 
 M: ast-return need-return-continuation? drop t ;
 
-M: ast-block need-return-continuation? body>> [ need-return-continuation? ] any? ;
+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? ] any? ]
+        [ arguments>> need-return-continuation? ]
     } 1&& ;
 
 M: ast-assignment need-return-continuation?
     value>> need-return-continuation? ;
 
+M: array need-return-continuation? [ need-return-continuation? ] any? ;
+
 M: object need-return-continuation? drop f ;
 
 GENERIC: assigned-locals ( ast -- seq )
@@ -30,16 +32,20 @@ GENERIC: assigned-locals ( ast -- seq )
 M: ast-return assigned-locals value>> assigned-locals ;
 
 M: ast-block assigned-locals
-    [ body>> [ assigned-locals ] map concat ] [ arguments>> ] bi diff ;
+    [ body>> assigned-locals ] [ arguments>> ] bi diff ;
 
 M: ast-message-send assigned-locals
+    [ arguments>> assigned-locals ]
     [ receiver>> assigned-locals ]
-    [ arguments>> [ assigned-locals ] map ] bi append ;
+    bi append ;
 
 M: ast-assignment assigned-locals
     [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
     [ value>> assigned-locals ] bi append ;
 
+M: array assigned-locals
+    [ assigned-locals ] map concat ;
+
 M: object assigned-locals drop f ;
 
 GENERIC: compile-ast ( lexenv ast -- quot )
@@ -52,8 +58,8 @@ M: ast-name compile-ast
     name>> swap local-readers>> at 1quotation ;
 
 M: ast-message-send compile-ast
+    [ arguments>> [ compile-ast ] with map [ ] join ]
     [ receiver>> compile-ast ]
-    [ arguments>> [ compile-ast ] with map concat ]
     [ nip selector>> selector>generic ]
     2tri [ append ] dip suffix ;
 
@@ -61,6 +67,22 @@ M: ast-return compile-ast
     value>> compile-ast
     [ return-continuation get continue-with ] append ;
 
+GENERIC: contains-blocks? ( obj -- ? )
+
+M: ast-block contains-blocks? drop t ;
+
+M: object contains-blocks? drop f ;
+
+M: array contains-blocks? [ contains-blocks? ] any? ;
+
+M: array compile-ast
+    dup contains-blocks? [
+        [ [ compile-ast ] with map [ ] join ] [ length ] bi
+        '[ @ _ narray ]
+    ] [
+        call-next-method
+    ] if ;
+
 GENERIC: compile-assignment ( lexenv name -- quot )
 
 M: ast-name compile-assignment
@@ -95,8 +117,15 @@ M: ast-block compile-ast
         bi-curry* bi
         append
     ] if-empty
-    <lambda> '[ @ ] ;
+    <lambda> '[ _ ] ;
 
 : compile-method ( block -- quot )
-    [ [ empty-lexenv ] dip compile-ast ] [ arguments>> length ] [ need-return-continuation? ] tri
-    [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
\ No newline at end of file
+    [ [ 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 ;
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index 2488a54c5f..2097dc8a50 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -3,9 +3,15 @@
 USING: assocs kernel accessors ;
 IN: smalltalk.compiler.lexenv
 
-TUPLE: lexenv local-readers local-writers ;
+! local-readers: assoc string => word
+! local-writers: assoc string => word
+! self: word or f for top-level forms
+! class: class word or f for top-level forms
+! method: generic word or f for top-level forms
+TUPLE: lexenv local-readers local-writers self class method ;
 
-C: <lexenv> lexenv
+: <lexenv> ( local-readers local-writers -- lexenv )
+    f f f lexenv boa ; inline
 
 CONSTANT: empty-lexenv T{ lexenv }
 
diff --git a/extra/smalltalk/library/authors.txt b/extra/smalltalk/library/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/library/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
new file mode 100644
index 0000000000..bf455c2c4a
--- /dev/null
+++ b/extra/smalltalk/library/library.factor
@@ -0,0 +1,75 @@
+! 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 ;
+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: *
+SELECTOR: /
+SELECTOR: <
+SELECTOR: >
+SELECTOR: <=
+SELECTOR: >=
+SELECTOR: =
+
+M: object selector-+  swap +  ;
+M: object selector--  swap -  ;
+M: object selector-*  swap *  ;
+M: object selector-/  swap /  ;
+M: object selector-<  swap <  ;
+M: object selector->  swap >  ;
+M: object selector-<= swap <= ;
+M: object selector->= swap >= ;
+M: object selector-=  swap =  ;
+
+! Some keyword selectors
+SELECTOR: ifTrue:
+SELECTOR: ifFalse:
+SELECTOR: ifTrue:ifFalse:
+
+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: at:
+SELECTOR: at:put:
+
+M: sequence selector-at: nth ;
+M: sequence selector-at:put: ( key value receiver -- receiver ) [ swapd set-nth ] keep ;
+
+M: assoc selector-at: at ;
+M: assoc selector-at:put: ( key value receiver -- receiver ) [ swapd set-at ] keep ;
+
+SELECTOR: do:
+
+M:: object selector-do: ( quot receiver -- nil )
+    receiver [ quot call( elt -- result ) drop ] each nil ;
+
+SELECTOR: to:
+SELECTOR: to:do:
+
+M: object selector-to: swap [a,b] ;
+M:: object selector-to:do: ( to quot from -- nil )
+    from to [a,b] [ quot call( i -- result ) drop ] each nil ;
+
+SELECTOR: value
+SELECTOR: value:
+SELECTOR: value:value:
+SELECTOR: value:value:value:
+SELECTOR: value:value:value:value:
+
+M: object selector-value call( -- result ) ;
+M: object selector-value: call( input -- result ) ;
+M: object selector-value:value: call( input input -- result ) ;
+M: object selector-value:value:value: call( input input input -- result ) ;
+M: object selector-value:value:value:value: call( input input input input -- result ) ;
diff --git a/extra/smalltalk/listener/authors.txt b/extra/smalltalk/listener/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/listener/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
new file mode 100644
index 0000000000..e1bb6aca5e
--- /dev/null
+++ b/extra/smalltalk/listener/listener.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! 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 ;
+IN: smalltalk.listener
+
+: eval-smalltalk ( string -- )
+    [
+        parse-smalltalk-statement compile-statement rewrite-closures first
+    ] with-compilation-unit call( -- result )
+    dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ;
+
+: smalltalk-listener ( -- )
+    "Smalltalk>" { { background COLOR: light-blue } } format bl flush readln
+    [ '[ _ eval-smalltalk ] try smalltalk-listener ] when* ;
+
+MAIN: smalltalk-listener
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index 9a6614aa07..fa0fde51d6 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -53,6 +53,21 @@ test         = <foreign parse-smalltalk Literal>
 [ 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
+       { arguments { "i" } }
+       { body
+         {
+             T{ ast-message-send
+                { receiver T{ ast-name { name "i" } } }
+                { selector "print" }
+             }
+         }
+       }
+    }
+]
+[ "[ :i | i print ]" test-Literal ] unit-test
+
 EBNF: test-FormalBlockArgumentDeclarationList
 test         = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
 ;EBNF
@@ -86,6 +101,24 @@ test         = <foreign parse-smalltalk Expression>
 ]
 [ "3 factorial + 4 factorial" test-Expression ] unit-test
 
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 3 "factorial" { } }
+        "+"
+        { T{ ast-message-send f 4 "factorial" { } } }
+    }
+]
+[ "   3 factorial + 4 factorial" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 3 "factorial" { } }
+        "+"
+        { T{ ast-message-send f 4 "factorial" { } } }
+    }
+]
+[ "   3 factorial + 4 factorial     " test-Expression ] unit-test
+
 [
     T{ ast-message-send f
         T{ ast-message-send f
@@ -98,13 +131,53 @@ test         = <foreign parse-smalltalk Expression>
     }
 ]
 [ "(3 factorial + 4) factorial" test-Expression ] unit-test
+
+[
+    T{ ast-message-send
+       { receiver
+         T{ ast-message-send
+            { receiver
+              T{ ast-message-send
+                 { receiver 1 }
+                 { selector "<" }
+                 { arguments { 10 } }
+              }
+            }
+            { selector "ifTrue:ifFalse:" }
+            { arguments
+              {
+                  T{ ast-block { body { "HI" } } }
+                  T{ ast-block { body { "BYE" } } }
+              }
+            }
+         }
+       }
+       { selector "print" }
+    }
+]
+[ "((1 < 10) ifTrue: [ 'HI' ] ifFalse: [ 'BYE' ]) print" test-Expression ] unit-test
+
+[
+    T{ ast-message-send
+       { receiver
+         T{ ast-message-send
+            { receiver { T{ ast-block { body { "a" } } } } }
+            { selector "at:" }
+            { arguments { 0 } }
+         }
+       }
+       { selector "value" }
+    }
+]
+[ "(#(['a']) at: 0) value" test-Expression ] unit-test
+
 EBNF: test-FinalStatement
 test         = <foreign parse-smalltalk FinalStatement>
 ;EBNF
 
-[ T{ ast-return f T{ ast-name f "value" } } ] [ "value" test-FinalStatement ] unit-test
+[ T{ ast-name f "value" } ] [ "value" test-FinalStatement ] unit-test
 [ T{ ast-return f T{ ast-name f "value" } } ] [ "^value" test-FinalStatement ] unit-test
-[ T{ ast-return f T{ ast-assignment f T{ ast-name f "value" } 5 } } ] [ "value:=5" test-FinalStatement ] unit-test
+[ T{ ast-assignment f T{ ast-name f "value" } 5 } ] [ "value:=5" test-FinalStatement ] unit-test
 
 EBNF: test-LocalVariableDeclarationList
 test         = <foreign parse-smalltalk LocalVariableDeclarationList>
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index 2822165938..e2fea234c8 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -143,13 +143,15 @@ BinaryMessageSend = (BinaryMessageSend:lhs
                     | BinaryMessageSend-1
 
 KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
-KeywordMessageSend = BinaryMessageOperand:receiver
+KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):receiver
                      OptionalWhiteSpace
                      KeywordMessageSegment:h
                      (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
                      => [[ receiver t h prefix unzip [ concat ] dip ast-message-send boa ]]
 
-Expression = KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand
+Expression = OptionalWhiteSpace
+             (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
+             => [[ e ]]
 
 AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
                       OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
@@ -157,7 +159,8 @@ AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment
 Statement = AssignmentStatement | Expression
 
 MethodReturnOperator = OptionalWhiteSpace "^"
-FinalStatement = (MethodReturnOperator)? Statement:s => [[ s ast-return boa ]]
+FinalStatement = (MethodReturnOperator Statement:s => [[ s ast-return boa ]])
+                 | Statement
 
 LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
                 (BindableIdentifier:h
@@ -200,4 +203,14 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
 End = !(.)
 
 Program = ClassDeclaration* End
+;EBNF
+
+EBNF: parse-smalltalk-statement
+
+Statement = <foreign parse-smalltalk Statement>
+
+End = !(.)
+
+Program = Statement? => [[ nil or ]] End
+
 ;EBNF
\ No newline at end of file
diff --git a/extra/smalltalk/printer/authors.txt b/extra/smalltalk/printer/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/printer/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/printer/printer.factor b/extra/smalltalk/printer/printer.factor
new file mode 100644
index 0000000000..70055e8e77
--- /dev/null
+++ b/extra/smalltalk/printer/printer.factor
@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays kernel make math
+math.parser prettyprint sequences smalltalk.ast strings ;
+IN: smalltalk.printer
+
+GENERIC: smalltalk>string ( object -- string )
+
+M: real smalltalk>string number>string ;
+
+M: string smalltalk>string
+    [
+        "'" %
+        [ dup CHAR: ' = [ dup , , ] [ , ] if ] each
+        "'" %
+    ] "" make ;
+
+GENERIC: array-element>string ( object -- string )
+
+M: object array-element>string smalltalk>string ;
+
+M: array array-element>string
+    [ smalltalk>string ] map " " join "(" ")" surround ;
+
+M: array smalltalk>string
+    array-element>string "#" prepend ;
+
+M: byte-array smalltalk>string
+    [ number>string ] { } map-as " " join "#[" "]" surround ;
+
+M: symbol smalltalk>string
+    name>> smalltalk>string "#" prepend ;
+
+M: object smalltalk>string unparse-short ;
\ No newline at end of file
diff --git a/extra/smalltalk/selectors/selectors.factor b/extra/smalltalk/selectors/selectors.factor
index 51b2132dbe..2ea1e99afd 100644
--- a/extra/smalltalk/selectors/selectors.factor
+++ b/extra/smalltalk/selectors/selectors.factor
@@ -1,14 +1,14 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators effects generic generic.standard
-kernel sequences words ;
+kernel sequences words lexer ;
 IN: smalltalk.selectors
 
 SYMBOLS: unary binary keyword ;
 
 : selector-type ( selector -- type )
     {
-        { [ dup [ "+-*/%^&*|@" member? ] all? ] [ binary ] }
+        { [ dup [ "~!@%&*-+=|\\<>,?/" member? ] all? ] [ binary ] }
         { [ CHAR: : over member? ] [ keyword ] }
         [ unary ]
     } cond nip ;
@@ -24,3 +24,5 @@ SYMBOLS: unary binary keyword ;
     [ "selector-" prepend "smalltalk.selectors" create dup ]
     [ selector>effect ]
     bi define-simple-generic ;
+
+SYNTAX: SELECTOR: scan selector>generic drop ;
\ No newline at end of file

From 5b6948aaa5b4c652f0833fbbe74cb8a08d039515 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 01:24:38 -0500
Subject: [PATCH 03/12] smalltalk: working on lexical scoping for instance
 variables and class names

---
 extra/smalltalk/ast/ast.factor                |  2 +
 extra/smalltalk/classes/authors.txt           |  1 +
 extra/smalltalk/classes/classes.factor        | 25 ++++++
 .../smalltalk/compiler/compiler-tests.factor  | 10 +--
 extra/smalltalk/compiler/compiler.factor      | 88 +++++++++++++------
 .../compiler/lexenv/lexenv-tests.factor       | 24 +++++
 extra/smalltalk/compiler/lexenv/lexenv.factor | 54 ++++++++++--
 extra/smalltalk/library/library.factor        |  6 +-
 extra/smalltalk/listener/listener.factor      |  2 +-
 extra/smalltalk/parser/parser-tests.factor    | 18 ++++
 extra/smalltalk/parser/parser.factor          | 25 +++---
 11 files changed, 199 insertions(+), 56 deletions(-)
 create mode 100644 extra/smalltalk/classes/authors.txt
 create mode 100644 extra/smalltalk/classes/classes.factor
 create mode 100644 extra/smalltalk/compiler/lexenv/lexenv-tests.factor

diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index 83e6d0ae84..f426789316 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -14,5 +14,7 @@ TUPLE: ast-assignment { name ast-name } value ;
 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: symbol { name string } ;
 MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
diff --git a/extra/smalltalk/classes/authors.txt b/extra/smalltalk/classes/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/classes/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/classes/classes.factor b/extra/smalltalk/classes/classes.factor
new file mode 100644
index 0000000000..1798aad961
--- /dev/null
+++ b/extra/smalltalk/classes/classes.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors words sequences classes.tuple ;
+IN: smalltalk.classes
+
+SYMBOL: classes
+
+classes [ H{ } clone ] initialize
+
+: create-class ( class -- class )
+    "smalltalk.classes" create ;
+
+ERROR: no-class name ;
+
+: lookup-class ( class -- class )
+    classes get ?at [ ] [ no-class ] if ;
+
+: define-class ( class superclass ivars -- class-word )
+    [ create-class ] [ lookup-class ] [ ] tri*
+    [ define-tuple-class ] [ 2drop dup dup name>> classes get set-at ] 3bi ;
+
+: define-foreign ( class name -- )
+    classes get set-at ;
+
+tuple "Object" define-foreign
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
index a8e918fcf4..c0b9507dd0 100644
--- a/extra/smalltalk/compiler/compiler-tests.factor
+++ b/extra/smalltalk/compiler/compiler-tests.factor
@@ -1,12 +1,10 @@
 USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
-stack-checker locals.rewrite.closures kernel accessors
-compiler.units sequences ;
+smalltalk.compiler.lexenv stack-checker locals.rewrite.closures
+kernel accessors compiler.units sequences ;
 IN: smalltalk.compiler.tests
 
 : test-compilation ( ast -- quot )
-    [
-        compile-method rewrite-closures first
-    ] with-compilation-unit ;
+    [ compile-smalltalk [ call ] append ] with-compilation-unit ;
 
 : test-inference ( ast -- in# out# )
     test-compilation infer [ in>> ] [ out>> ] bi ;
@@ -31,7 +29,7 @@ IN: smalltalk.compiler.tests
            T{ ast-assignment f
               T{ ast-name f "a" }
               T{ ast-message-send f
-                 T{ ast-name f "asmal" }
+                 T{ ast-name f "c" }
                  "+"
                  { T{ ast-name f "b" } }
               }
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index b72b218f82..9c3638ba6c 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -2,8 +2,10 @@
 ! 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 ;
+generalizations slots locals.types generalizations splitting math
+locals.rewrite.closures generic words smalltalk.ast
+smalltalk.compiler.lexenv smalltalk.selectors
+smalltalk.classes ;
 IN: smalltalk.compiler
 
 SYMBOL: return-continuation
@@ -52,10 +54,11 @@ GENERIC: compile-ast ( lexenv ast -- quot )
 
 M: object compile-ast nip 1quotation ;
 
+M: self compile-ast drop self>> 1quotation ;
+
 ERROR: unbound-local name ;
 
-M: ast-name compile-ast
-    name>> swap local-readers>> at 1quotation ;
+M: ast-name compile-ast name>> swap lookup-reader ;
 
 M: ast-message-send compile-ast
     [ arguments>> [ compile-ast ] with map [ ] join ]
@@ -79,14 +82,11 @@ M: array compile-ast
     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 ;
@@ -102,30 +102,62 @@ M: ast-assignment compile-ast
     dup
     [ nip local-reader? ] assoc-filter
     [ <local-writer> ] assoc-map
-    <lexenv> ;
+    <lexenv> swap >>local-writers swap >>local-readers ;
 
-M: ast-block compile-ast
+: compile-block ( lexenv block -- vars body )
     [
         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> '[ _ ] ;
+    [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
 
-: 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 ;
+M: ast-block compile-ast
+    compile-block <lambda> '[ _ ] ;
 
-: compile-statement ( statement -- quot )
-    [ [ empty-lexenv ] dip compile-ast ] [ need-return-continuation? ] bi
-    [ '[ [ [ return-continuation set @ ] callcc1 ] with-scope ] ] when ;
+: 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 )
+
+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
+    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-reader> >>self ;
+
+M: ast-class compile-smalltalk ( ast-class -- quot )
+    [
+        [ name>> ] [ superclass>> ] [ ivars>> ] tri
+        define-class <class-lexenv> 
+    ]
+    [ methods>> ] bi
+    [ compile-method ] with each
+    [ nil ] ;
+
+ERROR: no-word name ;
+
+M: ast-foreign compile-smalltalk
+    [ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ]
+    [ name>> ] bi define-foreign
+    [ nil ] ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv-tests.factor b/extra/smalltalk/compiler/lexenv/lexenv-tests.factor
new file mode 100644
index 0000000000..8f171f3eed
--- /dev/null
+++ b/extra/smalltalk/compiler/lexenv/lexenv-tests.factor
@@ -0,0 +1,24 @@
+USING: smalltalk.compiler.lexenv tools.test kernel namespaces accessors ;
+IN: smalltalk.compiler.lexenv.tests
+
+TUPLE: some-class x y z ;
+
+SYMBOL: fake-self
+
+SYMBOL: fake-local
+
+<lexenv>
+    some-class >>class
+    fake-self >>self
+    H{ { "mumble" fake-local } } >>local-readers
+    H{ { "jumble" fake-local } } >>local-writers
+lexenv set
+
+[ [ fake-local ] ] [ "mumble" lexenv get lookup-reader ] unit-test
+[ [ fake-self x>> ] ] [ "x" lexenv get lookup-reader ] unit-test
+[ [ \ tuple ] ] [ "Object" lexenv get lookup-reader ] unit-test
+
+[ [ fake-local ] ] [ "jumble" lexenv get lookup-writer ] unit-test
+[ [ fake-self (>>y) ] ] [ "y" lexenv get lookup-writer ] unit-test
+
+[ "blahblah" lexenv get lookup-writer ] must-fail
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index 2097dc8a50..b204b057b6 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -1,6 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel accessors ;
+USING: assocs kernel accessors quotations slots words
+sequences namespaces combinators combinators.short-circuit
+smalltalk.classes ;
 IN: smalltalk.compiler.lexenv
 
 ! local-readers: assoc string => word
@@ -10,11 +12,53 @@ IN: smalltalk.compiler.lexenv
 ! method: generic word or f for top-level forms
 TUPLE: lexenv local-readers local-writers self class method ;
 
-: <lexenv> ( local-readers local-writers -- lexenv )
-    f f f lexenv boa ; inline
+: <lexenv> ( -- lexenv ) lexenv new ; inline
 
 CONSTANT: empty-lexenv T{ lexenv }
 
 : lexenv-union ( lexenv1 lexenv2 -- lexenv )
-    [ [ local-readers>> ] bi@ assoc-union ]
-    [ [ local-writers>> ] bi@ assoc-union ] 2bi <lexenv> ;
+    [ <lexenv> ] 2dip {
+        [ [ local-readers>> ] bi@ assoc-union >>local-readers ]
+        [ [ local-writers>> ] bi@ assoc-union >>local-writers ]
+        [ [ self>> ] either? >>self ]
+        [ [ class>> ] either? >>class ]
+        [ [ method>> ] either? >>method ]
+    } 2cleave ;
+
+: local-reader ( name lexenv -- local )
+    local-readers>> at dup [ 1quotation ] when ;
+
+: ivar-reader ( name lexenv -- quot/f )
+    dup class>> [
+        [ class>> "slots" word-prop slot-named ] [ self>> ] bi
+        swap dup [ name>> reader-word [ ] 2sequence ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
+
+: class-name ( name -- quot/f )
+    classes get at dup [ [ ] curry ] when ;
+
+ERROR: bad-identifier name ;
+
+: lookup-reader ( name lexenv -- reader-quot )
+    {
+        [ local-reader ]
+        [ ivar-reader ]
+        [ drop class-name ]
+        [ drop bad-identifier ]
+    } 2|| ;
+
+: local-writer ( name lexenv -- local )
+    local-writers>> at dup [ 1quotation ] when ;
+
+: ivar-writer ( name lexenv -- quot/f )
+    dup class>> [
+        [ class>> "slots" word-prop slot-named ] [ self>> ] bi
+        swap dup [ name>> writer-word [ ] 2sequence ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
+
+: lookup-writer ( name lexenv -- writer-quot )
+    {
+        [ local-writer ]
+        [ ivar-writer ]
+        [ drop bad-identifier ]
+    } 2|| ;
\ No newline at end of file
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
index bf455c2c4a..1b24db71e8 100644
--- a/extra/smalltalk/library/library.factor
+++ b/extra/smalltalk/library/library.factor
@@ -1,7 +1,7 @@
 ! 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 ;
+locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
 IN: smalltalk.library
 
 ! Some unary selectors
@@ -73,3 +73,7 @@ M: object selector-value: call( input -- result ) ;
 M: object selector-value:value: call( input input -- result ) ;
 M: object selector-value:value:value: call( input input input -- result ) ;
 M: object selector-value:value:value:value: call( input input input input -- result ) ;
+
+SELECTOR: new
+
+M: object selector-new new ;
\ No newline at end of file
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
index e1bb6aca5e..bef4adc196 100644
--- a/extra/smalltalk/listener/listener.factor
+++ b/extra/smalltalk/listener/listener.factor
@@ -7,7 +7,7 @@ IN: smalltalk.listener
 
 : eval-smalltalk ( string -- )
     [
-        parse-smalltalk-statement compile-statement rewrite-closures first
+        parse-smalltalk compile-smalltalk
     ] with-compilation-unit call( -- result )
     dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ;
 
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index fa0fde51d6..aa440f581e 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -68,6 +68,13 @@ test         = <foreign parse-smalltalk Literal>
 ]
 [ "[ :i | i print ]" test-Literal ] unit-test
 
+[
+    T{ ast-block
+       { body { 5 self } }
+    }
+]
+[ "[5. self]" test-Literal ] unit-test
+
 EBNF: test-FormalBlockArgumentDeclarationList
 test         = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
 ;EBNF
@@ -207,4 +214,15 @@ 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-class
+       { name "Test" }
+       { superclass "Object" }
+       { ivars { "a" } }
+    }
+]
+[ "class Test [|a|]" parse-smalltalk ] unit-test
+
 [ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index e2fea234c8..e153e1552d 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings
-math.parser kernel arrays byte-arrays math assocs ;
+math.parser kernel arrays byte-arrays math assocs accessors ;
 IN: smalltalk.parser
 
 ! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html
@@ -189,28 +189,23 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:
         OptionalWhiteSpace "["
         ExecutableCode:code
         OptionalWhiteSpace "]"
-        => [[ header first2 "self" suffix code ast-block boa ast-method boa ]]
+        => [[ header first2 code ast-block boa ast-method boa ]]
 
 ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
         OptionalWhiteSpace
         ("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
         OptionalWhiteSpace "["
-        (OptionalWhiteSpace LocalVariableDeclarationList)?:ivars
-        (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix >array ]])?:methods
+        (OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars
+        (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix ]])?:methods
         OptionalWhiteSpace "]"
-        => [[ name superclass "Object" or ivars methods ast-class boa ]]
+        => [[ name superclass "Object" or ivars >array methods >array ast-class boa ]]
 
+ForeignClassDeclaration = OptionalWhiteSpace "foreign"
+                          OptionalWhiteSpace Identifier:name
+                          OptionalWhiteSpace Literal:class
+                          => [[ class name ast-foreign boa ]]
 End = !(.)
 
-Program = ClassDeclaration* End
-;EBNF
-
-EBNF: parse-smalltalk-statement
-
-Statement = <foreign parse-smalltalk Statement>
-
-End = !(.)
-
-Program = Statement? => [[ nil or ]] End
+Program = (ClassDeclaration|ForeignClassDeclaration|ExecutableCode) => [[ nil or ]] End
 
 ;EBNF
\ No newline at end of file

From 712b21b59e14c78e387b3e6cd17fb0471ed46960 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 01:37:05 -0500
Subject: [PATCH 04/12] Fix printing of nested arrays

---
 extra/smalltalk/printer/printer-tests.factor | 4 ++++
 extra/smalltalk/printer/printer.factor       | 2 +-
 2 files changed, 5 insertions(+), 1 deletion(-)
 create mode 100644 extra/smalltalk/printer/printer-tests.factor

diff --git a/extra/smalltalk/printer/printer-tests.factor b/extra/smalltalk/printer/printer-tests.factor
new file mode 100644
index 0000000000..e9f4bd9451
--- /dev/null
+++ b/extra/smalltalk/printer/printer-tests.factor
@@ -0,0 +1,4 @@
+IN: smalltalk.printer.tests
+USING: smalltalk.printer tools.test ;
+
+[ "#((1 2) 'hi')" ] [ { { 1 2 } "hi" } smalltalk>string ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/printer/printer.factor b/extra/smalltalk/printer/printer.factor
index 70055e8e77..9b6aa11114 100644
--- a/extra/smalltalk/printer/printer.factor
+++ b/extra/smalltalk/printer/printer.factor
@@ -20,7 +20,7 @@ GENERIC: array-element>string ( object -- string )
 M: object array-element>string smalltalk>string ;
 
 M: array array-element>string
-    [ smalltalk>string ] map " " join "(" ")" surround ;
+    [ array-element>string ] map " " join "(" ")" surround ;
 
 M: array smalltalk>string
     array-element>string "#" prepend ;

From 15cb926afb6504bb24095f2788df3fdf0d2612ba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 21:23:09 -0500
Subject: [PATCH 05/12] smalltalk: Working on message cascade syntax

---
 extra/smalltalk/ast/ast.factor                | 11 ++-
 extra/smalltalk/compiler/compiler.factor      | 52 ++++++++++++--
 extra/smalltalk/compiler/lexenv/lexenv.factor |  4 +-
 extra/smalltalk/eval/authors.txt              |  1 +
 extra/smalltalk/eval/eval-tests.factor        |  5 ++
 extra/smalltalk/eval/eval.factor              |  8 +++
 extra/smalltalk/library/library.factor        | 13 ++--
 extra/smalltalk/listener/listener.factor      | 14 ++--
 extra/smalltalk/parser/parser-tests.factor    | 68 +++++++++++++++++--
 extra/smalltalk/parser/parser.factor          | 67 ++++++++++--------
 extra/smalltalk/parser/test.st                |  4 +-
 11 files changed, 194 insertions(+), 53 deletions(-)
 create mode 100644 extra/smalltalk/eval/authors.txt
 create mode 100644 extra/smalltalk/eval/eval-tests.factor
 create mode 100644 extra/smalltalk/eval/eval.factor

diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index f426789316..69bfc3dbf6 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/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 ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 9c3638ba6c..4a2417e91d 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/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> '[ _ ] ;
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index b204b057b6..6b6d283761 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/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 ]
diff --git a/extra/smalltalk/eval/authors.txt b/extra/smalltalk/eval/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/eval/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
new file mode 100644
index 0000000000..33f28a2bd8
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor
new file mode 100644
index 0000000000..60f0d9cce2
--- /dev/null
+++ b/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 ) ;
\ No newline at end of file
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
index 1b24db71e8..1a8cb8d177 100644
--- a/extra/smalltalk/library/library.factor
+++ b/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 ;
\ No newline at end of file
+M: object selector-new new ;
+
+SELECTOR: time
+
+M: object selector-time '[ _ call( -- result ) ] time ;
\ No newline at end of file
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
index bef4adc196..e052f0c629 100644
--- a/extra/smalltalk/listener/listener.factor
+++ b/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
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index aa440f581e..1ed6108376 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/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
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index e153e1552d..d6194a9637 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/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
\ No newline at end of file
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
index 7771ee2b9c..493d270f9b 100644
--- a/extra/smalltalk/parser/test.st
+++ b/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

From d0921b1d2d9b7b965c7a47e09e11aed79de1ddd6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 22:30:13 -0500
Subject: [PATCH 06/12] Smalltalk parser work in progress

---
 extra/smalltalk/eval/eval-tests.factor     |  6 ++-
 extra/smalltalk/parser/parser-tests.factor | 10 +++--
 extra/smalltalk/parser/parser.factor       | 46 ++++++++++++----------
 extra/smalltalk/parser/test.st             | 12 +++---
 4 files changed, 41 insertions(+), 33 deletions(-)

diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
index 33f28a2bd8..1dbbd054a8 100644
--- a/extra/smalltalk/eval/eval-tests.factor
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -1,5 +1,7 @@
 IN: smalltalk.eval.tests
-USING: smalltalk.eval tools.test ;
+USING: smalltalk.eval tools.test io.streams.string ;
 
 [ 3 ] [ "1+2" eval-smalltalk ] unit-test
-[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
\ No newline at end of file
+[ "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
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index 1ed6108376..9ba1c38ede 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -228,12 +228,12 @@ test         = <foreign parse-smalltalk LocalVariableDeclarationList>
 [ T{ ast-local-variables f { "i" "j" } } ] [ " |  i j   |" test-LocalVariableDeclarationList ] unit-test
 
 
-EBNF: test-KeywordMessageSend
-test         = <foreign parse-smalltalk KeywordMessageSend>
+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-KeywordMessageSend ] unit-test
+[ "x foo:1 bar:2" test-MessageSend ] unit-test
 
 [
     T{ ast-message-send
@@ -247,7 +247,7 @@ test         = <foreign parse-smalltalk KeywordMessageSend>
         { 10 100 }
     }
 ]
-[ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
+[ "3 factorial + 4 factorial between: 10 and: 100" test-MessageSend ] unit-test
 
 [ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
 
@@ -283,4 +283,6 @@ test         = <foreign parse-smalltalk KeywordMessageSend>
 ]
 [ "class Test1 [|a|]. class Test2 extends Test1 [|b|]" parse-smalltalk ] unit-test
 
+[ ] [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test
+
 [ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index d6194a9637..c80171e025 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -104,7 +104,7 @@ BlockLiteral = "["
                  "|"
                  => [[ args ]]
                 )?:args
-                ExecutableCode:body OptionalWhiteSpace
+                ExecutableCode:body
                 "]" => [[ args >array body ast-block boa ]]
 
 Literal = (ConstantReference
@@ -125,41 +125,38 @@ Operand =       Literal
 UnaryMessage = OptionalWhiteSpace
                UnaryMessageSelector:s !(":")
                => [[ s { } ast-message boa ]]
-UnaryMessageOperand = UnaryMessageSend | Operand
-UnaryMessageSend = UnaryMessageOperand:receiver
-                   UnaryMessage:h
-                   (OptionalWhiteSpace ";" UnaryMessage:m => [[ m ]])*:t
-                   => [[ receiver t h prefix >array <ast-cascade> ]]
 
 BinaryMessage = OptionalWhiteSpace
                 BinaryMessageSelector:selector
                 OptionalWhiteSpace
-                BinaryMessageOperand:rhs
+                (MessageSend | Operand):rhs
                 => [[ selector { rhs } ast-message boa ]]
                                    
-BinaryMessageOperand = BinaryMessageSend | UnaryMessageSend | Operand
-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 } ]]
+KeywordMessageSegment = Keyword:k OptionalWhiteSpace (BinaryMessageSend | UnaryMessageSend | Operand):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
-                     KeywordMessage:m
-                     => [[ receiver m 1array <ast-cascade> ]]
 
 Message = BinaryMessage | UnaryMessage | KeywordMessage
 
-MessageSend = (MessageSend | Operand):lhs
+UnaryMessageSend = (MessageSend | Operand):lhs
               Message:h
               (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
               => [[ lhs t h prefix >array <ast-cascade> ]]
 
+BinaryMessageSend = (MessageSend | Operand):lhs
+              Message:h
+              (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+              => [[ lhs t h prefix >array <ast-cascade> ]]
+
+KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+              KeywordMessage:h
+              (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+              => [[ lhs t h prefix >array <ast-cascade> ]]
+
+MessageSend = BinaryMessageSend | UnaryMessageSend | KeywordMessageSend
+
 Expression = OptionalWhiteSpace
              (MessageSend | Operand):e
              => [[ e ]]
@@ -182,6 +179,7 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
 ExecutableCode = (LocalVariableDeclarationList)?:locals
                  ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h
                  FinalStatement:t (".")? => [[ h t suffix ]])?:body
+                 OptionalWhiteSpace
                  => [[ body locals [ suffix ] when* >array ]]
 
 TopLevelForm = ExecutableCode => [[ ast-sequence boa ]]
@@ -201,7 +199,7 @@ MethodHeader =   KeywordMethodHeader
 MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:header
         OptionalWhiteSpace "["
         ExecutableCode:code
-        OptionalWhiteSpace "]"
+        "]"
         => [[ header first2 code ast-block boa ast-method boa ]]
 
 ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
@@ -209,7 +207,13 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
         ("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
         OptionalWhiteSpace "["
         (OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars
-        (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix ]])?:methods
+        (MethodDeclaration:h
+         (OptionalWhiteSpace
+          "."
+          OptionalWhiteSpace
+          MethodDeclaration:m => [[ m ]])*:t (".")?
+          => [[ t h prefix ]]
+         )?:methods
         OptionalWhiteSpace "]"
         => [[ name superclass "Object" or ivars >array methods >array ast-class boa ]]
 
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
index 493d270f9b..8a1ae12145 100644
--- a/extra/smalltalk/parser/test.st
+++ b/extra/smalltalk/parser/test.st
@@ -30,23 +30,23 @@ class TreeNode extends Object [
         output
             nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
             nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
-    ]
+    ].
 
     method binarytrees [
         self binarytrees: self arg to: self stdout.
         ^''
-    ]
+    ].
 
     method left: leftChild right: rightChild item: anItem [
         left := leftChild.
         right := rightChild.
         item := anItem
-    ]
+    ].
 
     method itemCheck [
         ^left isNil
             ifTrue: [item] ifFalse: [item + (left itemCheck - right itemCheck)]
-    ]
+    ].
 
     method bottomUpTree: anItem depth: anInteger [
         ^(anInteger > 0)
@@ -56,11 +56,11 @@ class TreeNode extends Object [
                     right: (self bottomUpTree: 2*anItem depth: anInteger - 1)
                     item: anItem
             ] ifFalse: [self left: nil right: nil item: anItem]
-    ]
+    ].
 
     method left: leftChild right: rightChild item: anItem [
         ^(super new) left: leftChild right: rightChild item: anItem
     ]
-]
+].
 
 Tests binarytrees

From 087a7acfba477a5a5c9b90d8de3a2ece5aead5d3 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Wed, 1 Apr 2009 17:55:15 +1300
Subject: [PATCH 07/12] Fix peg left recursion handling

---
 basis/peg/peg.factor | 23 ++++++++++++++---------
 1 file changed, 14 insertions(+), 9 deletions(-)

diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor
index ce34beb725..dda36432e7 100644
--- a/basis/peg/peg.factor
+++ b/basis/peg/peg.factor
@@ -155,18 +155,21 @@ TUPLE: peg-head rule-id involved-set eval-set ;
   dup pos>> pos set ans>>
   ; inline
 
-:: (setup-lr) ( r l s -- )
-  s head>> l head>> eq? [
-    l head>> s (>>head)
-    l head>> [ s rule-id>> suffix ] change-involved-set drop
-    r l s next>> (setup-lr)
-  ] unless ;
+:: (setup-lr) ( l s -- )
+  s [ 
+    s left-recursion? [ s throw ] unless
+    s head>> l head>> eq? [
+      l head>> s (>>head)
+      l head>> [ s rule-id>> suffix ] change-involved-set drop
+      l s next>> (setup-lr)
+    ] unless 
+  ] when ;
 
 :: setup-lr ( r l -- )
   l head>> [
     r rule-id V{ } clone V{ } clone peg-head boa l (>>head)
   ] unless
-  r l lrstack get (setup-lr) ;
+  l lrstack get (setup-lr) ;
 
 :: lr-answer ( r p m -- ast )
   [let* |
@@ -216,8 +219,10 @@ TUPLE: peg-head rule-id involved-set eval-set ;
     lrstack get next>> lrstack set
     pos get m (>>pos)
     lr head>> [
-      ans lr (>>seed)
-      r p m lr-answer
+      m ans>> left-recursion? [
+        ans lr (>>seed)
+        r p m lr-answer
+     ] [ ans ] if 
     ] [
       ans m (>>ans)
       ans

From 9f01e819e841056d38ef9618f8a581bb8ddd1047 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:06:57 -0500
Subject: [PATCH 08/12] smalltalk: fix various things in the parser, add
 temporary variable support, clean up compiler

---
 extra/smalltalk/ast/ast.factor                |  26 ++-
 .../smalltalk/compiler/compiler-tests.factor  |   9 +-
 extra/smalltalk/compiler/compiler.factor      | 163 ++++++------------
 extra/smalltalk/eval/eval-tests.factor        |   4 +-
 extra/smalltalk/eval/eval.factor              |   8 +-
 extra/smalltalk/library/library.factor        |  25 ++-
 extra/smalltalk/listener/listener.factor      |   2 +-
 extra/smalltalk/parser/parser-tests.factor    |  35 ++--
 extra/smalltalk/parser/parser.factor          |  36 ++--
 extra/smalltalk/parser/test.st                |   7 +-
 10 files changed, 155 insertions(+), 160 deletions(-)

diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index 69bfc3dbf6..e9759b2197 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/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 ]
diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
index c0b9507dd0..81b38f2c14 100644
--- a/extra/smalltalk/compiler/compiler-tests.factor
+++ b/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
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 4a2417e91d..e61b44ffae 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/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
-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 ;
@@ -108,11 +43,39 @@ 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 ;
+: (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 -- ? )
 
@@ -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 )
-    need-return-continuation? [
-        '[
-            [
-                _ _ 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 -- lambda )
+    lexenv block compile-sequence
+    [ lexenv self>> 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 ] ;
\ No newline at end of file
+    [ nil ] ;
+
+: compile-smalltalk ( statement -- quot )
+    [ [ empty-lexenv ] dip compile-sequence nip 0 ]
+    keep make-return ;
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
index 1dbbd054a8..8a7756054a 100644
--- a/extra/smalltalk/eval/eval-tests.factor
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -4,4 +4,6 @@ USING: smalltalk.eval tools.test io.streams.string ;
 [ 3 ] [ "1+2" eval-smalltalk ] unit-test
 [ "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
\ No newline at end of file
+[ 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
diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor
index 60f0d9cce2..d874000a0f 100644
--- a/extra/smalltalk/eval/eval.factor
+++ b/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 ) ;
\ No newline at end of file
+    call( -- result ) ;
+
+: eval-smalltalk-file ( path -- result )
+    utf8 file-contents eval-smalltalk ;
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
index 1a8cb8d177..28acf98dff 100644
--- a/extra/smalltalk/library/library.factor
+++ b/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
-tools.time locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
+USING: kernel present io math sequences assocs math.ranges
+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:
 
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
index e052f0c629..dc84fd90fb 100644
--- a/extra/smalltalk/listener/listener.factor
+++ b/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 -- )
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index 9ba1c38ede..ff9cbc208b 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/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 { "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 { } { } { } } ] [ "[]" 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
@@ -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" }
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index c80171e025..1958861606 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/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
-              Message:h
+UnaryMessageSend = (UnaryMessageSend | Operand):lhs
+              UnaryMessage:h
               (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
               => [[ lhs t h prefix >array <ast-cascade> ]]
 
-BinaryMessageSend = (MessageSend | Operand):lhs
-              Message:h
+BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+              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
-                 ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h
-                 FinalStatement:t (".")? => [[ h t suffix ]])?:body
-                 OptionalWhiteSpace
-                 => [[ body locals [ suffix ] when* >array ]]
+EndStatement = "."
 
-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 "]"
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
index 8a1ae12145..063f20882a 100644
--- a/extra/smalltalk/parser/test.st
+++ b/extra/smalltalk/parser/test.st
@@ -31,9 +31,9 @@ class TreeNode extends Object [
             nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
             nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
     ].
-
-    method binarytrees [
-        self binarytrees: self arg to: self stdout.
+    
+    method binarytrees: arg [
+        self binarytrees: arg to: self stdout.
         ^''
     ].
 
@@ -63,4 +63,3 @@ class TreeNode extends Object [
     ]
 ].
 
-Tests binarytrees

From 0ff66788503d96999b4b273a5bfe8c5fda8aab5f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:08:49 -0500
Subject: [PATCH 09/12] Load smalltalk.library by default and remove useless
 smalltalk.factor

---
 extra/smalltalk/eval/eval.factor | 3 ++-
 extra/smalltalk/smalltalk.factor | 4 ----
 2 files changed, 2 insertions(+), 5 deletions(-)
 delete mode 100644 extra/smalltalk/smalltalk.factor

diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor
index d874000a0f..56841beafd 100644
--- a/extra/smalltalk/eval/eval.factor
+++ b/extra/smalltalk/eval/eval.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files io.encodings.utf8
-compiler.units smalltalk.parser smalltalk.compiler ;
+compiler.units smalltalk.parser smalltalk.compiler
+smalltalk.library ;
 IN: smalltalk.eval
 
 : eval-smalltalk ( string -- result )
diff --git a/extra/smalltalk/smalltalk.factor b/extra/smalltalk/smalltalk.factor
deleted file mode 100644
index 27cd9912ed..0000000000
--- a/extra/smalltalk/smalltalk.factor
+++ /dev/null
@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: ;
-IN: smalltalk

From 8ab7328899458ad12c391272a7e0018bddbca742 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:09:49 -0500
Subject: [PATCH 10/12] Add new vocabs

---
 .../compiler/assignment/assignment.factor     | 36 +++++++++++++
 .../smalltalk/compiler/assignment/authors.txt |  1 +
 extra/smalltalk/compiler/return/authors.txt   |  1 +
 extra/smalltalk/compiler/return/return.factor | 50 +++++++++++++++++++
 4 files changed, 88 insertions(+)
 create mode 100644 extra/smalltalk/compiler/assignment/assignment.factor
 create mode 100644 extra/smalltalk/compiler/assignment/authors.txt
 create mode 100644 extra/smalltalk/compiler/return/authors.txt
 create mode 100644 extra/smalltalk/compiler/return/return.factor

diff --git a/extra/smalltalk/compiler/assignment/assignment.factor b/extra/smalltalk/compiler/assignment/assignment.factor
new file mode 100644
index 0000000000..3a0a769f86
--- /dev/null
+++ b/extra/smalltalk/compiler/assignment/assignment.factor
@@ -0,0 +1,36 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel sequences sets smalltalk.ast ;
+IN: smalltalk.compiler.assignment
+
+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
+    [ receiver>> 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
+    body>> assigned-locals ;
+
+M: array assigned-locals
+    [ assigned-locals ] map concat ;
+
+M: object assigned-locals drop f ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/assignment/authors.txt b/extra/smalltalk/compiler/assignment/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/assignment/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/return/authors.txt b/extra/smalltalk/compiler/return/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/return/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/return/return.factor b/extra/smalltalk/compiler/return/return.factor
new file mode 100644
index 0000000000..31b4a1511b
--- /dev/null
+++ b/extra/smalltalk/compiler/return/return.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators.short-circuit continuations
+fry generalizations kernel locals.rewrite.closures namespaces
+sequences smalltalk.ast ;
+IN: smalltalk.compiler.return
+
+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?
+    body>> need-return-continuation? ;
+
+M: array need-return-continuation? [ need-return-continuation? ] any? ;
+
+M: object need-return-continuation? drop f ;
+
+: make-return ( quot n block -- quot )
+    need-return-continuation? [
+        '[
+            [
+                _ _ ncurry
+                [ return-continuation set ] prepose callcc1
+            ] with-scope
+        ]
+    ] [ drop ] if
+    rewrite-closures first ;
\ No newline at end of file

From 3885ba02a6cdf78682f06d75d3865e5183084987 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:47:51 -0500
Subject: [PATCH 11/12] Fixing up smalltalk to the point where it can run fib,
 slowly

---
 extra/smalltalk/ast/ast.factor                |  4 +++
 extra/smalltalk/compiler/compiler.factor      | 31 +++++++++++++------
 extra/smalltalk/compiler/lexenv/lexenv.factor |  3 +-
 .../compiler/return/return-tests.factor       |  3 ++
 extra/smalltalk/compiler/return/return.factor | 23 ++++++--------
 extra/smalltalk/eval/eval-tests.factor        |  4 ++-
 extra/smalltalk/eval/fib.st                   | 11 +++++++
 extra/smalltalk/parser/parser-tests.factor    |  5 +--
 extra/smalltalk/parser/parser.factor          |  2 +-
 9 files changed, 57 insertions(+), 29 deletions(-)
 create mode 100644 extra/smalltalk/compiler/return/return-tests.factor
 create mode 100644 extra/smalltalk/eval/fib.st

diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index e9759b2197..fc415aa361 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -45,5 +45,9 @@ M: ast-sequence arguments>> drop { } ;
     [ ast-cascade boa ]
     if ;
 
+! Methods return self by default
+: <ast-method> ( class arguments body -- method )
+    self suffix <ast-block> ast-method boa ;
+
 TUPLE: symbol { name string } ;
 MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index e61b44ffae..0b6f17e3fa 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -21,11 +21,22 @@ 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
-    [ compile-arguments ]
+: compile-ifTrue:ifFalse: ( lexenv ast -- quot )
     [ receiver>> compile-ast ]
-    [ nip selector>> selector>generic ]
-    2tri [ append ] dip suffix ;
+    [ compile-arguments ] 2bi
+    [ if ] 3append ;
+
+M: ast-message-send compile-ast
+    dup selector>> {
+        { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
+        [
+            drop
+            [ compile-arguments ]
+            [ receiver>> compile-ast ]
+            [ nip selector>> selector>generic ]
+            2tri [ append ] dip suffix
+        ]
+    } case ;
 
 M: ast-cascade compile-ast
     [ receiver>> compile-ast ]
@@ -40,8 +51,8 @@ M: ast-cascade 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 ] ] [
@@ -106,7 +117,7 @@ M: ast-block compile-ast
     [ 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 -- )
@@ -115,7 +126,7 @@ M: ast-block compile-ast
     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-ast
     nip
@@ -136,5 +147,5 @@ M: ast-foreign compile-ast
     [ nil ] ;
 
 : compile-smalltalk ( statement -- quot )
-    [ [ empty-lexenv ] dip compile-sequence nip 0 ]
-    keep make-return ;
\ No newline at end of file
+    [ empty-lexenv ] dip [ compile-sequence nip 0 ]
+    2keep make-return ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index 6b6d283761..cd06314fd9 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -10,7 +10,7 @@ IN: smalltalk.compiler.lexenv
 ! self: word or f for top-level forms
 ! class: class word or f for top-level forms
 ! method: generic word or f for top-level forms
-TUPLE: lexenv local-readers local-writers self class method ;
+TUPLE: lexenv local-readers local-writers self return class method ;
 
 : <lexenv> ( -- lexenv ) lexenv new ; inline
 
@@ -21,6 +21,7 @@ CONSTANT: empty-lexenv T{ lexenv }
         [ [ local-readers>> ] bi@ assoc-union >>local-readers ]
         [ [ local-writers>> ] bi@ assoc-union >>local-writers ]
         [ [ self>> ] either? >>self ]
+        [ [ return>> ] either? >>return ]
         [ [ class>> ] either? >>class ]
         [ [ method>> ] either? >>method ]
     } 2cleave ;
diff --git a/extra/smalltalk/compiler/return/return-tests.factor b/extra/smalltalk/compiler/return/return-tests.factor
new file mode 100644
index 0000000000..15a3406ffc
--- /dev/null
+++ b/extra/smalltalk/compiler/return/return-tests.factor
@@ -0,0 +1,3 @@
+USING: smalltalk.parser smalltalk.compiler.return tools.test ;
+
+[ t ] [ "(i <= 1) ifTrue: [^1] ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)]" parse-smalltalk need-return-continuation? ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/return/return.factor b/extra/smalltalk/compiler/return/return.factor
index 31b4a1511b..8c36bdac64 100644
--- a/extra/smalltalk/compiler/return/return.factor
+++ b/extra/smalltalk/compiler/return/return.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators.short-circuit continuations
-fry generalizations kernel locals.rewrite.closures namespaces
-sequences smalltalk.ast ;
+fry generalizations kernel locals locals.types locals.rewrite.closures
+namespaces make sequences smalltalk.ast ;
 IN: smalltalk.compiler.return
 
 SYMBOL: return-continuation
@@ -17,13 +17,13 @@ M: ast-message-send need-return-continuation?
     {
         [ receiver>> need-return-continuation? ]
         [ arguments>> need-return-continuation? ]
-    } 1&& ;
+    } 1|| ;
 
 M: ast-cascade need-return-continuation?
     {
         [ receiver>> need-return-continuation? ]
         [ messages>> need-return-continuation? ]
-    } 1&& ;
+    } 1|| ;
 
 M: ast-message need-return-continuation?
     arguments>> need-return-continuation? ;
@@ -38,13 +38,8 @@ M: array need-return-continuation? [ need-return-continuation? ] any? ;
 
 M: object need-return-continuation? drop f ;
 
-: make-return ( quot n block -- quot )
-    need-return-continuation? [
-        '[
-            [
-                _ _ ncurry
-                [ return-continuation set ] prepose callcc1
-            ] with-scope
-        ]
-    ] [ drop ] if
-    rewrite-closures first ;
\ No newline at end of file
+:: make-return ( quot n lexenv block -- quot )
+    block need-return-continuation? [
+        quot clone [ lexenv return>> <def> '[ _ ] prepend ] change-body
+        n '[ _ _ ncurry callcc1 ]
+    ] [ quot ] if rewrite-closures first ;
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
index 8a7756054a..95366d65b9 100644
--- a/extra/smalltalk/eval/eval-tests.factor
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -1,5 +1,5 @@
 IN: smalltalk.eval.tests
-USING: smalltalk.eval tools.test io.streams.string ;
+USING: smalltalk.eval tools.test io.streams.string kernel ;
 
 [ 3 ] [ "1+2" eval-smalltalk ] unit-test
 [ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
@@ -7,3 +7,5 @@ USING: smalltalk.eval tools.test io.streams.string ;
 [ 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
+[ t ] [ "class Blah [method foo [5]]. Blah new foo" eval-smalltalk tuple? ] unit-test
+[ 196418 ] [ "vocab:smalltalk/eval/fib.st" eval-smalltalk-file ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/eval/fib.st b/extra/smalltalk/eval/fib.st
new file mode 100644
index 0000000000..41ab8f56cc
--- /dev/null
+++ b/extra/smalltalk/eval/fib.st
@@ -0,0 +1,11 @@
+class Fib [
+    |i|
+    method i: newI [i:=newI].
+    method compute [
+        (i <= 1)
+          ifTrue: [^1]
+          ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)]
+    ].
+].
+
+[(Fib new i: 26) compute] time
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index ff9cbc208b..9027290e6a 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -1,5 +1,6 @@
 IN: smalltalk.parser.tests
-USING: smalltalk.parser smalltalk.ast peg.ebnf tools.test accessors
+USING: smalltalk.parser smalltalk.ast
+peg.ebnf tools.test accessors
 io.files io.encodings.ascii kernel ;
 
 EBNF: test-Character
@@ -296,4 +297,4 @@ test         = <foreign parse-smalltalk LocalVariableDeclarationList>
 
 [ ] [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test
 
-[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
+[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index 1958861606..c7cafe94dd 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -200,7 +200,7 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:
         OptionalWhiteSpace "["
         ExecutableCode:code
         "]"
-        => [[ header first2 code <ast-block> ast-method boa ]]
+        => [[ header first2 code <ast-method> ]]
 
 ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
         OptionalWhiteSpace

From 11eff11fb753cc2b97ed73e5e1698bde60efc359 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:53:30 -0500
Subject: [PATCH 12/12] Add silly optimization for 'new'; this will be removed
 when compiler improves

---
 extra/smalltalk/compiler/compiler.factor | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 0b6f17e3fa..2eeee30692 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -21,6 +21,11 @@ M: ast-name compile-ast name>> swap lookup-reader ;
 : compile-arguments ( lexenv ast -- quot )
     arguments>> [ compile-ast ] with map [ ] join ;
 
+: compile-new ( lexenv ast -- quot )
+    [ receiver>> compile-ast ]
+    [ compile-arguments ] 2bi
+    [ new ] 3append ;
+
 : compile-ifTrue:ifFalse: ( lexenv ast -- quot )
     [ receiver>> compile-ast ]
     [ compile-arguments ] 2bi
@@ -29,6 +34,7 @@ M: ast-name compile-ast name>> swap lookup-reader ;
 M: ast-message-send compile-ast
     dup selector>> {
         { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
+        { "new" [ compile-new ] }
         [
             drop
             [ compile-arguments ]