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 = [ T{ ast-local-variables f { "i" "j" } } ] [ " | i j |" test-LocalVariableDeclarationList ] unit-test -EBNF: test-KeywordMessageSend -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-KeywordMessageSend ] unit-test +[ "x foo:1 bar:2" test-MessageSend ] unit-test [ T{ ast-message-send @@ -247,7 +247,7 @@ test = { 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 = ] [ "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 ]] 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 ]] - -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 ]] Message = BinaryMessage | UnaryMessage | KeywordMessage -MessageSend = (MessageSend | Operand):lhs +UnaryMessageSend = (MessageSend | Operand):lhs Message:h (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t => [[ lhs t h prefix >array ]] +BinaryMessageSend = (MessageSend | Operand):lhs + Message:h + (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t + => [[ lhs t h prefix >array ]] + +KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs + KeywordMessage:h + (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t + => [[ lhs t h prefix >array ]] + +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