smalltalk: Working on message cascade syntax
parent
177c58808e
commit
15cb926afb
|
@ -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 ;
|
|
@ -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> '[ _ ] ;
|
||||
|
|
|
@ -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 ]
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -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
|
|
@ -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 ) ;
|
|
@ -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 ;
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue