First checkin of extra/smalltalk
Slava Pestov
parent
e8ec1716e3
commit
00c9cde8e2
|
|
@ -0,0 +1,18 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: strings arrays memoize kernel ;
|
||||||
|
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-name { name string } ;
|
||||||
|
TUPLE: ast-return value ;
|
||||||
|
TUPLE: ast-assignment { name ast-name } value ;
|
||||||
|
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: symbol { name string } ;
|
||||||
|
MEMO: intern ( name -- symbol ) symbol boa ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,45 @@
|
||||||
|
USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
|
||||||
|
stack-checker locals.rewrite.closures kernel accessors
|
||||||
|
compiler.units sequences ;
|
||||||
|
IN: smalltalk.compiler.tests
|
||||||
|
|
||||||
|
[ 2 1 ] [
|
||||||
|
[
|
||||||
|
T{ ast-block f
|
||||||
|
{ "a" "b" }
|
||||||
|
{
|
||||||
|
T{ ast-message-send f
|
||||||
|
T{ ast-name f "a" }
|
||||||
|
"+"
|
||||||
|
{ T{ ast-name f "b" } }
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} compile-method
|
||||||
|
[ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
|
||||||
|
] with-compilation-unit
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ 3 1 ] [
|
||||||
|
[
|
||||||
|
T{ ast-block f
|
||||||
|
{ "a" "b" "c" }
|
||||||
|
{
|
||||||
|
T{ ast-assignment f
|
||||||
|
T{ ast-name f "a" }
|
||||||
|
T{ ast-message-send f
|
||||||
|
T{ ast-name f "a" }
|
||||||
|
"+"
|
||||||
|
{ T{ ast-name f "b" } }
|
||||||
|
}
|
||||||
|
}
|
||||||
|
T{ ast-message-send f
|
||||||
|
T{ ast-name f "b" }
|
||||||
|
"blah:"
|
||||||
|
{ 123.456 }
|
||||||
|
}
|
||||||
|
T{ ast-return f T{ ast-name f "c" } }
|
||||||
|
}
|
||||||
|
} compile-method
|
||||||
|
[ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
|
||||||
|
] with-compilation-unit
|
||||||
|
] unit-test
|
||||||
|
|
@ -0,0 +1,102 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors arrays assocs combinators.short-circuit
|
||||||
|
continuations fry kernel namespaces quotations sequences sets
|
||||||
|
slots locals.types generalizations smalltalk.ast
|
||||||
|
smalltalk.compiler.lexenv smalltalk.selectors ;
|
||||||
|
IN: smalltalk.compiler
|
||||||
|
|
||||||
|
SYMBOL: return-continuation
|
||||||
|
|
||||||
|
GENERIC: need-return-continuation? ( ast -- ? )
|
||||||
|
|
||||||
|
M: ast-return need-return-continuation? drop t ;
|
||||||
|
|
||||||
|
M: ast-block need-return-continuation? body>> [ need-return-continuation? ] any? ;
|
||||||
|
|
||||||
|
M: ast-message-send need-return-continuation?
|
||||||
|
{
|
||||||
|
[ receiver>> need-return-continuation? ]
|
||||||
|
[ arguments>> [ need-return-continuation? ] any? ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
M: ast-assignment need-return-continuation?
|
||||||
|
value>> need-return-continuation? ;
|
||||||
|
|
||||||
|
M: object need-return-continuation? drop f ;
|
||||||
|
|
||||||
|
GENERIC: assigned-locals ( ast -- seq )
|
||||||
|
|
||||||
|
M: ast-return assigned-locals value>> assigned-locals ;
|
||||||
|
|
||||||
|
M: ast-block assigned-locals
|
||||||
|
[ body>> [ assigned-locals ] map concat ] [ arguments>> ] bi diff ;
|
||||||
|
|
||||||
|
M: ast-message-send assigned-locals
|
||||||
|
[ receiver>> assigned-locals ]
|
||||||
|
[ arguments>> [ assigned-locals ] map ] bi append ;
|
||||||
|
|
||||||
|
M: ast-assignment assigned-locals
|
||||||
|
[ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
|
||||||
|
[ value>> assigned-locals ] bi append ;
|
||||||
|
|
||||||
|
M: object assigned-locals drop f ;
|
||||||
|
|
||||||
|
GENERIC: compile-ast ( lexenv ast -- quot )
|
||||||
|
|
||||||
|
M: object compile-ast nip 1quotation ;
|
||||||
|
|
||||||
|
ERROR: unbound-local name ;
|
||||||
|
|
||||||
|
M: ast-name compile-ast
|
||||||
|
name>> swap local-readers>> at 1quotation ;
|
||||||
|
|
||||||
|
M: ast-message-send compile-ast
|
||||||
|
[ receiver>> compile-ast ]
|
||||||
|
[ arguments>> [ compile-ast ] with map concat ]
|
||||||
|
[ nip selector>> selector>generic ]
|
||||||
|
2tri [ append ] dip suffix ;
|
||||||
|
|
||||||
|
M: ast-return compile-ast
|
||||||
|
value>> compile-ast
|
||||||
|
[ return-continuation get continue-with ] append ;
|
||||||
|
|
||||||
|
GENERIC: compile-assignment ( lexenv name -- quot )
|
||||||
|
|
||||||
|
M: ast-name compile-assignment
|
||||||
|
name>> swap local-writers>> at 1quotation ;
|
||||||
|
|
||||||
|
M: ast-assignment compile-ast
|
||||||
|
[ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
|
||||||
|
|
||||||
|
: block-lexenv ( block -- lexenv )
|
||||||
|
[ arguments>> ] [ body>> [ assigned-locals ] map concat unique ] bi
|
||||||
|
'[
|
||||||
|
dup dup _ key?
|
||||||
|
[ <local-reader> ]
|
||||||
|
[ <local> ]
|
||||||
|
if
|
||||||
|
] { } map>assoc
|
||||||
|
dup
|
||||||
|
[ nip local-reader? ] assoc-filter
|
||||||
|
[ <local-writer> ] assoc-map
|
||||||
|
<lexenv> ;
|
||||||
|
|
||||||
|
M: ast-block compile-ast
|
||||||
|
[
|
||||||
|
block-lexenv
|
||||||
|
[ nip local-readers>> values ]
|
||||||
|
[ lexenv-union ] 2bi
|
||||||
|
] [ body>> ] bi
|
||||||
|
[ drop [ nil ] ] [
|
||||||
|
unclip-last
|
||||||
|
[ [ compile-ast [ drop ] append ] with map [ ] join ]
|
||||||
|
[ compile-ast ]
|
||||||
|
bi-curry* bi
|
||||||
|
append
|
||||||
|
] if-empty
|
||||||
|
<lambda> '[ @ ] ;
|
||||||
|
|
||||||
|
: compile-method ( block -- quot )
|
||||||
|
[ [ empty-lexenv ] dip compile-ast ] [ arguments>> length ] [ need-return-continuation? ] tri
|
||||||
|
[ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,14 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: assocs kernel accessors ;
|
||||||
|
IN: smalltalk.compiler.lexenv
|
||||||
|
|
||||||
|
TUPLE: lexenv local-readers local-writers ;
|
||||||
|
|
||||||
|
C: <lexenv> lexenv
|
||||||
|
|
||||||
|
CONSTANT: empty-lexenv T{ lexenv }
|
||||||
|
|
||||||
|
: lexenv-union ( lexenv1 lexenv2 -- lexenv )
|
||||||
|
[ [ local-readers>> ] bi@ assoc-union ]
|
||||||
|
[ [ local-writers>> ] bi@ assoc-union ] 2bi <lexenv> ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,137 @@
|
||||||
|
IN: smalltalk.parser.tests
|
||||||
|
USING: smalltalk.parser smalltalk.ast peg.ebnf tools.test accessors
|
||||||
|
io.files io.encodings.ascii kernel ;
|
||||||
|
|
||||||
|
EBNF: test-Character
|
||||||
|
test = <foreign parse-smalltalk Character>
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
[ CHAR: a ] [ "a" test-Character ] unit-test
|
||||||
|
|
||||||
|
EBNF: test-Comment
|
||||||
|
test = <foreign parse-smalltalk Comment>
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
[ T{ ast-comment f "Hello, this is a comment." } ]
|
||||||
|
[ "\"Hello, this is a comment.\"" test-Comment ]
|
||||||
|
unit-test
|
||||||
|
|
||||||
|
[ T{ ast-comment f "Hello, \"this\" is a comment." } ]
|
||||||
|
[ "\"Hello, \"\"this\"\" is a comment.\"" test-Comment ]
|
||||||
|
unit-test
|
||||||
|
|
||||||
|
EBNF: test-Identifier
|
||||||
|
test = <foreign parse-smalltalk Identifier>
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
[ "OrderedCollection" ] [ "OrderedCollection" test-Identifier ] unit-test
|
||||||
|
|
||||||
|
EBNF: test-Literal
|
||||||
|
test = <foreign parse-smalltalk Literal>
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
[ nil ] [ "nil" test-Literal ] unit-test
|
||||||
|
[ 123 ] [ "123" test-Literal ] unit-test
|
||||||
|
[ HEX: deadbeef ] [ "16rdeadbeef" test-Literal ] unit-test
|
||||||
|
[ -123 ] [ "-123" test-Literal ] unit-test
|
||||||
|
[ 1.2 ] [ "1.2" test-Literal ] unit-test
|
||||||
|
[ -1.24 ] [ "-1.24" test-Literal ] unit-test
|
||||||
|
[ 12.4e7 ] [ "12.4e7" test-Literal ] unit-test
|
||||||
|
[ 12.4e-7 ] [ "12.4e-7" test-Literal ] unit-test
|
||||||
|
[ -12.4e7 ] [ "-12.4e7" test-Literal ] unit-test
|
||||||
|
[ CHAR: x ] [ "$x" test-Literal ] unit-test
|
||||||
|
[ "Hello, world" ] [ "'Hello, world'" test-Literal ] unit-test
|
||||||
|
[ "Hello, 'funny' world" ] [ "'Hello, ''funny'' world'" test-Literal ] unit-test
|
||||||
|
[ T{ symbol f "foo" } ] [ "#foo" test-Literal ] unit-test
|
||||||
|
[ T{ symbol f "+" } ] [ "#+" test-Literal ] unit-test
|
||||||
|
[ T{ symbol f "at:put:" } ] [ "#at:put:" test-Literal ] unit-test
|
||||||
|
[ T{ symbol f "Hello world" } ] [ "#'Hello world'" test-Literal ] unit-test
|
||||||
|
[ B{ 1 2 3 4 } ] [ "#[1 2 3 4]" test-Literal ] unit-test
|
||||||
|
[ { nil t f } ] [ "#(nil true false)" test-Literal ] unit-test
|
||||||
|
[ { nil { t f } } ] [ "#(nil (true false))" test-Literal ] unit-test
|
||||||
|
[ T{ ast-block f { } { } } ] [ "[]" test-Literal ] unit-test
|
||||||
|
[ T{ ast-block f { "x" } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
|
||||||
|
[ T{ ast-block f { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
|
||||||
|
|
||||||
|
EBNF: test-FormalBlockArgumentDeclarationList
|
||||||
|
test = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
[ V{ "x" "y" "elt" } ] [ ":x :y :elt" test-FormalBlockArgumentDeclarationList ] unit-test
|
||||||
|
|
||||||
|
EBNF: test-Operand
|
||||||
|
test = <foreign parse-smalltalk Operand>
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
[ { 123 15.6 { t f } } ] [ "#(123 15.6 (true false))" test-Operand ] unit-test
|
||||||
|
[ T{ ast-name f "x" } ] [ "x" test-Operand ] unit-test
|
||||||
|
|
||||||
|
EBNF: test-Expression
|
||||||
|
test = <foreign parse-smalltalk Expression>
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
[ self ] [ "self" test-Expression ] unit-test
|
||||||
|
[ { 123 15.6 { t f } } ] [ "#(123 15.6 (true false))" test-Expression ] unit-test
|
||||||
|
[ T{ ast-name f "x" } ] [ "x" test-Expression ] unit-test
|
||||||
|
[ T{ ast-message-send f 5 "print" { } } ] [ "5 print" test-Expression ] unit-test
|
||||||
|
[ T{ ast-message-send f T{ ast-message-send f 5 "squared" { } } "print" { } } ] [ "5 squared print" test-Expression ] unit-test
|
||||||
|
[ T{ ast-message-send f 2 "+" { 2 } } ] [ "2+2" test-Expression ] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
T{ ast-message-send f
|
||||||
|
T{ ast-message-send f 3 "factorial" { } }
|
||||||
|
"+"
|
||||||
|
{ T{ ast-message-send f 4 "factorial" { } } }
|
||||||
|
}
|
||||||
|
]
|
||||||
|
[ "3 factorial + 4 factorial" test-Expression ] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
T{ ast-message-send f
|
||||||
|
T{ ast-message-send f
|
||||||
|
T{ ast-message-send f 3 "factorial" { } }
|
||||||
|
"+"
|
||||||
|
{ 4 }
|
||||||
|
}
|
||||||
|
"factorial"
|
||||||
|
{ }
|
||||||
|
}
|
||||||
|
]
|
||||||
|
[ "(3 factorial + 4) factorial" test-Expression ] unit-test
|
||||||
|
EBNF: test-FinalStatement
|
||||||
|
test = <foreign parse-smalltalk FinalStatement>
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
[ T{ ast-return f T{ ast-name f "value" } } ] [ "value" test-FinalStatement ] unit-test
|
||||||
|
[ T{ ast-return f T{ ast-name f "value" } } ] [ "^value" test-FinalStatement ] unit-test
|
||||||
|
[ T{ ast-return f T{ ast-assignment f T{ ast-name f "value" } 5 } } ] [ "value:=5" test-FinalStatement ] unit-test
|
||||||
|
|
||||||
|
EBNF: test-LocalVariableDeclarationList
|
||||||
|
test = <foreign parse-smalltalk LocalVariableDeclarationList>
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
[ T{ ast-local-variables f { "i" "j" } } ] [ " | i j |" test-LocalVariableDeclarationList ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
EBNF: test-KeywordMessageSend
|
||||||
|
test = <foreign parse-smalltalk KeywordMessageSend>
|
||||||
|
;EBNF
|
||||||
|
|
||||||
|
[ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ]
|
||||||
|
[ "x foo:1 bar:2" test-KeywordMessageSend ] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
T{ ast-message-send
|
||||||
|
f
|
||||||
|
T{ ast-message-send f
|
||||||
|
T{ ast-message-send f 3 "factorial" { } }
|
||||||
|
"+"
|
||||||
|
{ T{ ast-message-send f 4 "factorial" { } } }
|
||||||
|
}
|
||||||
|
"between:and:"
|
||||||
|
{ 10 100 }
|
||||||
|
}
|
||||||
|
]
|
||||||
|
[ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
|
||||||
|
|
@ -0,0 +1,203 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings
|
||||||
|
math.parser kernel arrays byte-arrays math assocs ;
|
||||||
|
IN: smalltalk.parser
|
||||||
|
|
||||||
|
! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html
|
||||||
|
|
||||||
|
ERROR: bad-number str ;
|
||||||
|
|
||||||
|
: check-number ( str -- n )
|
||||||
|
>string dup string>number [ ] [ bad-number ] ?if ;
|
||||||
|
|
||||||
|
EBNF: parse-smalltalk
|
||||||
|
|
||||||
|
Character = .
|
||||||
|
WhitespaceCharacter = (" " | "\t" | "\n" | "\r" )
|
||||||
|
DecimalDigit = [0-9]
|
||||||
|
Letter = [A-Za-z]
|
||||||
|
|
||||||
|
CommentCharacter = [^"] | '""' => [[ CHAR: " ]]
|
||||||
|
Comment = '"' (CommentCharacter)*:s '"' => [[ s >string ast-comment boa ]]
|
||||||
|
|
||||||
|
OptionalWhiteSpace = (WhitespaceCharacter | Comment)*
|
||||||
|
Whitespace = (WhitespaceCharacter | Comment)+
|
||||||
|
|
||||||
|
LetterOrDigit = DecimalDigit | Letter
|
||||||
|
Identifier = (Letter | "_"):h (LetterOrDigit | "_")*:t => [[ { h t } flatten >string ]]
|
||||||
|
Reference = Identifier => [[ ast-name boa ]]
|
||||||
|
|
||||||
|
ConstantReference = "nil" => [[ nil ]]
|
||||||
|
| "false" => [[ f ]]
|
||||||
|
| "true" => [[ t ]]
|
||||||
|
PseudoVariableReference = "self" => [[ self ]]
|
||||||
|
| "super" => [[ super ]]
|
||||||
|
ReservedIdentifier = PseudoVariableReference | ConstantReference
|
||||||
|
|
||||||
|
BindableIdentifier = Identifier
|
||||||
|
|
||||||
|
UnaryMessageSelector = Identifier
|
||||||
|
|
||||||
|
Keyword = Identifier:i ":" => [[ i ":" append ]]
|
||||||
|
|
||||||
|
KeywordMessageSelector = Keyword+ => [[ concat ]]
|
||||||
|
BinarySelectorChar = "~" | "!" | "@" | "%" | "&" | "*" | "-" | "+"
|
||||||
|
| "=" | "|" | "\" | "<" | ">" | "," | "?" | "/"
|
||||||
|
BinaryMessageSelector = BinarySelectorChar+ => [[ concat ]]
|
||||||
|
|
||||||
|
OptionalMinus = ("-" => [[ CHAR: - ]])?
|
||||||
|
IntegerLiteral = (OptionalMinus:m UnsignedIntegerLiteral:i) => [[ i m [ neg ] when ]]
|
||||||
|
UnsignedIntegerLiteral = Radix:r "r" BaseNIntegerLiteral:b => [[ b >string r base> ]]
|
||||||
|
| DecimalIntegerLiteral => [[ check-number ]]
|
||||||
|
DecimalIntegerLiteral = DecimalDigit+
|
||||||
|
Radix = DecimalIntegerLiteral => [[ check-number ]]
|
||||||
|
BaseNIntegerLiteral = LetterOrDigit+
|
||||||
|
FloatingPointLiteral = (OptionalMinus
|
||||||
|
DecimalIntegerLiteral
|
||||||
|
("." => [[ CHAR: . ]] DecimalIntegerLiteral Exponent? | Exponent))
|
||||||
|
=> [[ flatten check-number ]]
|
||||||
|
Exponent = "e" => [[ CHAR: e ]] (OptionalMinus DecimalIntegerLiteral)?
|
||||||
|
|
||||||
|
CharacterLiteral = "$" Character:c => [[ c ]]
|
||||||
|
|
||||||
|
StringLiteral = "'" (StringLiteralCharacter | "''" => [[ CHAR: ' ]])*:s "'"
|
||||||
|
=> [[ s >string ]]
|
||||||
|
StringLiteralCharacter = [^']
|
||||||
|
|
||||||
|
SymbolInArrayLiteral = KeywordMessageSelector
|
||||||
|
| UnaryMessageSelector
|
||||||
|
| BinaryMessageSelector
|
||||||
|
SymbolLiteral = "#" (SymbolInArrayLiteral | StringLiteral):s => [[ s intern ]]
|
||||||
|
|
||||||
|
ArrayLiteral = (ObjectArrayLiteral | ByteArrayLiteral)
|
||||||
|
ObjectArrayLiteral = "#" NestedObjectArrayLiteral:elts => [[ elts ]]
|
||||||
|
NestedObjectArrayLiteral = "(" OptionalWhiteSpace
|
||||||
|
(LiteralArrayElement:h
|
||||||
|
(Whitespace LiteralArrayElement:e => [[ e ]])*:t
|
||||||
|
=> [[ t h prefix ]]
|
||||||
|
)?:elts OptionalWhiteSpace ")" => [[ elts >array ]]
|
||||||
|
|
||||||
|
LiteralArrayElement = Literal
|
||||||
|
| NestedObjectArrayLiteral
|
||||||
|
| SymbolInArrayLiteral
|
||||||
|
| ConstantReference
|
||||||
|
|
||||||
|
ByteArrayLiteral = "#[" OptionalWhiteSpace
|
||||||
|
(UnsignedIntegerLiteral:h
|
||||||
|
(Whitespace UnsignedIntegerLiteral:i => [[ i ]])*:t
|
||||||
|
=> [[ t h prefix ]]
|
||||||
|
)?:elts OptionalWhiteSpace "]" => [[ elts >byte-array ]]
|
||||||
|
|
||||||
|
FormalBlockArgumentDeclaration = ":" BindableIdentifier:i => [[ i ]]
|
||||||
|
FormalBlockArgumentDeclarationList =
|
||||||
|
FormalBlockArgumentDeclaration:h
|
||||||
|
(Whitespace FormalBlockArgumentDeclaration:v => [[ v ]])*:t
|
||||||
|
=> [[ t h prefix ]]
|
||||||
|
|
||||||
|
BlockLiteral = "["
|
||||||
|
(OptionalWhiteSpace
|
||||||
|
FormalBlockArgumentDeclarationList:args
|
||||||
|
OptionalWhiteSpace
|
||||||
|
"|"
|
||||||
|
=> [[ args ]]
|
||||||
|
)?:args
|
||||||
|
ExecutableCode:body OptionalWhiteSpace
|
||||||
|
"]" => [[ args >array body ast-block boa ]]
|
||||||
|
|
||||||
|
Literal = (ConstantReference
|
||||||
|
| FloatingPointLiteral
|
||||||
|
| IntegerLiteral
|
||||||
|
| CharacterLiteral
|
||||||
|
| StringLiteral
|
||||||
|
| ArrayLiteral
|
||||||
|
| SymbolLiteral
|
||||||
|
| BlockLiteral)
|
||||||
|
|
||||||
|
NestedExpression = "(" Statement:s OptionalWhiteSpace ")" => [[ s ]]
|
||||||
|
Operand = Literal
|
||||||
|
| PseudoVariableReference
|
||||||
|
| Reference
|
||||||
|
| NestedExpression
|
||||||
|
|
||||||
|
UnaryMessage = UnaryMessageSelector
|
||||||
|
UnaryMessageOperand = UnaryMessageSend | Operand
|
||||||
|
UnaryMessageSend = UnaryMessageOperand:receiver
|
||||||
|
OptionalWhiteSpace UnaryMessageSelector:selector !(":")
|
||||||
|
=> [[ receiver selector { } ast-message-send boa ]]
|
||||||
|
|
||||||
|
BinaryMessage = BinaryMessageSelector OptionalWhiteSpace BinaryMessageOperand
|
||||||
|
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
|
||||||
|
|
||||||
|
KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
|
||||||
|
KeywordMessageSend = BinaryMessageOperand:receiver
|
||||||
|
OptionalWhiteSpace
|
||||||
|
KeywordMessageSegment:h
|
||||||
|
(OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
|
||||||
|
=> [[ receiver t h prefix unzip [ concat ] dip ast-message-send boa ]]
|
||||||
|
|
||||||
|
Expression = KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand
|
||||||
|
|
||||||
|
AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
|
||||||
|
OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
|
||||||
|
AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment boa ]]
|
||||||
|
Statement = AssignmentStatement | Expression
|
||||||
|
|
||||||
|
MethodReturnOperator = OptionalWhiteSpace "^"
|
||||||
|
FinalStatement = (MethodReturnOperator)? Statement:s => [[ s ast-return boa ]]
|
||||||
|
|
||||||
|
LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
|
||||||
|
(BindableIdentifier:h
|
||||||
|
(Whitespace BindableIdentifier:b => [[ b ]])*:t
|
||||||
|
=> [[ t h prefix ]]
|
||||||
|
)?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
|
||||||
|
|
||||||
|
ExecutableCode = (LocalVariableDeclarationList)?
|
||||||
|
((Statement:s OptionalWhiteSpace "." => [[ s ]])*
|
||||||
|
FinalStatement:f (".")? => [[ f ]])?
|
||||||
|
=> [[ sift >array ]]
|
||||||
|
|
||||||
|
UnaryMethodHeader = UnaryMessageSelector:selector
|
||||||
|
=> [[ { selector { } } ]]
|
||||||
|
BinaryMethodHeader = BinaryMessageSelector:selector OptionalWhiteSpace BindableIdentifier:identifier
|
||||||
|
=> [[ { selector { identifier } } ]]
|
||||||
|
KeywordMethodHeaderSegment = Keyword:keyword
|
||||||
|
OptionalWhiteSpace
|
||||||
|
BindableIdentifier:identifier => [[ { keyword identifier } ]]
|
||||||
|
KeywordMethodHeader = KeywordMethodHeaderSegment:h (Whitespace KeywordMethodHeaderSegment:s => [[ s ]])*:t
|
||||||
|
=> [[ t h prefix unzip [ concat ] dip 2array ]]
|
||||||
|
MethodHeader = KeywordMethodHeader
|
||||||
|
| BinaryMethodHeader
|
||||||
|
| UnaryMethodHeader
|
||||||
|
MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:header
|
||||||
|
OptionalWhiteSpace "["
|
||||||
|
ExecutableCode:code
|
||||||
|
OptionalWhiteSpace "]"
|
||||||
|
=> [[ header first2 "self" suffix code ast-block boa ast-method boa ]]
|
||||||
|
|
||||||
|
ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
|
||||||
|
OptionalWhiteSpace
|
||||||
|
("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
|
||||||
|
OptionalWhiteSpace "["
|
||||||
|
(OptionalWhiteSpace LocalVariableDeclarationList)?:ivars
|
||||||
|
(MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix >array ]])?:methods
|
||||||
|
OptionalWhiteSpace "]"
|
||||||
|
=> [[ name superclass "Object" or ivars methods ast-class boa ]]
|
||||||
|
|
||||||
|
End = !(.)
|
||||||
|
|
||||||
|
Program = ClassDeclaration* End
|
||||||
|
;EBNF
|
||||||
|
|
@ -0,0 +1,66 @@
|
||||||
|
class TreeNode extends Object [
|
||||||
|
|left right item|
|
||||||
|
|
||||||
|
method binarytrees: n to: output [
|
||||||
|
| minDepth maxDepth stretchDepth check longLivedTree iterations |
|
||||||
|
minDepth := 4.
|
||||||
|
maxDepth := minDepth + 2 max: n.
|
||||||
|
stretchDepth := maxDepth + 1.
|
||||||
|
|
||||||
|
check := (TreeNode bottomUpTree: 0 depth: stretchDepth) itemCheck.
|
||||||
|
output
|
||||||
|
nextPutAll: 'stretch tree of depth '; print: stretchDepth; tab;
|
||||||
|
nextPutAll: ' check: '; print: check; nl.
|
||||||
|
|
||||||
|
longLivedTree := TreeNode bottomUpTree: 0 depth: maxDepth.
|
||||||
|
minDepth to: maxDepth by: 2 do: [:depth|
|
||||||
|
iterations := 1 bitShift: maxDepth - depth + minDepth.
|
||||||
|
|
||||||
|
check := 0.
|
||||||
|
1 to: iterations do: [:i|
|
||||||
|
check := check + (TreeNode bottomUpTree: i depth: depth) itemCheck.
|
||||||
|
check := check + (TreeNode bottomUpTree: -1*i depth: depth) itemCheck
|
||||||
|
].
|
||||||
|
output
|
||||||
|
print: (2*iterations); tab;
|
||||||
|
nextPutAll: ' trees of depth '; print: depth; tab;
|
||||||
|
nextPutAll: ' check: '; print: check; nl
|
||||||
|
].
|
||||||
|
|
||||||
|
output
|
||||||
|
nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
|
||||||
|
nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
|
||||||
|
]
|
||||||
|
|
||||||
|
binarytrees [
|
||||||
|
self binarytrees: self arg to: self stdout.
|
||||||
|
^''
|
||||||
|
]
|
||||||
|
|
||||||
|
method left: leftChild right: rightChild item: anItem [
|
||||||
|
left := leftChild.
|
||||||
|
right := rightChild.
|
||||||
|
item := anItem
|
||||||
|
]
|
||||||
|
|
||||||
|
method itemCheck [
|
||||||
|
^left isNil
|
||||||
|
ifTrue: [item] ifFalse: [item + (left itemCheck - right itemCheck)]
|
||||||
|
]
|
||||||
|
|
||||||
|
method bottomUpTree: anItem depth: anInteger [
|
||||||
|
^(anInteger > 0)
|
||||||
|
ifTrue: [
|
||||||
|
self
|
||||||
|
left: (self bottomUpTree: 2*anItem - 1 depth: anInteger - 1)
|
||||||
|
right: (self bottomUpTree: 2*anItem depth: anInteger - 1)
|
||||||
|
item: anItem
|
||||||
|
] ifFalse: [self left: nil right: nil item: anItem]
|
||||||
|
]
|
||||||
|
|
||||||
|
method left: leftChild right: rightChild item: anItem [
|
||||||
|
^(super new) left: leftChild right: rightChild item: anItem
|
||||||
|
]
|
||||||
|
]
|
||||||
|
|
||||||
|
Tests binarytrees.
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,26 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: combinators effects generic generic.standard
|
||||||
|
kernel sequences words ;
|
||||||
|
IN: smalltalk.selectors
|
||||||
|
|
||||||
|
SYMBOLS: unary binary keyword ;
|
||||||
|
|
||||||
|
: selector-type ( selector -- type )
|
||||||
|
{
|
||||||
|
{ [ dup [ "+-*/%^&*|@" member? ] all? ] [ binary ] }
|
||||||
|
{ [ CHAR: : over member? ] [ keyword ] }
|
||||||
|
[ unary ]
|
||||||
|
} cond nip ;
|
||||||
|
|
||||||
|
: selector>effect ( selector -- effect )
|
||||||
|
dup selector-type {
|
||||||
|
{ unary [ drop 0 ] }
|
||||||
|
{ binary [ drop 1 ] }
|
||||||
|
{ keyword [ [ CHAR: : = ] count ] }
|
||||||
|
} case "receiver" suffix { "result" } <effect> ;
|
||||||
|
|
||||||
|
: selector>generic ( selector -- generic )
|
||||||
|
[ "selector-" prepend "smalltalk.selectors" create dup ]
|
||||||
|
[ selector>effect ]
|
||||||
|
bi define-simple-generic ;
|
||||||
|
|
@ -0,0 +1,4 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: ;
|
||||||
|
IN: smalltalk
|
||||||
Loading…
Reference in New Issue