diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor new file mode 100644 index 0000000000..83e6d0ae84 --- /dev/null +++ b/extra/smalltalk/ast/ast.factor @@ -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 ; \ No newline at end of file diff --git a/extra/smalltalk/ast/authors.txt b/extra/smalltalk/ast/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/ast/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/authors.txt b/extra/smalltalk/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/compiler/authors.txt b/extra/smalltalk/compiler/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/compiler/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor new file mode 100644 index 0000000000..ee944baf02 --- /dev/null +++ b/extra/smalltalk/compiler/compiler-tests.factor @@ -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 \ No newline at end of file diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor new file mode 100644 index 0000000000..1f3b0f94e5 --- /dev/null +++ b/extra/smalltalk/compiler/compiler.factor @@ -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? + [ ] + [ ] + if + ] { } map>assoc + dup + [ nip local-reader? ] assoc-filter + [ ] assoc-map + ; + +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 + '[ @ ] ; + +: 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 diff --git a/extra/smalltalk/compiler/lexenv/authors.txt b/extra/smalltalk/compiler/lexenv/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/compiler/lexenv/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor new file mode 100644 index 0000000000..2488a54c5f --- /dev/null +++ b/extra/smalltalk/compiler/lexenv/lexenv.factor @@ -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 + +CONSTANT: empty-lexenv T{ lexenv } + +: lexenv-union ( lexenv1 lexenv2 -- lexenv ) + [ [ local-readers>> ] bi@ assoc-union ] + [ [ local-writers>> ] bi@ assoc-union ] 2bi ; diff --git a/extra/smalltalk/parser/authors.txt b/extra/smalltalk/parser/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/parser/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor new file mode 100644 index 0000000000..9a6614aa07 --- /dev/null +++ b/extra/smalltalk/parser/parser-tests.factor @@ -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 = +;EBNF + +[ CHAR: a ] [ "a" test-Character ] unit-test + +EBNF: test-Comment +test = +;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 = +;EBNF + +[ "OrderedCollection" ] [ "OrderedCollection" test-Identifier ] unit-test + +EBNF: test-Literal +test = +;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 = +;EBNF + +[ V{ "x" "y" "elt" } ] [ ":x :y :elt" test-FormalBlockArgumentDeclarationList ] unit-test + +EBNF: test-Operand +test = +;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 = +;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 = +;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 = +;EBNF + +[ T{ ast-local-variables f { "i" "j" } } ] [ " | i j |" test-LocalVariableDeclarationList ] unit-test + + +EBNF: test-KeywordMessageSend +test = +;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 diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor new file mode 100644 index 0000000000..2822165938 --- /dev/null +++ b/extra/smalltalk/parser/parser.factor @@ -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 \ No newline at end of file diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st new file mode 100644 index 0000000000..7771ee2b9c --- /dev/null +++ b/extra/smalltalk/parser/test.st @@ -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. diff --git a/extra/smalltalk/selectors/authors.txt b/extra/smalltalk/selectors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/selectors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/selectors/selectors.factor b/extra/smalltalk/selectors/selectors.factor new file mode 100644 index 0000000000..51b2132dbe --- /dev/null +++ b/extra/smalltalk/selectors/selectors.factor @@ -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" } ; + +: selector>generic ( selector -- generic ) + [ "selector-" prepend "smalltalk.selectors" create dup ] + [ selector>effect ] + bi define-simple-generic ; diff --git a/extra/smalltalk/smalltalk.factor b/extra/smalltalk/smalltalk.factor new file mode 100644 index 0000000000..27cd9912ed --- /dev/null +++ b/extra/smalltalk/smalltalk.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: ; +IN: smalltalk