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 ; + +: ( arguments body -- block ) + unclip-temporaries ast-block boa ; + +: ( 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 : ( 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? + [ ] + [ ] + if + ] H{ } map>assoc + dup + [ nip local-reader? ] assoc-filter + [ ] assoc-map + 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 + [ [ 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? - [ ] - [ ] - if - ] { } map>assoc - dup - [ nip local-reader? ] assoc-filter - [ ] assoc-map - 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 '[ _ ] ; + compile-sequence '[ _ ] ; -: 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 -- lambda ) + lexenv block compile-sequence + [ lexenv self>> suffix ] dip ; : 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 ) swap >>class "self" >>self ; -M: ast-class compile-smalltalk ( ast-class -- quot ) +M: ast-class compile-ast + nip [ [ name>> ] [ superclass>> ] [ ivars>> ] tri define-class @@ -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 = [ 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 = ] [ "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 = [ T{ ast-local-variables f { "i" "j" } } ] [ " | i j |" test-LocalVariableDeclarationList ] unit-test -EBNF: test-MessageSend -test = -;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 = { 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 = [ "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 ]] 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 ]] -BinaryMessageSend = (MessageSend | Operand):lhs - Message:h +BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs + BinaryMessage:h (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t => [[ lhs t h prefix >array ]] @@ -155,10 +155,8 @@ KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t => [[ lhs t h prefix >array ]] -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 => [[ ]] 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-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