--- /dev/null
+! 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 ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
\ No newline at end of file
--- /dev/null
+! 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 ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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> ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+! 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
\ No newline at end of file
--- /dev/null
+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.
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: smalltalk
projects / factor.git / commitdiff