From 15cb926afb6504bb24095f2788df3fdf0d2612ba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 21:23:09 -0500
Subject: [PATCH] smalltalk: Working on message cascade syntax
---
extra/smalltalk/ast/ast.factor | 11 ++-
extra/smalltalk/compiler/compiler.factor | 52 ++++++++++++--
extra/smalltalk/compiler/lexenv/lexenv.factor | 4 +-
extra/smalltalk/eval/authors.txt | 1 +
extra/smalltalk/eval/eval-tests.factor | 5 ++
extra/smalltalk/eval/eval.factor | 8 +++
extra/smalltalk/library/library.factor | 13 ++--
extra/smalltalk/listener/listener.factor | 14 ++--
extra/smalltalk/parser/parser-tests.factor | 68 +++++++++++++++++--
extra/smalltalk/parser/parser.factor | 67 ++++++++++--------
extra/smalltalk/parser/test.st | 4 +-
11 files changed, 194 insertions(+), 53 deletions(-)
create mode 100644 extra/smalltalk/eval/authors.txt
create mode 100644 extra/smalltalk/eval/eval-tests.factor
create mode 100644 extra/smalltalk/eval/eval.factor
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 } ;
+
+: <ast-cascade> ( 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 <lambda> '[ _ ] ;
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 = <foreign parse-smalltalk Expression>
]
[ "((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 = <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-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 <ast-cascade> ]]
-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 <ast-cascade> ]]
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 <ast-cascade> ]]
+
+Message = BinaryMessage | UnaryMessage | KeywordMessage
+
+MessageSend = (MessageSend | Operand):lhs
+ Message:h
+ (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+ => [[ lhs t h prefix >array <ast-cascade> ]]
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