smalltalk: Working on message cascade syntax

db4
Slava Pestov 2009-03-31 21:23:09 -05:00
parent 177c58808e
commit 15cb926afb
11 changed files with 194 additions and 53 deletions

View File

@ -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 ;

View File

@ -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> '[ _ ] ;

View File

@ -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 ]

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -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

View File

@ -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 ) ;

View File

@ -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 ;
M: object selector-new new ;
SELECTOR: time
M: object selector-time '[ _ call( -- result ) ] time ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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