! 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 ;
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 ;
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
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
[ 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 ;
[ 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 ;
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 ;
[ 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> '[ _ ] ;
! 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
ERROR: bad-identifier name ;
+M: bad-identifier summary drop "Unknown identifier" ;
+
: lookup-reader ( name lexenv -- reader-quot )
{
[ local-reader ]
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+! 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
! 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: *
M: object selector->= swap >= ;
M: object selector-= swap = ;
-! Some keyword selectors
SELECTOR: ifTrue:
SELECTOR: ifFalse:
SELECTOR: ifTrue:ifFalse:
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
! 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
]
[ "((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
]
[ "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
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 ;
| 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 ]]
-
-BinaryMessage = BinaryMessageSelector OptionalWhiteSpace BinaryMessageOperand
+ UnaryMessage:h
+ (OptionalWhiteSpace ";" UnaryMessage:m => [[ m ]])*:t
+ => [[ receiver t h prefix >array <ast-cascade> ]]
+
+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 ]])
=> [[ 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 { } } ]]
=> [[ class name ast-foreign boa ]]
End = !(.)
-Program = (ClassDeclaration|ForeignClassDeclaration|ExecutableCode) => [[ nil or ]] End
+Program = TopLevelForm End
;EBNF
\ No newline at end of file
nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
]
- binarytrees [
+ method binarytrees [
self binarytrees: self arg to: self stdout.
^''
]
]
]
-Tests binarytrees.
+Tests binarytrees
projects / factor.git / commitdiff