smalltalk: working on lexical scoping for instance variables and class names

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 ;

extra/smalltalk/classes/authors.txt

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

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

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" } }
               }

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

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

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

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 ;

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 ;
 

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

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