diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor index f426789316..69bfc3dbf6 100644 --- a/extra/smalltalk/ast/ast.factor +++ b/extra/smalltalk/ast/ast.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: strings arrays memoize kernel ; +USING: strings arrays memoize kernel sequences accessors ; IN: smalltalk.ast SINGLETONS: nil self super ; @@ -8,6 +8,8 @@ SINGLETONS: nil self super ; TUPLE: ast-comment { string string } ; TUPLE: ast-block { arguments 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 } ; TUPLE: ast-name { name string } ; TUPLE: ast-return value ; TUPLE: ast-assignment { name ast-name } value ; @@ -15,6 +17,13 @@ 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 } ; + +: ( receiver messages -- ast ) + dup length 1 = + [ first [ selector>> ] [ arguments>> ] bi ast-message-send boa ] + [ ast-cascade boa ] + if ; TUPLE: symbol { name string } ; MEMO: intern ( name -- symbol ) symbol boa ; \ No newline at end of file diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor index 9c3638ba6c..4a2417e91d 100644 --- a/extra/smalltalk/compiler/compiler.factor +++ b/extra/smalltalk/compiler/compiler.factor @@ -3,7 +3,7 @@ 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 smalltalk.ast +locals.rewrite.closures generic words combinators smalltalk.ast smalltalk.compiler.lexenv smalltalk.selectors smalltalk.classes ; IN: smalltalk.compiler @@ -22,9 +22,21 @@ M: ast-message-send 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 ; @@ -37,14 +49,25 @@ M: ast-block assigned-locals [ body>> assigned-locals ] [ arguments>> ] bi diff ; M: ast-message-send assigned-locals - [ arguments>> 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 ; @@ -60,16 +83,37 @@ ERROR: unbound-local name ; M: ast-name compile-ast name>> swap lookup-reader ; +: compile-arguments ( lexenv ast -- quot ) + arguments>> [ compile-ast ] with map [ ] join ; + M: ast-message-send compile-ast - [ arguments>> [ compile-ast ] with map [ ] join ] + [ compile-arguments ] [ receiver>> compile-ast ] [ nip selector>> selector>generic ] 2tri [ append ] dip suffix ; +M: ast-cascade compile-ast + [ receiver>> compile-ast ] + [ + messages>> [ + [ compile-arguments \ dip ] + [ selector>> selector>generic ] bi + [ ] 3sequence + ] with map + unclip-last [ [ [ drop ] append ] map ] dip suffix + cleave>quot + ] 2bi append ; + 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 ; + +M: ast-sequence compile-ast + statements>> compile-sequence ; + GENERIC: contains-blocks? ( obj -- ? ) M: ast-block contains-blocks? drop t ; @@ -110,7 +154,7 @@ M: ast-assignment compile-ast [ nip local-readers>> values ] [ lexenv-union ] 2bi ] [ body>> ] bi - [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ; + compile-sequence ; M: ast-block compile-ast compile-block '[ _ ] ; diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor index b204b057b6..6b6d283761 100644 --- a/extra/smalltalk/compiler/lexenv/lexenv.factor +++ b/extra/smalltalk/compiler/lexenv/lexenv.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel accessors quotations slots words sequences namespaces combinators combinators.short-circuit -smalltalk.classes ; +summary smalltalk.classes ; IN: smalltalk.compiler.lexenv ! local-readers: assoc string => word @@ -39,6 +39,8 @@ CONSTANT: empty-lexenv T{ lexenv } ERROR: bad-identifier name ; +M: bad-identifier summary drop "Unknown identifier" ; + : lookup-reader ( name lexenv -- reader-quot ) { [ local-reader ] diff --git a/extra/smalltalk/eval/authors.txt b/extra/smalltalk/eval/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/eval/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor new file mode 100644 index 0000000000..33f28a2bd8 --- /dev/null +++ b/extra/smalltalk/eval/eval-tests.factor @@ -0,0 +1,5 @@ +IN: smalltalk.eval.tests +USING: smalltalk.eval tools.test ; + +[ 3 ] [ "1+2" eval-smalltalk ] unit-test +[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test \ No newline at end of file diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor new file mode 100644 index 0000000000..60f0d9cce2 --- /dev/null +++ b/extra/smalltalk/eval/eval.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: 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 diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor index 1b24db71e8..1a8cb8d177 100644 --- a/extra/smalltalk/library/library.factor +++ b/extra/smalltalk/library/library.factor @@ -1,17 +1,15 @@ ! 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 smalltalk.classes ; +USING: kernel present io math sequences assocs math.ranges fry +tools.time locals smalltalk.selectors smalltalk.ast smalltalk.classes ; 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: * @@ -32,7 +30,6 @@ M: object selector-<= swap <= ; M: object selector->= swap >= ; M: object selector-= swap = ; -! Some keyword selectors SELECTOR: ifTrue: SELECTOR: ifFalse: SELECTOR: ifTrue:ifFalse: @@ -76,4 +73,8 @@ M: object selector-value:value:value:value: call( input input input input -- res SELECTOR: new -M: object selector-new new ; \ No newline at end of file +M: object selector-new new ; + +SELECTOR: time + +M: object selector-time '[ _ call( -- result ) ] time ; \ No newline at end of file diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor index bef4adc196..e052f0c629 100644 --- a/extra/smalltalk/listener/listener.factor +++ b/extra/smalltalk/listener/listener.factor @@ -2,17 +2,17 @@ ! 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 ; +smalltalk.eval smalltalk.printer ; IN: smalltalk.listener -: eval-smalltalk ( string -- ) - [ - parse-smalltalk compile-smalltalk - ] with-compilation-unit call( -- result ) - dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ; +: eval-interactively ( string -- ) + '[ + _ eval-smalltalk + dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if + ] try ; : smalltalk-listener ( -- ) "Smalltalk>" { { background COLOR: light-blue } } format bl flush readln - [ '[ _ eval-smalltalk ] try smalltalk-listener ] when* ; + [ eval-interactively smalltalk-listener ] when* ; MAIN: smalltalk-listener \ No newline at end of file diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor index aa440f581e..1ed6108376 100644 --- a/extra/smalltalk/parser/parser-tests.factor +++ b/extra/smalltalk/parser/parser-tests.factor @@ -164,6 +164,41 @@ test = ] [ "((1 < 10) ifTrue: [ 'HI' ] ifFalse: [ 'BYE' ]) print" test-Expression ] unit-test +[ + T{ ast-cascade + { receiver 12 } + { messages + { + T{ ast-message f "sqrt" } + T{ ast-message f "+" { 2 } } + } + } + } +] +[ "12 sqrt; + 2" test-Expression ] unit-test + +[ + T{ ast-cascade + { receiver T{ ast-message-send f 12 "sqrt" } } + { messages + { + T{ ast-message f "+" { 1 } } + T{ ast-message f "+" { 2 } } + } + } + } +] +[ "12 sqrt + 1; + 2" test-Expression ] unit-test + +[ + T{ ast-message-send f + T{ ast-message-send f 1 "+" { 2 } } + "*" + { 3 } + } +] +[ "1+2*3" test-Expression ] unit-test + [ T{ ast-message-send { receiver @@ -214,15 +249,38 @@ test = ] [ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test -[ { 1 2 } ] [ "1. 2" parse-smalltalk ] unit-test +[ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test [ - T{ ast-class - { name "Test" } - { superclass "Object" } - { ivars { "a" } } + T{ ast-sequence f + { + T{ ast-class + { name "Test" } + { superclass "Object" } + { ivars { "a" } } + } + } } ] [ "class Test [|a|]" parse-smalltalk ] unit-test +[ + T{ ast-sequence f + { + T{ ast-class + { name "Test1" } + { superclass "Object" } + { ivars { "a" } } + } + + T{ ast-class + { name "Test2" } + { superclass "Test1" } + { ivars { "b" } } + } + } + } +] +[ "class Test1 [|a|]. class Test2 extends Test1 [|b|]" 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 e153e1552d..d6194a9637 100644 --- a/extra/smalltalk/parser/parser.factor +++ b/extra/smalltalk/parser/parser.factor @@ -4,6 +4,8 @@ USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings math.parser kernel arrays byte-arrays math assocs accessors ; IN: smalltalk.parser +! :mode=text:noTabs=true: + ! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html ERROR: bad-number str ; @@ -120,43 +122,52 @@ Operand = Literal | Reference | NestedExpression -UnaryMessage = UnaryMessageSelector +UnaryMessage = OptionalWhiteSpace + UnaryMessageSelector:s !(":") + => [[ s { } ast-message boa ]] UnaryMessageOperand = UnaryMessageSend | Operand UnaryMessageSend = UnaryMessageOperand:receiver - OptionalWhiteSpace UnaryMessageSelector:selector !(":") - => [[ receiver selector { } ast-message-send boa ]] + UnaryMessage:h + (OptionalWhiteSpace ";" UnaryMessage:m => [[ m ]])*:t + => [[ receiver t h prefix >array ]] -BinaryMessage = BinaryMessageSelector OptionalWhiteSpace BinaryMessageOperand +BinaryMessage = OptionalWhiteSpace + BinaryMessageSelector:selector + OptionalWhiteSpace + BinaryMessageOperand:rhs + => [[ selector { rhs } ast-message boa ]] + BinaryMessageOperand = BinaryMessageSend | UnaryMessageSend | Operand -BinaryMessageSend-1 = BinaryMessageOperand:lhs - OptionalWhiteSpace - BinaryMessageSelector:selector - OptionalWhiteSpace - UnaryMessageOperand:rhs - => [[ lhs selector { rhs } ast-message-send boa ]] -BinaryMessageSend = (BinaryMessageSend:lhs - OptionalWhiteSpace - BinaryMessageSelector:selector - OptionalWhiteSpace - UnaryMessageOperand:rhs - => [[ lhs selector { rhs } ast-message-send boa ]]) - | BinaryMessageSend-1 +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 } ]] +KeywordMessage = OptionalWhiteSpace + KeywordMessageSegment:h + (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t + => [[ t h prefix unzip [ concat ] dip ast-message boa ]] KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):receiver OptionalWhiteSpace - KeywordMessageSegment:h - (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t - => [[ receiver t h prefix unzip [ concat ] dip ast-message-send boa ]] + KeywordMessage:m + => [[ receiver m 1array ]] + +Message = BinaryMessage | UnaryMessage | KeywordMessage + +MessageSend = (MessageSend | Operand):lhs + Message:h + (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t + => [[ lhs t h prefix >array ]] Expression = OptionalWhiteSpace - (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e + (MessageSend | Operand):e => [[ e ]] AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]] AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment boa ]] -Statement = AssignmentStatement | Expression +Statement = ClassDeclaration | ForeignClassDeclaration | AssignmentStatement | Expression MethodReturnOperator = OptionalWhiteSpace "^" FinalStatement = (MethodReturnOperator Statement:s => [[ s ast-return boa ]]) @@ -168,10 +179,12 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace => [[ t h prefix ]] )?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]] -ExecutableCode = (LocalVariableDeclarationList)? - ((Statement:s OptionalWhiteSpace "." => [[ s ]])* - FinalStatement:f (".")? => [[ f ]])? - => [[ sift >array ]] +ExecutableCode = (LocalVariableDeclarationList)?:locals + ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h + FinalStatement:t (".")? => [[ h t suffix ]])?:body + => [[ body locals [ suffix ] when* >array ]] + +TopLevelForm = ExecutableCode => [[ ast-sequence boa ]] UnaryMethodHeader = UnaryMessageSelector:selector => [[ { selector { } } ]] @@ -206,6 +219,6 @@ ForeignClassDeclaration = OptionalWhiteSpace "foreign" => [[ class name ast-foreign boa ]] End = !(.) -Program = (ClassDeclaration|ForeignClassDeclaration|ExecutableCode) => [[ nil or ]] End +Program = TopLevelForm End ;EBNF \ No newline at end of file diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st index 7771ee2b9c..493d270f9b 100644 --- a/extra/smalltalk/parser/test.st +++ b/extra/smalltalk/parser/test.st @@ -32,7 +32,7 @@ class TreeNode extends Object [ nextPutAll: ' check: '; print: longLivedTree itemCheck; nl ] - binarytrees [ + method binarytrees [ self binarytrees: self arg to: self stdout. ^'' ] @@ -63,4 +63,4 @@ class TreeNode extends Object [ ] ] -Tests binarytrees. +Tests binarytrees