smalltalk: adding a small library, fix various bugs

extra/smalltalk/compiler/compiler-tests.factor

@@ -3,8 +3,15 @@ stack-checker locals.rewrite.closures kernel accessors
 compiler.units sequences ;
 IN: smalltalk.compiler.tests
 
-[ 2 1 ] [
+: test-compilation ( ast -- quot )
     [
+        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" }
        {
@@ -14,20 +21,17 @@ IN: smalltalk.compiler.tests
               { T{ ast-name f "b" } }
            }
        }
-        } compile-method
+    } test-inference
-        [ . ] [ 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 "asmal" }
                  "+"
                  { T{ ast-name f "b" } }
               }
@@ -39,7 +43,42 @@ IN: smalltalk.compiler.tests
            }
            T{ ast-return f T{ ast-name f "c" } }
        }
-        } compile-method
+    } test-inference
-        [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
+] unit-test
-    ] with-compilation-unit
+
+[ 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

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
+    [ [ 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 ;

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 }
 

extra/smalltalk/library/authors.txt

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

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 ) ;

extra/smalltalk/listener/authors.txt

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

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

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>

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
@@ -201,3 +204,13 @@ End = !(.)
 
 Program = ClassDeclaration* End
 ;EBNF
+
+EBNF: parse-smalltalk-statement
+
+Statement = <foreign parse-smalltalk Statement>
+
+End = !(.)
+
+Program = Statement? => [[ nil or ]] End
+
+;EBNF

extra/smalltalk/printer/authors.txt

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

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 ;

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 ;