From 5b6948aaa5b4c652f0833fbbe74cb8a08d039515 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 01:24:38 -0500 Subject: [PATCH] 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 [ ] assoc-map - ; + 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 - '[ _ ] ; + [ 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 '[ _ ] ; -: 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 ; + +: 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 ) + swap >>class "self" >>self ; + +M: ast-class compile-smalltalk ( ast-class -- quot ) + [ + [ name>> ] [ superclass>> ] [ ivars>> ] tri + define-class + ] + [ 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 + + + 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 ; -: ( local-readers local-writers -- lexenv ) - f f f lexenv boa ; inline +: ( -- 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 ; + [ ] 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 = ] [ "[ :i | i print ]" test-Literal ] unit-test +[ + T{ ast-block + { body { 5 self } } + } +] +[ "[5. self]" test-Literal ] unit-test + EBNF: test-FormalBlockArgumentDeclarationList test = ;EBNF @@ -207,4 +214,15 @@ test = ] [ "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 = - -End = !(.) - -Program = Statement? => [[ nil or ]] End +Program = (ClassDeclaration|ForeignClassDeclaration|ExecutableCode) => [[ nil or ]] End ;EBNF \ No newline at end of file