From 00c9cde8e2edaf806d31b7ef676e16219f53b06a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 30 Mar 2009 05:31:50 -0500 Subject: [PATCH 01/20] First checkin of extra/smalltalk --- extra/smalltalk/ast/ast.factor | 18 ++ extra/smalltalk/ast/authors.txt | 1 + extra/smalltalk/authors.txt | 1 + extra/smalltalk/compiler/authors.txt | 1 + .../smalltalk/compiler/compiler-tests.factor | 45 ++++ extra/smalltalk/compiler/compiler.factor | 102 +++++++++ extra/smalltalk/compiler/lexenv/authors.txt | 1 + extra/smalltalk/compiler/lexenv/lexenv.factor | 14 ++ extra/smalltalk/parser/authors.txt | 1 + extra/smalltalk/parser/parser-tests.factor | 137 ++++++++++++ extra/smalltalk/parser/parser.factor | 203 ++++++++++++++++++ extra/smalltalk/parser/test.st | 66 ++++++ extra/smalltalk/selectors/authors.txt | 1 + extra/smalltalk/selectors/selectors.factor | 26 +++ extra/smalltalk/smalltalk.factor | 4 + 15 files changed, 621 insertions(+) create mode 100644 extra/smalltalk/ast/ast.factor create mode 100644 extra/smalltalk/ast/authors.txt create mode 100644 extra/smalltalk/authors.txt create mode 100644 extra/smalltalk/compiler/authors.txt create mode 100644 extra/smalltalk/compiler/compiler-tests.factor create mode 100644 extra/smalltalk/compiler/compiler.factor create mode 100644 extra/smalltalk/compiler/lexenv/authors.txt create mode 100644 extra/smalltalk/compiler/lexenv/lexenv.factor create mode 100644 extra/smalltalk/parser/authors.txt create mode 100644 extra/smalltalk/parser/parser-tests.factor create mode 100644 extra/smalltalk/parser/parser.factor create mode 100644 extra/smalltalk/parser/test.st create mode 100644 extra/smalltalk/selectors/authors.txt create mode 100644 extra/smalltalk/selectors/selectors.factor create mode 100644 extra/smalltalk/smalltalk.factor 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 From 381dbb957c44f8f17cd975329b1ca6f0277cc5dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 30 Mar 2009 20:45:01 -0500 Subject: [PATCH 02/20] smalltalk: adding a small library, fix various bugs --- .../smalltalk/compiler/compiler-tests.factor | 105 ++++++++++++------ extra/smalltalk/compiler/compiler.factor | 47 ++++++-- extra/smalltalk/compiler/lexenv/lexenv.factor | 10 +- extra/smalltalk/library/authors.txt | 1 + extra/smalltalk/library/library.factor | 75 +++++++++++++ extra/smalltalk/listener/authors.txt | 1 + extra/smalltalk/listener/listener.factor | 18 +++ extra/smalltalk/parser/parser-tests.factor | 77 ++++++++++++- extra/smalltalk/parser/parser.factor | 19 +++- extra/smalltalk/printer/authors.txt | 1 + extra/smalltalk/printer/printer.factor | 34 ++++++ extra/smalltalk/selectors/selectors.factor | 6 +- 12 files changed, 343 insertions(+), 51 deletions(-) create mode 100644 extra/smalltalk/library/authors.txt create mode 100644 extra/smalltalk/library/library.factor create mode 100644 extra/smalltalk/listener/authors.txt create mode 100644 extra/smalltalk/listener/listener.factor create mode 100644 extra/smalltalk/printer/authors.txt create mode 100644 extra/smalltalk/printer/printer.factor diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor index ee944baf02..a8e918fcf4 100644 --- a/extra/smalltalk/compiler/compiler-tests.factor +++ b/extra/smalltalk/compiler/compiler-tests.factor @@ -3,43 +3,82 @@ stack-checker locals.rewrite.closures kernel accessors compiler.units sequences ; IN: smalltalk.compiler.tests -[ 2 1 ] [ +: test-compilation ( ast -- quot ) [ - 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 + ] with-compilation-unit ; + +: test-inference ( ast -- in# out# ) + test-compilation infer [ in>> ] [ out>> ] bi ; + +[ 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 + } + } test-inference ] 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" } } + 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 "asmal" } + "+" + { T{ ast-name f "b" } } + } } - } compile-method - [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi - ] with-compilation-unit + T{ ast-message-send f + T{ ast-name f "b" } + "blah:" + { 123.456 } + } + T{ ast-return f T{ ast-name f "c" } } + } + } test-inference +] unit-test + +[ 0 1 ] [ + T{ ast-block f + { } + { + T{ ast-message-send + { receiver 1 } + { selector "to:do:" } + { arguments + { + 10 + T{ ast-block + { arguments { "i" } } + { body + { + T{ ast-message-send + { receiver + T{ ast-name { name "i" } } + } + { selector "print" } + } + } + } + } + } + } + } + } + } test-inference +] unit-test + +[ "a" ] [ + T{ ast-block f + { } + { { T{ ast-block { body { "a" } } } } } + } test-compilation call first call ] unit-test \ No newline at end of file diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor index 1f3b0f94e5..b72b218f82 100644 --- a/extra/smalltalk/compiler/compiler.factor +++ b/extra/smalltalk/compiler/compiler.factor @@ -2,7 +2,7 @@ ! 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 +generalizations slots locals.types generalizations smalltalk.ast smalltalk.compiler.lexenv smalltalk.selectors ; IN: smalltalk.compiler @@ -12,17 +12,19 @@ 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-block need-return-continuation? body>> need-return-continuation? ; M: ast-message-send need-return-continuation? { [ receiver>> need-return-continuation? ] - [ arguments>> [ need-return-continuation? ] any? ] + [ arguments>> need-return-continuation? ] } 1&& ; M: ast-assignment need-return-continuation? value>> need-return-continuation? ; +M: array need-return-continuation? [ need-return-continuation? ] any? ; + M: object need-return-continuation? drop f ; GENERIC: assigned-locals ( ast -- seq ) @@ -30,16 +32,20 @@ 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 ; + [ body>> assigned-locals ] [ arguments>> ] bi diff ; M: ast-message-send assigned-locals + [ arguments>> assigned-locals ] [ receiver>> assigned-locals ] - [ arguments>> [ assigned-locals ] map ] bi append ; + bi append ; M: ast-assignment assigned-locals [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ] [ value>> assigned-locals ] bi append ; +M: array assigned-locals + [ assigned-locals ] map concat ; + M: object assigned-locals drop f ; GENERIC: compile-ast ( lexenv ast -- quot ) @@ -52,8 +58,8 @@ M: ast-name compile-ast name>> swap local-readers>> at 1quotation ; M: ast-message-send compile-ast + [ arguments>> [ compile-ast ] with map [ ] join ] [ receiver>> compile-ast ] - [ arguments>> [ compile-ast ] with map concat ] [ nip selector>> selector>generic ] 2tri [ append ] dip suffix ; @@ -61,6 +67,22 @@ M: ast-return compile-ast value>> compile-ast [ return-continuation get continue-with ] append ; +GENERIC: contains-blocks? ( obj -- ? ) + +M: ast-block contains-blocks? drop t ; + +M: object contains-blocks? drop f ; + +M: array contains-blocks? [ contains-blocks? ] any? ; + +M: array compile-ast + dup contains-blocks? [ + [ [ compile-ast ] with map [ ] join ] [ length ] bi + '[ @ _ narray ] + ] [ + call-next-method + ] if ; + GENERIC: compile-assignment ( lexenv name -- quot ) M: ast-name compile-assignment @@ -95,8 +117,15 @@ M: ast-block 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 + [ [ empty-lexenv ] dip compile-ast [ call ] compose ] + [ arguments>> length ] + [ need-return-continuation? ] + tri + [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ; + +: compile-statement ( statement -- quot ) + [ [ empty-lexenv ] dip compile-ast ] [ need-return-continuation? ] bi + [ '[ [ [ return-continuation set @ ] callcc1 ] with-scope ] ] when ; diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor index 2488a54c5f..2097dc8a50 100644 --- a/extra/smalltalk/compiler/lexenv/lexenv.factor +++ b/extra/smalltalk/compiler/lexenv/lexenv.factor @@ -3,9 +3,15 @@ USING: assocs kernel accessors ; IN: smalltalk.compiler.lexenv -TUPLE: lexenv local-readers local-writers ; +! local-readers: assoc string => word +! local-writers: assoc string => word +! self: word or f for top-level forms +! class: class word or f for top-level forms +! method: generic word or f for top-level forms +TUPLE: lexenv local-readers local-writers self class method ; -C: lexenv +: ( local-readers local-writers -- lexenv ) + f f f lexenv boa ; inline CONSTANT: empty-lexenv T{ lexenv } diff --git a/extra/smalltalk/library/authors.txt b/extra/smalltalk/library/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/library/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor new file mode 100644 index 0000000000..bf455c2c4a --- /dev/null +++ b/extra/smalltalk/library/library.factor @@ -0,0 +1,75 @@ +! 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 ; +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: * +SELECTOR: / +SELECTOR: < +SELECTOR: > +SELECTOR: <= +SELECTOR: >= +SELECTOR: = + +M: object selector-+ swap + ; +M: object selector-- swap - ; +M: object selector-* swap * ; +M: object selector-/ swap / ; +M: object selector-< swap < ; +M: object selector-> swap > ; +M: object selector-<= swap <= ; +M: object selector->= swap >= ; +M: object selector-= swap = ; + +! Some keyword selectors +SELECTOR: ifTrue: +SELECTOR: ifFalse: +SELECTOR: ifTrue:ifFalse: + +M: object selector-ifTrue: [ call( -- result ) ] [ drop nil ] if ; +M: object selector-ifFalse: [ drop nil ] [ call( -- result ) ] if ; +M: object selector-ifTrue:ifFalse: [ drop call( -- result ) ] [ nip call( -- result ) ] if ; + +SELECTOR: at: +SELECTOR: at:put: + +M: sequence selector-at: nth ; +M: sequence selector-at:put: ( key value receiver -- receiver ) [ swapd set-nth ] keep ; + +M: assoc selector-at: at ; +M: assoc selector-at:put: ( key value receiver -- receiver ) [ swapd set-at ] keep ; + +SELECTOR: do: + +M:: object selector-do: ( quot receiver -- nil ) + receiver [ quot call( elt -- result ) drop ] each nil ; + +SELECTOR: to: +SELECTOR: to:do: + +M: object selector-to: swap [a,b] ; +M:: object selector-to:do: ( to quot from -- nil ) + from to [a,b] [ quot call( i -- result ) drop ] each nil ; + +SELECTOR: value +SELECTOR: value: +SELECTOR: value:value: +SELECTOR: value:value:value: +SELECTOR: value:value:value:value: + +M: object selector-value call( -- result ) ; +M: object selector-value: call( input -- result ) ; +M: object selector-value:value: call( input input -- result ) ; +M: object selector-value:value:value: call( input input input -- result ) ; +M: object selector-value:value:value:value: call( input input input input -- result ) ; diff --git a/extra/smalltalk/listener/authors.txt b/extra/smalltalk/listener/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/listener/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor new file mode 100644 index 0000000000..e1bb6aca5e --- /dev/null +++ b/extra/smalltalk/listener/listener.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Slava Pestov. +! 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 ; +IN: smalltalk.listener + +: eval-smalltalk ( string -- ) + [ + parse-smalltalk-statement compile-statement rewrite-closures first + ] with-compilation-unit call( -- result ) + dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ; + +: smalltalk-listener ( -- ) + "Smalltalk>" { { background COLOR: light-blue } } format bl flush readln + [ '[ _ eval-smalltalk ] try smalltalk-listener ] when* ; + +MAIN: smalltalk-listener \ No newline at end of file diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor index 9a6614aa07..fa0fde51d6 100644 --- a/extra/smalltalk/parser/parser-tests.factor +++ b/extra/smalltalk/parser/parser-tests.factor @@ -53,6 +53,21 @@ 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 +[ + T{ ast-block + { arguments { "i" } } + { body + { + T{ ast-message-send + { receiver T{ ast-name { name "i" } } } + { selector "print" } + } + } + } + } +] +[ "[ :i | i print ]" test-Literal ] unit-test + EBNF: test-FormalBlockArgumentDeclarationList test = ;EBNF @@ -86,6 +101,24 @@ test = ] [ "3 factorial + 4 factorial" 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 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 @@ -98,13 +131,53 @@ test = } ] [ "(3 factorial + 4) factorial" test-Expression ] unit-test + +[ + T{ ast-message-send + { receiver + T{ ast-message-send + { receiver + T{ ast-message-send + { receiver 1 } + { selector "<" } + { arguments { 10 } } + } + } + { selector "ifTrue:ifFalse:" } + { arguments + { + T{ ast-block { body { "HI" } } } + T{ ast-block { body { "BYE" } } } + } + } + } + } + { selector "print" } + } +] +[ "((1 < 10) ifTrue: [ 'HI' ] ifFalse: [ 'BYE' ]) print" test-Expression ] unit-test + +[ + T{ ast-message-send + { receiver + T{ ast-message-send + { receiver { T{ ast-block { body { "a" } } } } } + { selector "at:" } + { arguments { 0 } } + } + } + { selector "value" } + } +] +[ "(#(['a']) at: 0) value" 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-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 +[ T{ ast-assignment f T{ ast-name f "value" } 5 } ] [ "value:=5" test-FinalStatement ] unit-test EBNF: test-LocalVariableDeclarationList test = diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor index 2822165938..e2fea234c8 100644 --- a/extra/smalltalk/parser/parser.factor +++ b/extra/smalltalk/parser/parser.factor @@ -143,13 +143,15 @@ BinaryMessageSend = (BinaryMessageSend:lhs | BinaryMessageSend-1 KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]] -KeywordMessageSend = BinaryMessageOperand:receiver +KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):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 +Expression = OptionalWhiteSpace + (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e + => [[ e ]] AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]] @@ -157,7 +159,8 @@ AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment Statement = AssignmentStatement | Expression MethodReturnOperator = OptionalWhiteSpace "^" -FinalStatement = (MethodReturnOperator)? Statement:s => [[ s ast-return boa ]] +FinalStatement = (MethodReturnOperator Statement:s => [[ s ast-return boa ]]) + | Statement LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace (BindableIdentifier:h @@ -200,4 +203,14 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name End = !(.) Program = ClassDeclaration* End +;EBNF + +EBNF: parse-smalltalk-statement + +Statement = + +End = !(.) + +Program = Statement? => [[ nil or ]] End + ;EBNF \ No newline at end of file diff --git a/extra/smalltalk/printer/authors.txt b/extra/smalltalk/printer/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/printer/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/printer/printer.factor b/extra/smalltalk/printer/printer.factor new file mode 100644 index 0000000000..70055e8e77 --- /dev/null +++ b/extra/smalltalk/printer/printer.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays byte-arrays kernel make math +math.parser prettyprint sequences smalltalk.ast strings ; +IN: smalltalk.printer + +GENERIC: smalltalk>string ( object -- string ) + +M: real smalltalk>string number>string ; + +M: string smalltalk>string + [ + "'" % + [ dup CHAR: ' = [ dup , , ] [ , ] if ] each + "'" % + ] "" make ; + +GENERIC: array-element>string ( object -- string ) + +M: object array-element>string smalltalk>string ; + +M: array array-element>string + [ smalltalk>string ] map " " join "(" ")" surround ; + +M: array smalltalk>string + array-element>string "#" prepend ; + +M: byte-array smalltalk>string + [ number>string ] { } map-as " " join "#[" "]" surround ; + +M: symbol smalltalk>string + name>> smalltalk>string "#" prepend ; + +M: object smalltalk>string unparse-short ; \ No newline at end of file diff --git a/extra/smalltalk/selectors/selectors.factor b/extra/smalltalk/selectors/selectors.factor index 51b2132dbe..2ea1e99afd 100644 --- a/extra/smalltalk/selectors/selectors.factor +++ b/extra/smalltalk/selectors/selectors.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: combinators effects generic generic.standard -kernel sequences words ; +kernel sequences words lexer ; IN: smalltalk.selectors SYMBOLS: unary binary keyword ; : selector-type ( selector -- type ) { - { [ dup [ "+-*/%^&*|@" member? ] all? ] [ binary ] } + { [ dup [ "~!@%&*-+=|\\<>,?/" member? ] all? ] [ binary ] } { [ CHAR: : over member? ] [ keyword ] } [ unary ] } cond nip ; @@ -24,3 +24,5 @@ SYMBOLS: unary binary keyword ; [ "selector-" prepend "smalltalk.selectors" create dup ] [ selector>effect ] bi define-simple-generic ; + +SYNTAX: SELECTOR: scan selector>generic drop ; \ No newline at end of file From 5b6948aaa5b4c652f0833fbbe74cb8a08d039515 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 01:24:38 -0500 Subject: [PATCH 03/20] smalltalk: working on lexical scoping for instance variables and class names --- extra/smalltalk/ast/ast.factor | 2 + extra/smalltalk/classes/authors.txt | 1 + extra/smalltalk/classes/classes.factor | 25 ++++++ .../smalltalk/compiler/compiler-tests.factor | 10 +-- extra/smalltalk/compiler/compiler.factor | 88 +++++++++++++------ .../compiler/lexenv/lexenv-tests.factor | 24 +++++ extra/smalltalk/compiler/lexenv/lexenv.factor | 54 ++++++++++-- extra/smalltalk/library/library.factor | 6 +- extra/smalltalk/listener/listener.factor | 2 +- extra/smalltalk/parser/parser-tests.factor | 18 ++++ extra/smalltalk/parser/parser.factor | 25 +++--- 11 files changed, 199 insertions(+), 56 deletions(-) create mode 100644 extra/smalltalk/classes/authors.txt create mode 100644 extra/smalltalk/classes/classes.factor create mode 100644 extra/smalltalk/compiler/lexenv/lexenv-tests.factor diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor index 83e6d0ae84..f426789316 100644 --- a/extra/smalltalk/ast/ast.factor +++ b/extra/smalltalk/ast/ast.factor @@ -14,5 +14,7 @@ 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: ast-foreign { class string } { name string } ; + TUPLE: symbol { name string } ; MEMO: intern ( name -- symbol ) symbol boa ; \ No newline at end of file diff --git a/extra/smalltalk/classes/authors.txt b/extra/smalltalk/classes/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/classes/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/classes/classes.factor b/extra/smalltalk/classes/classes.factor new file mode 100644 index 0000000000..1798aad961 --- /dev/null +++ b/extra/smalltalk/classes/classes.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces assocs accessors words sequences classes.tuple ; +IN: smalltalk.classes + +SYMBOL: classes + +classes [ H{ } clone ] initialize + +: create-class ( class -- class ) + "smalltalk.classes" create ; + +ERROR: no-class name ; + +: lookup-class ( class -- class ) + classes get ?at [ ] [ no-class ] if ; + +: define-class ( class superclass ivars -- class-word ) + [ create-class ] [ lookup-class ] [ ] tri* + [ define-tuple-class ] [ 2drop dup dup name>> classes get set-at ] 3bi ; + +: define-foreign ( class name -- ) + classes get set-at ; + +tuple "Object" define-foreign \ No newline at end of file diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor index a8e918fcf4..c0b9507dd0 100644 --- a/extra/smalltalk/compiler/compiler-tests.factor +++ b/extra/smalltalk/compiler/compiler-tests.factor @@ -1,12 +1,10 @@ USING: smalltalk.compiler tools.test prettyprint smalltalk.ast -stack-checker locals.rewrite.closures kernel accessors -compiler.units sequences ; +smalltalk.compiler.lexenv stack-checker locals.rewrite.closures +kernel accessors compiler.units sequences ; IN: smalltalk.compiler.tests : test-compilation ( ast -- quot ) - [ - compile-method rewrite-closures first - ] with-compilation-unit ; + [ compile-smalltalk [ call ] append ] with-compilation-unit ; : test-inference ( ast -- in# out# ) test-compilation infer [ in>> ] [ out>> ] bi ; @@ -31,7 +29,7 @@ IN: smalltalk.compiler.tests T{ ast-assignment f T{ ast-name f "a" } T{ ast-message-send f - T{ ast-name f "asmal" } + T{ ast-name f "c" } "+" { T{ ast-name f "b" } } } diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor index b72b218f82..9c3638ba6c 100644 --- a/extra/smalltalk/compiler/compiler.factor +++ b/extra/smalltalk/compiler/compiler.factor @@ -2,8 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators.short-circuit continuations fry kernel namespaces quotations sequences sets -generalizations slots locals.types generalizations smalltalk.ast -smalltalk.compiler.lexenv smalltalk.selectors ; +generalizations slots locals.types generalizations splitting math +locals.rewrite.closures generic words smalltalk.ast +smalltalk.compiler.lexenv smalltalk.selectors +smalltalk.classes ; IN: smalltalk.compiler SYMBOL: return-continuation @@ -52,10 +54,11 @@ GENERIC: compile-ast ( lexenv ast -- quot ) M: object compile-ast nip 1quotation ; +M: self compile-ast drop self>> 1quotation ; + ERROR: unbound-local name ; -M: ast-name compile-ast - name>> swap local-readers>> at 1quotation ; +M: ast-name compile-ast name>> swap lookup-reader ; M: ast-message-send compile-ast [ arguments>> [ compile-ast ] with map [ ] join ] @@ -79,14 +82,11 @@ M: array compile-ast dup contains-blocks? [ [ [ compile-ast ] with map [ ] join ] [ length ] bi '[ @ _ narray ] - ] [ - call-next-method - ] if ; + ] [ call-next-method ] if ; GENERIC: compile-assignment ( lexenv name -- quot ) -M: ast-name compile-assignment - name>> swap local-writers>> at 1quotation ; +M: ast-name compile-assignment name>> swap lookup-writer ; M: ast-assignment compile-ast [ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ; @@ -102,30 +102,62 @@ M: ast-assignment compile-ast dup [ nip local-reader? ] assoc-filter [ ] assoc-map - ; + swap >>local-writers swap >>local-readers ; -M: ast-block compile-ast +: compile-block ( lexenv block -- vars body ) [ 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 - '[ _ ] ; + [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ; -: compile-method ( block -- quot ) - [ [ empty-lexenv ] dip compile-ast [ call ] compose ] - [ arguments>> length ] - [ need-return-continuation? ] - tri - [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ; +M: ast-block compile-ast + compile-block '[ _ ] ; -: compile-statement ( statement -- quot ) - [ [ empty-lexenv ] dip compile-ast ] [ need-return-continuation? ] bi - [ '[ [ [ return-continuation set @ ] callcc1 ] with-scope ] ] when ; +: make-return ( quot n block -- quot ) + need-return-continuation? [ + '[ + [ + _ _ ncurry + [ return-continuation set ] prepose callcc1 + ] with-scope + ] + ] [ drop ] if + rewrite-closures first ; + +GENERIC: compile-smalltalk ( ast -- quot ) + +M: object compile-smalltalk ( statement -- quot ) + [ [ empty-lexenv ] dip compile-ast 0 ] keep make-return ; + +: (compile-method-body) ( lexenv block -- lambda ) + [ drop self>> ] [ compile-block ] 2bi [ swap suffix ] dip ; + +: compile-method-body ( lexenv block -- quot ) + [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep + make-return ; + +: compile-method ( lexenv ast-method -- ) + [ [ class>> ] [ name>> selector>generic ] bi* create-method ] + [ body>> compile-method-body ] + 2bi define ; + +: ( class -- lexenv ) + swap >>class "self" >>self ; + +M: ast-class compile-smalltalk ( ast-class -- quot ) + [ + [ name>> ] [ superclass>> ] [ ivars>> ] tri + define-class + ] + [ methods>> ] bi + [ compile-method ] with each + [ nil ] ; + +ERROR: no-word name ; + +M: ast-foreign compile-smalltalk + [ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ] + [ name>> ] bi define-foreign + [ nil ] ; \ No newline at end of file diff --git a/extra/smalltalk/compiler/lexenv/lexenv-tests.factor b/extra/smalltalk/compiler/lexenv/lexenv-tests.factor new file mode 100644 index 0000000000..8f171f3eed --- /dev/null +++ b/extra/smalltalk/compiler/lexenv/lexenv-tests.factor @@ -0,0 +1,24 @@ +USING: smalltalk.compiler.lexenv tools.test kernel namespaces accessors ; +IN: smalltalk.compiler.lexenv.tests + +TUPLE: some-class x y z ; + +SYMBOL: fake-self + +SYMBOL: fake-local + + + some-class >>class + fake-self >>self + H{ { "mumble" fake-local } } >>local-readers + H{ { "jumble" fake-local } } >>local-writers +lexenv set + +[ [ fake-local ] ] [ "mumble" lexenv get lookup-reader ] unit-test +[ [ fake-self x>> ] ] [ "x" lexenv get lookup-reader ] unit-test +[ [ \ tuple ] ] [ "Object" lexenv get lookup-reader ] unit-test + +[ [ fake-local ] ] [ "jumble" lexenv get lookup-writer ] unit-test +[ [ fake-self (>>y) ] ] [ "y" lexenv get lookup-writer ] unit-test + +[ "blahblah" lexenv get lookup-writer ] must-fail \ No newline at end of file diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor index 2097dc8a50..b204b057b6 100644 --- a/extra/smalltalk/compiler/lexenv/lexenv.factor +++ b/extra/smalltalk/compiler/lexenv/lexenv.factor @@ -1,6 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel accessors ; +USING: assocs kernel accessors quotations slots words +sequences namespaces combinators combinators.short-circuit +smalltalk.classes ; IN: smalltalk.compiler.lexenv ! local-readers: assoc string => word @@ -10,11 +12,53 @@ IN: smalltalk.compiler.lexenv ! method: generic word or f for top-level forms TUPLE: lexenv local-readers local-writers self class method ; -: ( local-readers local-writers -- lexenv ) - f f f lexenv boa ; inline +: ( -- lexenv ) lexenv new ; inline CONSTANT: empty-lexenv T{ lexenv } : lexenv-union ( lexenv1 lexenv2 -- lexenv ) - [ [ local-readers>> ] bi@ assoc-union ] - [ [ local-writers>> ] bi@ assoc-union ] 2bi ; + [ ] 2dip { + [ [ local-readers>> ] bi@ assoc-union >>local-readers ] + [ [ local-writers>> ] bi@ assoc-union >>local-writers ] + [ [ self>> ] either? >>self ] + [ [ class>> ] either? >>class ] + [ [ method>> ] either? >>method ] + } 2cleave ; + +: local-reader ( name lexenv -- local ) + local-readers>> at dup [ 1quotation ] when ; + +: ivar-reader ( name lexenv -- quot/f ) + dup class>> [ + [ class>> "slots" word-prop slot-named ] [ self>> ] bi + swap dup [ name>> reader-word [ ] 2sequence ] [ 2drop f ] if + ] [ 2drop f ] if ; + +: class-name ( name -- quot/f ) + classes get at dup [ [ ] curry ] when ; + +ERROR: bad-identifier name ; + +: lookup-reader ( name lexenv -- reader-quot ) + { + [ local-reader ] + [ ivar-reader ] + [ drop class-name ] + [ drop bad-identifier ] + } 2|| ; + +: local-writer ( name lexenv -- local ) + local-writers>> at dup [ 1quotation ] when ; + +: ivar-writer ( name lexenv -- quot/f ) + dup class>> [ + [ class>> "slots" word-prop slot-named ] [ self>> ] bi + swap dup [ name>> writer-word [ ] 2sequence ] [ 2drop f ] if + ] [ 2drop f ] if ; + +: lookup-writer ( name lexenv -- writer-quot ) + { + [ local-writer ] + [ ivar-writer ] + [ drop bad-identifier ] + } 2|| ; \ No newline at end of file diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor index bf455c2c4a..1b24db71e8 100644 --- a/extra/smalltalk/library/library.factor +++ b/extra/smalltalk/library/library.factor @@ -1,7 +1,7 @@ ! 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 ; +locals smalltalk.selectors smalltalk.ast smalltalk.classes ; IN: smalltalk.library ! Some unary selectors @@ -73,3 +73,7 @@ M: object selector-value: call( input -- result ) ; M: object selector-value:value: call( input input -- result ) ; M: object selector-value:value:value: call( input input input -- result ) ; M: object selector-value:value:value:value: call( input input input input -- result ) ; + +SELECTOR: new + +M: object selector-new new ; \ No newline at end of file diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor index e1bb6aca5e..bef4adc196 100644 --- a/extra/smalltalk/listener/listener.factor +++ b/extra/smalltalk/listener/listener.factor @@ -7,7 +7,7 @@ IN: smalltalk.listener : eval-smalltalk ( string -- ) [ - parse-smalltalk-statement compile-statement rewrite-closures first + parse-smalltalk compile-smalltalk ] with-compilation-unit call( -- result ) dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ; diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor index fa0fde51d6..aa440f581e 100644 --- a/extra/smalltalk/parser/parser-tests.factor +++ b/extra/smalltalk/parser/parser-tests.factor @@ -68,6 +68,13 @@ test = ] [ "[ :i | i print ]" test-Literal ] unit-test +[ + T{ ast-block + { body { 5 self } } + } +] +[ "[5. self]" test-Literal ] unit-test + EBNF: test-FormalBlockArgumentDeclarationList test = ;EBNF @@ -207,4 +214,15 @@ test = ] [ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test +[ { 1 2 } ] [ "1. 2" parse-smalltalk ] unit-test + +[ + T{ ast-class + { name "Test" } + { superclass "Object" } + { ivars { "a" } } + } +] +[ "class Test [|a|]" parse-smalltalk ] 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 index e2fea234c8..e153e1552d 100644 --- a/extra/smalltalk/parser/parser.factor +++ b/extra/smalltalk/parser/parser.factor @@ -1,7 +1,7 @@ ! 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 ; +math.parser kernel arrays byte-arrays math assocs accessors ; IN: smalltalk.parser ! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html @@ -189,28 +189,23 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader: OptionalWhiteSpace "[" ExecutableCode:code OptionalWhiteSpace "]" - => [[ header first2 "self" suffix code ast-block boa ast-method boa ]] + => [[ header first2 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 LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars + (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix ]])?:methods OptionalWhiteSpace "]" - => [[ name superclass "Object" or ivars methods ast-class boa ]] + => [[ name superclass "Object" or ivars >array methods >array ast-class boa ]] +ForeignClassDeclaration = OptionalWhiteSpace "foreign" + OptionalWhiteSpace Identifier:name + OptionalWhiteSpace Literal:class + => [[ class name ast-foreign boa ]] End = !(.) -Program = ClassDeclaration* End -;EBNF - -EBNF: parse-smalltalk-statement - -Statement = - -End = !(.) - -Program = Statement? => [[ nil or ]] End +Program = (ClassDeclaration|ForeignClassDeclaration|ExecutableCode) => [[ nil or ]] End ;EBNF \ No newline at end of file From 712b21b59e14c78e387b3e6cd17fb0471ed46960 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 01:37:05 -0500 Subject: [PATCH 04/20] Fix printing of nested arrays --- extra/smalltalk/printer/printer-tests.factor | 4 ++++ extra/smalltalk/printer/printer.factor | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) create mode 100644 extra/smalltalk/printer/printer-tests.factor diff --git a/extra/smalltalk/printer/printer-tests.factor b/extra/smalltalk/printer/printer-tests.factor new file mode 100644 index 0000000000..e9f4bd9451 --- /dev/null +++ b/extra/smalltalk/printer/printer-tests.factor @@ -0,0 +1,4 @@ +IN: smalltalk.printer.tests +USING: smalltalk.printer tools.test ; + +[ "#((1 2) 'hi')" ] [ { { 1 2 } "hi" } smalltalk>string ] unit-test \ No newline at end of file diff --git a/extra/smalltalk/printer/printer.factor b/extra/smalltalk/printer/printer.factor index 70055e8e77..9b6aa11114 100644 --- a/extra/smalltalk/printer/printer.factor +++ b/extra/smalltalk/printer/printer.factor @@ -20,7 +20,7 @@ GENERIC: array-element>string ( object -- string ) M: object array-element>string smalltalk>string ; M: array array-element>string - [ smalltalk>string ] map " " join "(" ")" surround ; + [ array-element>string ] map " " join "(" ")" surround ; M: array smalltalk>string array-element>string "#" prepend ; From ce04d1dfa96f0cfaf37155b8b8095c8122a172c0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 31 Mar 2009 18:21:15 -0500 Subject: [PATCH 05/20] redo spider without dynamic variables --- extra/spider/spider-docs.factor | 5 -- extra/spider/spider.factor | 114 ++++++++++++++++++++------------ 2 files changed, 73 insertions(+), 46 deletions(-) diff --git a/extra/spider/spider-docs.factor b/extra/spider/spider-docs.factor index cdbd5e7e09..4ed00d39f6 100644 --- a/extra/spider/spider-docs.factor +++ b/extra/spider/spider-docs.factor @@ -16,11 +16,6 @@ HELP: run-spider { "spider" spider } } { $description "Runs a spider until completion. See the " { $subsection "spider-tutorial" } " for a complete description of the tuple slots that affect how thet spider works." } ; -HELP: slurp-heap-while -{ $values - { "heap" "a heap" } { "quot1" quotation } { "quot2" quotation } } -{ $description "Removes values from a heap that match the predicate quotation " { $snippet "quot1" } " and processes them with " { $snippet "quot2" } " until the predicate quotation no longer matches." } ; - ARTICLE: "spider-tutorial" "Spider tutorial" "To create a new spider, call the " { $link } " word with a link to the site you wish to spider." { $code <" "http://concatenative.org" "> } diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index bd5b2668be..42f2485ebe 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -3,22 +3,44 @@ USING: accessors fry html.parser html.parser.analyzer http.client kernel tools.time sets assocs sequences concurrency.combinators io threads namespaces math multiline -heaps math.parser inspector urls assoc-heaps logging -combinators.short-circuit continuations calendar prettyprint ; +math.parser inspector urls logging combinators.short-circuit +continuations calendar prettyprint dlists deques locals ; IN: spider TUPLE: spider base count max-count sleep max-depth initial-links -filters spidered todo nonmatching quiet ; +filters spidered todo nonmatching filtered quiet ; TUPLE: spider-result url depth headers fetch-time parsed-html links processing-time timestamp ; +TUPLE: todo-url url depth ; + +: ( url depth -- todo-url ) + todo-url new + swap >>depth + swap >>url ; + +TUPLE: unique-deque assoc deque ; + +: ( -- unique-deque ) + H{ } clone unique-deque boa ; + +: store-url ( url depth unique-deque -- ) + [ ] dip + [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ] + [ deque>> push-back ] 2bi ; + +: pop-url ( unique-deque -- todo-url ) deque>> pop-front ; + +: peek-url ( unique-deque -- todo-url ) deque>> peek-front ; + : ( base -- spider ) >url spider new over >>base - swap 0 [ heap-push ] keep >>todo - >>nonmatching + swap 0 [ store-url ] keep >>todo + >>nonmatching + >>filtered 0 >>max-depth 0 >>count 1/0. >>max-count @@ -27,10 +49,10 @@ links processing-time timestamp ; > [ '[ _ 1&& ] filter ] when* ; + filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ; -: push-links ( links level assoc-heap -- ) - '[ _ _ heap-push ] each ; +: push-links ( links level unique-deque -- ) + '[ _ _ store-url ] each ; : add-todo ( links level spider -- ) todo>> push-links ; @@ -38,64 +60,74 @@ links processing-time timestamp ; : add-nonmatching ( links level spider -- ) nonmatching>> push-links ; -: filter-base ( spider spider-result -- base-links nonmatching-links ) +: add-filtered ( links level spider -- ) + filtered>> push-links ; + +: filter-base-links ( spider spider-result -- base-links nonmatching-links ) [ base>> host>> ] [ links>> prune ] bi* [ host>> = ] with partition ; : add-spidered ( spider spider-result -- ) [ [ 1+ ] change-count ] dip 2dup [ spidered>> ] [ dup url>> ] bi* rot set-at - [ filter-base ] 2keep + [ filter-base-links ] 2keep depth>> 1+ swap [ add-nonmatching ] [ tuck [ apply-filters ] 2dip add-todo ] 2bi ; -: normalize-hrefs ( links -- links' ) - [ >url ] map - spider get base>> swap [ derive-url ] with map ; +: normalize-hrefs ( links spider -- links' ) + [ [ >url ] map ] dip + base>> swap [ derive-url ] with map ; : print-spidering ( url depth -- ) "depth: " write number>string write ", spidering: " write . yield ; -: (spider-page) ( url depth -- spider-result ) - f pick spider get spidered>> set-at - over '[ _ http-get ] benchmark swap - [ parse-html dup find-hrefs normalize-hrefs ] benchmark +:: new-spidered-result ( spider url depth -- spider-result ) + f url spider spidered>> set-at + [ url http-get ] benchmark :> fetch-time :> html :> headers + [ + html parse-html [ ] [ find-hrefs spider normalize-hrefs ] bi + ] benchmark :> processing-time :> links :> parsed-html + url depth headers fetch-time parsed-html links processing-time now spider-result boa ; -: spider-page ( url depth -- ) - spider get quiet>> [ 2dup print-spidering ] unless - (spider-page) - spider get [ quiet>> [ dup describe ] unless ] - [ swap add-spidered ] bi ; +:: spider-page ( spider url depth -- ) + spider quiet>> [ url depth print-spidering ] unless + spider url depth new-spidered-result :> spidered-result + spider quiet>> [ spidered-result describe ] unless + spider spidered-result add-spidered ; \ spider-page ERROR add-error-logging -: spider-sleep ( -- ) - spider get sleep>> [ sleep ] when* ; +: spider-sleep ( spider -- ) + sleep>> [ sleep ] when* ; -: queue-initial-links ( spider -- spider ) - [ initial-links>> normalize-hrefs 0 ] keep - [ add-todo ] keep ; +:: queue-initial-links ( spider -- spider ) + spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ; -: slurp-heap-while ( heap quot1 quot2: ( value key -- ) -- ) - pick heap-empty? [ 3drop ] [ - [ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ] - [ roll [ slurp-heap-while ] [ 3drop ] if ] 3bi - ] if ; inline recursive +: spider-page? ( spider -- ? ) + { + [ todo>> deque>> deque-empty? not ] + [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ] + } 1&& ; + +: setup-next-url ( spider -- spider url depth ) + dup todo>> pop-url [ url>> ] [ depth>> ] bi ; + +: spider-next-page ( spider -- ) + setup-next-url spider-page ; PRIVATE> +: run-spider-loop ( spider -- ) + dup spider-page? [ + [ spider-next-page ] [ run-spider-loop ] bi + ] [ + drop + ] if ; + : run-spider ( spider -- spider ) "spider" [ - dup spider [ - queue-initial-links - [ todo>> ] [ max-depth>> ] bi - '[ - _ <= spider get - [ count>> ] [ max-count>> ] bi < and - ] [ spider-page spider-sleep ] slurp-heap-while - spider get - ] with-variable + queue-initial-links [ run-spider-loop ] keep ] with-logging ; From e22823f2c44ba8769664178b66c2ea9f69d73705 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 31 Mar 2009 18:23:02 -0500 Subject: [PATCH 06/20] rename word --- extra/spider/spider.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index 42f2485ebe..0287d50692 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -25,7 +25,7 @@ TUPLE: unique-deque assoc deque ; : ( -- unique-deque ) H{ } clone unique-deque boa ; -: store-url ( url depth unique-deque -- ) +: push-url ( url depth unique-deque -- ) [ ] dip [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ] [ deque>> push-back ] 2bi ; @@ -38,7 +38,7 @@ TUPLE: unique-deque assoc deque ; >url spider new over >>base - swap 0 [ store-url ] keep >>todo + swap 0 [ push-url ] keep >>todo >>nonmatching >>filtered 0 >>max-depth @@ -52,7 +52,7 @@ TUPLE: unique-deque assoc deque ; filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ; : push-links ( links level unique-deque -- ) - '[ _ _ store-url ] each ; + '[ _ _ push-url ] each ; : add-todo ( links level spider -- ) todo>> push-links ; From 8e26b19cc0aa008af012af16f2f1055a10faa251 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 31 Mar 2009 18:49:41 -0500 Subject: [PATCH 07/20] state-parser works with sequences, not strings fix bug with take-until --- extra/html/parser/parser.factor | 10 ++--- extra/html/parser/state/state-tests.factor | 20 +++++---- extra/html/parser/state/state.factor | 47 ++++++++++++---------- 3 files changed, 44 insertions(+), 33 deletions(-) diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 677737618b..94ef59bdfd 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -68,10 +68,10 @@ SYMBOL: tagstack [ blank? ] trim ; : read-comment ( state-parser -- ) - "-->" take-until-string make-comment-tag push-tag ; + "-->" take-until-sequence make-comment-tag push-tag ; : read-dtd ( state-parser -- ) - ">" take-until-string make-dtd-tag push-tag ; + ">" take-until-sequence make-dtd-tag push-tag ; : read-bang ( state-parser -- ) next dup { [ get-char CHAR: - = ] [ get-next CHAR: - = ] } 1&& [ @@ -93,7 +93,7 @@ SYMBOL: tagstack : (parse-attributes) ( state-parser -- ) skip-whitespace - dup string-parse-end? [ + dup state-parse-end? [ drop ] [ [ @@ -108,7 +108,7 @@ SYMBOL: tagstack : (parse-tag) ( string -- string' hashtable ) [ [ read-token >lower ] [ parse-attributes ] bi - ] string-parse ; + ] state-parse ; : read-< ( state-parser -- string/f ) next dup get-char [ @@ -126,7 +126,7 @@ SYMBOL: tagstack ] [ drop ] if ; : tag-parse ( quot -- vector ) - V{ } clone tagstack [ string-parse ] with-variable ; inline + V{ } clone tagstack [ state-parse ] with-variable ; inline : parse-html ( string -- vector ) [ (parse-html) tagstack get ] tag-parse ; diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor index f676649aa8..f9862e1e69 100644 --- a/extra/html/parser/state/state-tests.factor +++ b/extra/html/parser/state/state-tests.factor @@ -2,29 +2,35 @@ USING: tools.test html.parser.state ascii kernel accessors ; IN: html.parser.state.tests [ "hello" ] -[ "hello" [ take-rest ] string-parse ] unit-test +[ "hello" [ take-rest ] state-parse ] unit-test [ "hi" " how are you?" ] [ "hi how are you?" - [ [ [ blank? ] take-until ] [ take-rest ] bi ] string-parse + [ [ [ blank? ] take-until ] [ take-rest ] bi ] state-parse ] unit-test [ "foo" ";bar" ] [ "foo;bar" [ - [ CHAR: ; take-until-char ] [ take-rest ] bi - ] string-parse + [ CHAR: ; take-until-object ] [ take-rest ] bi + ] state-parse ] unit-test [ "foo " " bar" ] [ "foo and bar" [ - [ "and" take-until-string ] [ take-rest ] bi - ] string-parse + [ "and" take-until-sequence ] [ take-rest ] bi + ] state-parse ] unit-test [ 6 ] [ - " foo " [ skip-whitespace i>> ] string-parse + " foo " [ skip-whitespace n>> ] state-parse ] unit-test + +[ { 1 2 } ] +[ { 1 2 3 } [ 3 = ] take-until ] unit-test + +[ { 1 2 } ] +[ { 1 2 3 4 } { 3 4 } take-until-sequence ] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index c69fd76af5..2369b1d750 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -2,31 +2,32 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math kernel sequences accessors fry circular unicode.case unicode.categories locals ; + IN: html.parser.state -TUPLE: state-parser string i ; +TUPLE: state-parser sequence n ; -: ( string -- state-parser ) +: ( sequence -- state-parser ) state-parser new - swap >>string - 0 >>i ; + swap >>sequence + 0 >>n ; -: (get-char) ( i state -- char/f ) - string>> ?nth ; inline +: (get-char) ( n state -- char/f ) + sequence>> ?nth ; inline : get-char ( state -- char/f ) - [ i>> ] keep (get-char) ; inline + [ n>> ] keep (get-char) ; inline : get-next ( state -- char/f ) - [ i>> 1+ ] keep (get-char) ; inline + [ n>> 1 + ] keep (get-char) ; inline : next ( state -- state ) - [ 1+ ] change-i ; inline + [ 1 + ] change-n ; inline : get+increment ( state -- char/f ) [ get-char ] [ next drop ] bi ; inline -: string-parse ( string quot -- ) +: state-parse ( sequence quot -- ) [ ] dip call ; inline :: skip-until ( state quot: ( obj -- ? ) -- ) @@ -34,17 +35,23 @@ TUPLE: state-parser string i ; quot call [ state next quot skip-until ] unless ] when* ; inline recursive -: take-until ( state quot: ( obj -- ? ) -- string ) - [ drop i>> ] - [ skip-until ] - [ drop [ i>> ] [ string>> ] bi ] 2tri subseq ; inline +: state-parse-end? ( state -- ? ) get-next not ; -:: take-until-string ( state-parser string -- string' ) - string length :> growing +: take-until ( state quot: ( obj -- ? ) -- sequence/f ) + over state-parse-end? [ + 2drop f + ] [ + [ drop n>> ] + [ skip-until ] + [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq + ] if ; inline + +:: take-until-sequence ( state-parser sequence -- sequence' ) + sequence length :> growing state-parser [ growing push-growing-circular - string growing sequence= + sequence growing sequence= ] take-until :> found found dup length growing length 1- - head @@ -53,10 +60,8 @@ TUPLE: state-parser string i ; : skip-whitespace ( state -- state ) [ [ blank? not ] take-until drop ] keep ; -: take-rest ( state -- string ) +: take-rest ( state -- sequence ) [ drop f ] take-until ; inline -: take-until-char ( state ch -- string ) +: take-until-object ( state obj -- sequence ) '[ _ = ] take-until ; - -: string-parse-end? ( state -- ? ) get-next not ; From 15cb926afb6504bb24095f2788df3fdf0d2612ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 21:23:09 -0500 Subject: [PATCH 08/20] smalltalk: Working on message cascade syntax --- extra/smalltalk/ast/ast.factor | 11 ++- extra/smalltalk/compiler/compiler.factor | 52 ++++++++++++-- extra/smalltalk/compiler/lexenv/lexenv.factor | 4 +- extra/smalltalk/eval/authors.txt | 1 + extra/smalltalk/eval/eval-tests.factor | 5 ++ extra/smalltalk/eval/eval.factor | 8 +++ extra/smalltalk/library/library.factor | 13 ++-- extra/smalltalk/listener/listener.factor | 14 ++-- extra/smalltalk/parser/parser-tests.factor | 68 +++++++++++++++++-- extra/smalltalk/parser/parser.factor | 67 ++++++++++-------- extra/smalltalk/parser/test.st | 4 +- 11 files changed, 194 insertions(+), 53 deletions(-) create mode 100644 extra/smalltalk/eval/authors.txt create mode 100644 extra/smalltalk/eval/eval-tests.factor create mode 100644 extra/smalltalk/eval/eval.factor diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor index f426789316..69bfc3dbf6 100644 --- a/extra/smalltalk/ast/ast.factor +++ b/extra/smalltalk/ast/ast.factor @@ -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 } ; + +: ( 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 diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor index 9c3638ba6c..4a2417e91d 100644 --- a/extra/smalltalk/compiler/compiler.factor +++ b/extra/smalltalk/compiler/compiler.factor @@ -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 '[ _ ] ; diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor index b204b057b6..6b6d283761 100644 --- a/extra/smalltalk/compiler/lexenv/lexenv.factor +++ b/extra/smalltalk/compiler/lexenv/lexenv.factor @@ -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 ] diff --git a/extra/smalltalk/eval/authors.txt b/extra/smalltalk/eval/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/eval/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor new file mode 100644 index 0000000000..33f28a2bd8 --- /dev/null +++ b/extra/smalltalk/eval/eval-tests.factor @@ -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 \ No newline at end of file diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor new file mode 100644 index 0000000000..60f0d9cce2 --- /dev/null +++ b/extra/smalltalk/eval/eval.factor @@ -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 ) ; \ No newline at end of file diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor index 1b24db71e8..1a8cb8d177 100644 --- a/extra/smalltalk/library/library.factor +++ b/extra/smalltalk/library/library.factor @@ -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 ; \ 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 diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor index bef4adc196..e052f0c629 100644 --- a/extra/smalltalk/listener/listener.factor +++ b/extra/smalltalk/listener/listener.factor @@ -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 \ No newline at end of file diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor index aa440f581e..1ed6108376 100644 --- a/extra/smalltalk/parser/parser-tests.factor +++ b/extra/smalltalk/parser/parser-tests.factor @@ -164,6 +164,41 @@ test = ] [ "((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 = ] [ "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 diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor index e153e1552d..d6194a9637 100644 --- a/extra/smalltalk/parser/parser.factor +++ b/extra/smalltalk/parser/parser.factor @@ -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 ]] -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 ]] 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 ]] + +Message = BinaryMessage | UnaryMessage | KeywordMessage + +MessageSend = (MessageSend | Operand):lhs + Message:h + (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t + => [[ lhs t h prefix >array ]] 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 \ No newline at end of file diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st index 7771ee2b9c..493d270f9b 100644 --- a/extra/smalltalk/parser/test.st +++ b/extra/smalltalk/parser/test.st @@ -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 From d0921b1d2d9b7b965c7a47e09e11aed79de1ddd6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 22:30:13 -0500 Subject: [PATCH 09/20] Smalltalk parser work in progress --- extra/smalltalk/eval/eval-tests.factor | 6 ++- extra/smalltalk/parser/parser-tests.factor | 10 +++-- extra/smalltalk/parser/parser.factor | 46 ++++++++++++---------- extra/smalltalk/parser/test.st | 12 +++--- 4 files changed, 41 insertions(+), 33 deletions(-) diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor index 33f28a2bd8..1dbbd054a8 100644 --- a/extra/smalltalk/eval/eval-tests.factor +++ b/extra/smalltalk/eval/eval-tests.factor @@ -1,5 +1,7 @@ IN: smalltalk.eval.tests -USING: smalltalk.eval tools.test ; +USING: smalltalk.eval tools.test io.streams.string ; [ 3 ] [ "1+2" eval-smalltalk ] unit-test -[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test \ No newline at end of file +[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test +[ 7 ] [ "1+2+3;+4" eval-smalltalk ] unit-test +[ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test \ No newline at end of file diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor index 1ed6108376..9ba1c38ede 100644 --- a/extra/smalltalk/parser/parser-tests.factor +++ b/extra/smalltalk/parser/parser-tests.factor @@ -228,12 +228,12 @@ test = [ T{ ast-local-variables f { "i" "j" } } ] [ " | i j |" test-LocalVariableDeclarationList ] unit-test -EBNF: test-KeywordMessageSend -test = +EBNF: test-MessageSend +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 +[ "x foo:1 bar:2" test-MessageSend ] unit-test [ T{ ast-message-send @@ -247,7 +247,7 @@ test = { 10 100 } } ] -[ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test +[ "3 factorial + 4 factorial between: 10 and: 100" test-MessageSend ] unit-test [ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test @@ -283,4 +283,6 @@ test = ] [ "class Test1 [|a|]. class Test2 extends Test1 [|b|]" parse-smalltalk ] unit-test +[ ] [ "class Foo []. Tests blah " parse-smalltalk drop ] 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 index d6194a9637..c80171e025 100644 --- a/extra/smalltalk/parser/parser.factor +++ b/extra/smalltalk/parser/parser.factor @@ -104,7 +104,7 @@ BlockLiteral = "[" "|" => [[ args ]] )?:args - ExecutableCode:body OptionalWhiteSpace + ExecutableCode:body "]" => [[ args >array body ast-block boa ]] Literal = (ConstantReference @@ -125,41 +125,38 @@ Operand = Literal UnaryMessage = OptionalWhiteSpace UnaryMessageSelector:s !(":") => [[ s { } ast-message boa ]] -UnaryMessageOperand = UnaryMessageSend | Operand -UnaryMessageSend = UnaryMessageOperand:receiver - UnaryMessage:h - (OptionalWhiteSpace ";" UnaryMessage:m => [[ m ]])*:t - => [[ receiver t h prefix >array ]] BinaryMessage = OptionalWhiteSpace BinaryMessageSelector:selector OptionalWhiteSpace - BinaryMessageOperand:rhs + (MessageSend | Operand):rhs => [[ selector { rhs } ast-message boa ]] -BinaryMessageOperand = BinaryMessageSend | UnaryMessageSend | Operand -BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs - BinaryMessage:h - (OptionalWhiteSpace ";" BinaryMessage:m => [[ m ]])*:t - => [[ lhs t h prefix >array ]] - -KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]] +KeywordMessageSegment = Keyword:k OptionalWhiteSpace (BinaryMessageSend | UnaryMessageSend | Operand):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 - KeywordMessage:m - => [[ receiver m 1array ]] Message = BinaryMessage | UnaryMessage | KeywordMessage -MessageSend = (MessageSend | Operand):lhs +UnaryMessageSend = (MessageSend | Operand):lhs Message:h (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t => [[ lhs t h prefix >array ]] +BinaryMessageSend = (MessageSend | Operand):lhs + Message:h + (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t + => [[ lhs t h prefix >array ]] + +KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs + KeywordMessage:h + (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t + => [[ lhs t h prefix >array ]] + +MessageSend = BinaryMessageSend | UnaryMessageSend | KeywordMessageSend + Expression = OptionalWhiteSpace (MessageSend | Operand):e => [[ e ]] @@ -182,6 +179,7 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace ExecutableCode = (LocalVariableDeclarationList)?:locals ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h FinalStatement:t (".")? => [[ h t suffix ]])?:body + OptionalWhiteSpace => [[ body locals [ suffix ] when* >array ]] TopLevelForm = ExecutableCode => [[ ast-sequence boa ]] @@ -201,7 +199,7 @@ MethodHeader = KeywordMethodHeader MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:header OptionalWhiteSpace "[" ExecutableCode:code - OptionalWhiteSpace "]" + "]" => [[ header first2 code ast-block boa ast-method boa ]] ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name @@ -209,7 +207,13 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name ("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass OptionalWhiteSpace "[" (OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars - (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix ]])?:methods + (MethodDeclaration:h + (OptionalWhiteSpace + "." + OptionalWhiteSpace + MethodDeclaration:m => [[ m ]])*:t (".")? + => [[ t h prefix ]] + )?:methods OptionalWhiteSpace "]" => [[ name superclass "Object" or ivars >array methods >array ast-class boa ]] diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st index 493d270f9b..8a1ae12145 100644 --- a/extra/smalltalk/parser/test.st +++ b/extra/smalltalk/parser/test.st @@ -30,23 +30,23 @@ class TreeNode extends Object [ output nextPutAll: 'long lived tree of depth '; print: maxDepth; tab; nextPutAll: ' check: '; print: longLivedTree itemCheck; nl - ] + ]. method 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) @@ -56,11 +56,11 @@ class TreeNode extends Object [ 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 From 19d8a6a552d30964f8d5a684fc9f1b99f96641bb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 31 Mar 2009 23:04:59 -0500 Subject: [PATCH 10/20] remove some dead code, make spider use count and max-count again --- extra/spider/spider.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index 0287d50692..d08276a9bb 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -8,7 +8,7 @@ continuations calendar prettyprint dlists deques locals ; IN: spider TUPLE: spider base count max-count sleep max-depth initial-links -filters spidered todo nonmatching filtered quiet ; +filters spidered todo nonmatching quiet ; TUPLE: spider-result url depth headers fetch-time parsed-html links processing-time timestamp ; @@ -40,7 +40,6 @@ TUPLE: unique-deque assoc deque ; over >>base swap 0 [ push-url ] keep >>todo >>nonmatching - >>filtered 0 >>max-depth 0 >>count 1/0. >>max-count @@ -60,9 +59,6 @@ TUPLE: unique-deque assoc deque ; : add-nonmatching ( links level spider -- ) nonmatching>> push-links ; -: add-filtered ( links level spider -- ) - filtered>> push-links ; - : filter-base-links ( spider spider-result -- base-links nonmatching-links ) [ base>> host>> ] [ links>> prune ] bi* [ host>> = ] with partition ; @@ -110,6 +106,7 @@ TUPLE: unique-deque assoc deque ; { [ todo>> deque>> deque-empty? not ] [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ] + [ [ count>> ] [ max-count>> ] bi < ] } 1&& ; : setup-next-url ( spider -- spider url depth ) From 9e9116f0eacd11f8daa5c4475472310f6b641615 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 31 Mar 2009 23:18:52 -0500 Subject: [PATCH 11/20] Better error message for syntax error in : foo ( : bar --- core/effects/parser/parser.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index b9cb0ddcc9..c8ed6da2aa 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -15,6 +15,7 @@ ERROR: bad-effect ; scan { { "(" [ ")" parse-effect ] } { f [ ")" unexpected-eof ] } + [ bad-effect ] } case 2array ] when ] if @@ -31,4 +32,4 @@ ERROR: bad-effect ; "(" expect ")" parse-effect ; : parse-call( ( accum word -- accum ) - [ ")" parse-effect ] dip 2array over push-all ; \ No newline at end of file + [ ")" parse-effect ] dip 2array over push-all ; From ab7f433aa2dc175e5ac656052092b6cee855ebd7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 23:39:11 -0500 Subject: [PATCH 12/20] Fix stack effect declarations for (>>foo) words --- core/slots/slots.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 46fd325fa5..a353f50947 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -97,7 +97,7 @@ ERROR: bad-slot-value value class ; "writing" associate ; : define-writer-generic ( name -- ) - writer-word (( object value -- )) define-simple-generic ; + writer-word (( value object -- )) define-simple-generic ; : define-writer ( class slot-spec -- ) [ nip name>> define-writer-generic ] [ From 474e74a23208760456406ea679639b328518679c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 23:44:38 -0500 Subject: [PATCH 13/20] Re-organize things so that bootstrap.ui doesn't load ui.text --- basis/bootstrap/ui/ui.factor | 8 -------- basis/ui/gadgets/worlds/worlds.factor | 13 ++++++++----- basis/ui/text/core-text/core-text.factor | 5 ++--- basis/ui/text/pango/pango.factor | 5 ++--- basis/ui/text/text.factor | 22 ++++++++++++++++++---- basis/ui/ui.factor | 8 +++----- 6 files changed, 33 insertions(+), 28 deletions(-) diff --git a/basis/bootstrap/ui/ui.factor b/basis/bootstrap/ui/ui.factor index 4f7f82a067..271a99c223 100755 --- a/basis/bootstrap/ui/ui.factor +++ b/basis/bootstrap/ui/ui.factor @@ -10,12 +10,4 @@ IN: bootstrap.ui { [ os unix? ] [ "x11" ] } } cond ] unless* "ui.backend." prepend require - - "ui-text-backend" get [ - { - { [ os macosx? ] [ "core-text" ] } - { [ os windows? ] [ "pango" ] } - { [ os unix? ] [ "pango" ] } - } cond - ] unless* "ui.text." prepend require ] when diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 163dbff514..655c9ba49d 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -3,8 +3,7 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl sequences io combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures -ui.render ui.text ui.text.private ui.backend ui.gadgets.tracks -ui.commands ; +ui.render ui.backend ui.gadgets.tracks ui.commands ; IN: ui.gadgets.worlds TUPLE: world < track @@ -53,7 +52,6 @@ M: world request-focus-on ( child gadget -- ) swap >>status swap >>title swap 1 track-add - dup init-text-rendering dup request-focus ; : ( gadget title status -- world ) @@ -74,15 +72,20 @@ M: world remove-gadget 2dup layers>> memq? [ layers>> delq ] [ call-next-method ] if ; +SYMBOL: flush-layout-cache-hook + +flush-layout-cache-hook [ [ ] ] initialize + : (draw-world) ( world -- ) dup handle>> [ { [ init-gl ] [ draw-gadget ] - [ finish-text-rendering ] + [ text-handle>> [ purge-cache ] when* ] [ images>> [ purge-cache ] when* ] } cleave - ] with-gl-context ; + ] with-gl-context + flush-layout-cache-hook get call( -- ) ; : draw-world? ( world -- ? ) #! We don't draw deactivated worlds, or those with 0 size. diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor index 785a9366cb..3704189e48 100644 --- a/basis/ui/text/core-text/core-text.factor +++ b/basis/ui/text/core-text/core-text.factor @@ -18,12 +18,11 @@ M: core-text-renderer string-dim [ cached-line dim>> ] if-empty ; -M: core-text-renderer finish-text-rendering - text-handle>> purge-cache +M: core-text-renderer flush-layout-cache cached-lines get purge-cache ; : rendered-line ( font string -- texture ) - world get text-handle>> + world get world-text-handle [ cached-line [ image>> ] [ loc>> ] bi ] 2cache ; diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor index 8b644be469..017a4b2cf2 100755 --- a/basis/ui/text/pango/pango.factor +++ b/basis/ui/text/pango/pango.factor @@ -14,12 +14,11 @@ M: pango-renderer string-dim [ " " string-dim { 0 1 } v* ] [ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ; -M: pango-renderer finish-text-rendering - text-handle>> purge-cache +M: pango-renderer flush-layout-cache cached-layouts get purge-cache ; : rendered-layout ( font string -- texture ) - world get text-handle>> + world get world-text-handle [ cached-layout [ image>> ] [ text-position vneg ] bi ] 2cache ; diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor index d0766e9ee6..ebf4b9cce0 100644 --- a/basis/ui/text/text.factor +++ b/basis/ui/text/text.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays sequences math math.order opengl opengl.gl -strings fonts colors accessors ; +strings fonts colors accessors namespaces ui.gadgets.worlds ; IN: ui.text > [ dup init-text-rendering ] unless + text-handle>> ; -M: object finish-text-rendering drop ; +HOOK: flush-layout-cache font-renderer ( -- ) + +[ flush-layout-cache ] flush-layout-cache-hook set-global HOOK: string-dim font-renderer ( font string -- dim ) @@ -68,4 +72,14 @@ M: array draw-text [ draw-string ] [ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi ] with each - ] do-matrix ; \ No newline at end of file + ] do-matrix ; + +USING: vocabs.loader namespaces system combinators ; + +"ui-backend" get [ + { + { [ os macosx? ] [ "core-text" ] } + { [ os windows? ] [ "pango" ] } + { [ os unix? ] [ "pango" ] } + } cond +] unless* "ui.text." prepend require \ No newline at end of file diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 8ce8f57cf0..bf17e455f8 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -4,8 +4,7 @@ USING: arrays assocs io kernel math models namespaces make dlists deques sequences threads sequences words continuations init combinators hashtables concurrency.flags sets accessors calendar fry destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds -ui.gadgets.tracks ui.gestures ui.backend ui.render ui.text -ui.text.private ; +ui.gadgets.tracks ui.gestures ui.backend ui.render ; IN: ui > select-gl-context ] - [ text-handle>> dispose ] + [ text-handle>> [ dispose ] when* ] [ images>> [ dispose ] when* ] [ hand-clicked close-global ] [ hand-gadget close-global ] @@ -95,8 +94,7 @@ M: world ungraft* : restore-world ( world -- ) { [ reset-world ] - [ init-text-rendering ] - [ f >>images drop ] + [ f >>text-handle f >>images drop ] [ restore-gadget ] } cleave ; From 087a7acfba477a5a5c9b90d8de3a2ece5aead5d3 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 1 Apr 2009 17:55:15 +1300 Subject: [PATCH 14/20] Fix peg left recursion handling --- basis/peg/peg.factor | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index ce34beb725..dda36432e7 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -155,18 +155,21 @@ TUPLE: peg-head rule-id involved-set eval-set ; dup pos>> pos set ans>> ; inline -:: (setup-lr) ( r l s -- ) - s head>> l head>> eq? [ - l head>> s (>>head) - l head>> [ s rule-id>> suffix ] change-involved-set drop - r l s next>> (setup-lr) - ] unless ; +:: (setup-lr) ( l s -- ) + s [ + s left-recursion? [ s throw ] unless + s head>> l head>> eq? [ + l head>> s (>>head) + l head>> [ s rule-id>> suffix ] change-involved-set drop + l s next>> (setup-lr) + ] unless + ] when ; :: setup-lr ( r l -- ) l head>> [ r rule-id V{ } clone V{ } clone peg-head boa l (>>head) ] unless - r l lrstack get (setup-lr) ; + l lrstack get (setup-lr) ; :: lr-answer ( r p m -- ast ) [let* | @@ -216,8 +219,10 @@ TUPLE: peg-head rule-id involved-set eval-set ; lrstack get next>> lrstack set pos get m (>>pos) lr head>> [ - ans lr (>>seed) - r p m lr-answer + m ans>> left-recursion? [ + ans lr (>>seed) + r p m lr-answer + ] [ ans ] if ] [ ans m (>>ans) ans From 9f01e819e841056d38ef9618f8a581bb8ddd1047 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Apr 2009 02:06:57 -0500 Subject: [PATCH 15/20] smalltalk: fix various things in the parser, add temporary variable support, clean up compiler --- extra/smalltalk/ast/ast.factor | 26 ++- .../smalltalk/compiler/compiler-tests.factor | 9 +- extra/smalltalk/compiler/compiler.factor | 163 ++++++------------ extra/smalltalk/eval/eval-tests.factor | 4 +- extra/smalltalk/eval/eval.factor | 8 +- extra/smalltalk/library/library.factor | 25 ++- extra/smalltalk/listener/listener.factor | 2 +- extra/smalltalk/parser/parser-tests.factor | 35 ++-- extra/smalltalk/parser/parser.factor | 36 ++-- extra/smalltalk/parser/test.st | 7 +- 10 files changed, 155 insertions(+), 160 deletions(-) diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor index 69bfc3dbf6..e9759b2197 100644 --- a/extra/smalltalk/ast/ast.factor +++ b/extra/smalltalk/ast/ast.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: strings arrays memoize kernel sequences accessors ; +USING: strings arrays memoize kernel sequences accessors combinators ; IN: smalltalk.ast SINGLETONS: nil self super ; TUPLE: ast-comment { string string } ; -TUPLE: ast-block { arguments array } { body array } ; +TUPLE: ast-block { arguments array } { temporaries 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 } ; @@ -17,8 +17,28 @@ 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 } ; +TUPLE: ast-sequence { temporaries array } { body array } ; +! We treat a sequence of statements like a block in a few places to +! simplify handling of top-level forms +M: ast-sequence arguments>> drop { } ; + +: unclip-temporaries ( statements -- temporaries statements' ) + { + { [ dup empty? ] [ { } ] } + { [ dup first ast-local-variables? not ] [ { } ] } + [ unclip names>> ] + } cond swap ; + +: ( arguments body -- block ) + unclip-temporaries ast-block boa ; + +: ( body -- block ) + unclip-temporaries ast-sequence boa ; + +! The parser parses normal message sends as cascades with one message, but +! we represent them differently in the AST to simplify generated code in +! the common case : ( receiver messages -- ast ) dup length 1 = [ first [ selector>> ] [ arguments>> ] bi ast-message-send boa ] diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor index c0b9507dd0..81b38f2c14 100644 --- a/extra/smalltalk/compiler/compiler-tests.factor +++ b/extra/smalltalk/compiler/compiler-tests.factor @@ -1,10 +1,13 @@ USING: smalltalk.compiler tools.test prettyprint smalltalk.ast smalltalk.compiler.lexenv stack-checker locals.rewrite.closures -kernel accessors compiler.units sequences ; +kernel accessors compiler.units sequences arrays ; IN: smalltalk.compiler.tests : test-compilation ( ast -- quot ) - [ compile-smalltalk [ call ] append ] with-compilation-unit ; + [ + 1array ast-sequence new swap >>body + compile-smalltalk [ call ] append + ] with-compilation-unit ; : test-inference ( ast -- in# out# ) test-compilation infer [ in>> ] [ out>> ] bi ; @@ -46,6 +49,7 @@ IN: smalltalk.compiler.tests [ 0 1 ] [ T{ ast-block f + { } { } { T{ ast-message-send @@ -76,6 +80,7 @@ IN: smalltalk.compiler.tests [ "a" ] [ T{ ast-block f + { } { } { { T{ ast-block { body { "a" } } } } } } test-compilation call first call diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor index 4a2417e91d..e61b44ffae 100644 --- a/extra/smalltalk/compiler/compiler.factor +++ b/extra/smalltalk/compiler/compiler.factor @@ -2,77 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. 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 combinators smalltalk.ast -smalltalk.compiler.lexenv smalltalk.selectors -smalltalk.classes ; +generalizations slots locals.types splitting math +locals.rewrite.closures generic words combinators locals smalltalk.ast +smalltalk.compiler.lexenv smalltalk.compiler.assignment +smalltalk.compiler.return smalltalk.selectors smalltalk.classes ; 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? ; - -M: ast-message-send need-return-continuation? - { - [ receiver>> 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 ; - -GENERIC: assigned-locals ( ast -- seq ) - -M: ast-return assigned-locals value>> assigned-locals ; - -M: ast-block assigned-locals - [ body>> assigned-locals ] [ arguments>> ] bi diff ; - -M: ast-message-send 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: object assigned-locals drop f ; - GENERIC: compile-ast ( lexenv ast -- quot ) M: object compile-ast nip 1quotation ; @@ -108,11 +43,39 @@ 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 ; +: (compile-sequence) ( lexenv asts -- quot ) + [ drop [ nil ] ] [ + [ compile-ast ] with map [ drop ] join + ] if-empty ; + +: block-lexenv ( block -- lexenv ) + [ [ arguments>> ] [ temporaries>> ] bi append ] + [ body>> [ assigned-locals ] map concat unique ] bi + '[ + dup dup _ key? + [ ] + [ ] + if + ] H{ } map>assoc + dup + [ nip local-reader? ] assoc-filter + [ ] assoc-map + swap >>local-writers swap >>local-readers ; + +: lookup-block-vars ( vars lexenv -- seq ) + local-readers>> '[ _ at ] map ; + +: make-temporaries ( block lexenv -- quot ) + [ temporaries>> ] dip lookup-block-vars + [ [ f ] swap suffix ] map [ ] join ; + +:: compile-sequence ( lexenv block -- vars quot ) + lexenv block block-lexenv lexenv-union :> lexenv + block arguments>> lexenv lookup-block-vars + lexenv block body>> (compile-sequence) block lexenv make-temporaries prepend ; M: ast-sequence compile-ast - statements>> compile-sequence ; + compile-sequence nip ; GENERIC: contains-blocks? ( obj -- ? ) @@ -135,48 +98,12 @@ M: ast-name compile-assignment name>> swap lookup-writer ; 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 - swap >>local-writers swap >>local-readers ; - -: compile-block ( lexenv block -- vars body ) - [ - block-lexenv - [ nip local-readers>> values ] - [ lexenv-union ] 2bi - ] [ body>> ] bi - compile-sequence ; - M: ast-block compile-ast - compile-block '[ _ ] ; + compile-sequence '[ _ ] ; -: make-return ( quot n block -- quot ) - need-return-continuation? [ - '[ - [ - _ _ ncurry - [ return-continuation set ] prepose callcc1 - ] with-scope - ] - ] [ drop ] if - rewrite-closures first ; - -GENERIC: compile-smalltalk ( ast -- quot ) - -M: object compile-smalltalk ( statement -- quot ) - [ [ empty-lexenv ] dip compile-ast 0 ] keep make-return ; - -: (compile-method-body) ( lexenv block -- lambda ) - [ drop self>> ] [ compile-block ] 2bi [ swap suffix ] dip ; +:: (compile-method-body) ( lexenv block -- lambda ) + lexenv block compile-sequence + [ lexenv self>> suffix ] dip ; : compile-method-body ( lexenv block -- quot ) [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep @@ -190,7 +117,8 @@ M: object compile-smalltalk ( statement -- quot ) : ( class -- lexenv ) swap >>class "self" >>self ; -M: ast-class compile-smalltalk ( ast-class -- quot ) +M: ast-class compile-ast + nip [ [ name>> ] [ superclass>> ] [ ivars>> ] tri define-class @@ -201,7 +129,12 @@ M: ast-class compile-smalltalk ( ast-class -- quot ) ERROR: no-word name ; -M: ast-foreign compile-smalltalk +M: ast-foreign compile-ast + nip [ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ] [ name>> ] bi define-foreign - [ nil ] ; \ No newline at end of file + [ nil ] ; + +: compile-smalltalk ( statement -- quot ) + [ [ empty-lexenv ] dip compile-sequence nip 0 ] + keep make-return ; \ No newline at end of file diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor index 1dbbd054a8..8a7756054a 100644 --- a/extra/smalltalk/eval/eval-tests.factor +++ b/extra/smalltalk/eval/eval-tests.factor @@ -4,4 +4,6 @@ USING: smalltalk.eval tools.test io.streams.string ; [ 3 ] [ "1+2" eval-smalltalk ] unit-test [ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test [ 7 ] [ "1+2+3;+4" eval-smalltalk ] unit-test -[ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test \ No newline at end of file +[ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test +[ 5 ] [ "|x| x:=5. x" eval-smalltalk ] unit-test +[ 11 ] [ "[:i| |x| x:=5. i+x] value: 6" eval-smalltalk ] unit-test diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor index 60f0d9cce2..d874000a0f 100644 --- a/extra/smalltalk/eval/eval.factor +++ b/extra/smalltalk/eval/eval.factor @@ -1,8 +1,12 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler.units smalltalk.parser smalltalk.compiler ; +USING: io.files io.encodings.utf8 +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 + call( -- result ) ; + +: eval-smalltalk-file ( path -- result ) + utf8 file-contents eval-smalltalk ; diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor index 1a8cb8d177..28acf98dff 100644 --- a/extra/smalltalk/library/library.factor +++ b/extra/smalltalk/library/library.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel present io math sequences assocs math.ranges fry -tools.time locals smalltalk.selectors smalltalk.ast smalltalk.classes ; +USING: kernel present io math sequences assocs math.ranges +math.order fry tools.time locals smalltalk.selectors +smalltalk.ast smalltalk.classes ; IN: smalltalk.library SELECTOR: print @@ -10,6 +11,16 @@ SELECTOR: asString M: object selector-print dup present print ; M: object selector-asString present ; +SELECTOR: print: +SELECTOR: nextPutAll: +SELECTOR: tab +SELECTOR: nl + +M: object selector-print: [ present ] dip stream-print nil ; +M: object selector-nextPutAll: selector-print: ; +M: object selector-tab " " swap selector-print: ; +M: object selector-nl stream-nl nil ; + SELECTOR: + SELECTOR: - SELECTOR: * @@ -30,6 +41,12 @@ M: object selector-<= swap <= ; M: object selector->= swap >= ; M: object selector-= swap = ; +SELECTOR: min: +SELECTOR: max: + +M: object selector-min: min ; +M: object selector-max: max ; + SELECTOR: ifTrue: SELECTOR: ifFalse: SELECTOR: ifTrue:ifFalse: @@ -38,6 +55,10 @@ M: object selector-ifTrue: [ call( -- result ) ] [ drop nil ] if ; M: object selector-ifFalse: [ drop nil ] [ call( -- result ) ] if ; M: object selector-ifTrue:ifFalse: [ drop call( -- result ) ] [ nip call( -- result ) ] if ; +SELECTOR: isNil + +M: object selector-isNil nil eq? ; + SELECTOR: at: SELECTOR: at:put: diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor index e052f0c629..dc84fd90fb 100644 --- a/extra/smalltalk/listener/listener.factor +++ b/extra/smalltalk/listener/listener.factor @@ -2,7 +2,7 @@ ! 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.eval smalltalk.printer ; +smalltalk.eval smalltalk.printer smalltalk.listener ; IN: smalltalk.listener : eval-interactively ( string -- ) diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor index 9ba1c38ede..ff9cbc208b 100644 --- a/extra/smalltalk/parser/parser-tests.factor +++ b/extra/smalltalk/parser/parser-tests.factor @@ -49,9 +49,9 @@ 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 +[ 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 [ T{ ast-block @@ -190,6 +190,19 @@ test = ] [ "12 sqrt + 1; + 2" test-Expression ] unit-test +[ + T{ ast-cascade + { receiver T{ ast-message-send f 12 "squared" } } + { messages + { + T{ ast-message f "to:" { 100 } } + T{ ast-message f "sqrt" } + } + } + } +] +[ "12 squared to: 100; sqrt" test-Expression ] unit-test + [ T{ ast-message-send f T{ ast-message-send f 1 "+" { 2 } } @@ -228,12 +241,8 @@ test = [ T{ ast-local-variables f { "i" "j" } } ] [ " | i j |" test-LocalVariableDeclarationList ] unit-test -EBNF: test-MessageSend -test = -;EBNF - [ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ] -[ "x foo:1 bar:2" test-MessageSend ] unit-test +[ "x foo:1 bar:2" test-Expression ] unit-test [ T{ ast-message-send @@ -247,12 +256,14 @@ test = { 10 100 } } ] -[ "3 factorial + 4 factorial between: 10 and: 100" test-MessageSend ] unit-test +[ "3 factorial + 4 factorial between: 10 and: 100" test-Expression ] unit-test -[ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test +[ T{ ast-sequence f { } { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test + +[ T{ ast-sequence f { } { 1 2 } } ] [ "1. 2." parse-smalltalk ] unit-test [ - T{ ast-sequence f + T{ ast-sequence f { } { T{ ast-class { name "Test" } @@ -265,7 +276,7 @@ test = [ "class Test [|a|]" parse-smalltalk ] unit-test [ - T{ ast-sequence f + T{ ast-sequence f { } { T{ ast-class { name "Test1" } diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor index c80171e025..1958861606 100644 --- a/extra/smalltalk/parser/parser.factor +++ b/extra/smalltalk/parser/parser.factor @@ -105,7 +105,7 @@ BlockLiteral = "[" => [[ args ]] )?:args ExecutableCode:body - "]" => [[ args >array body ast-block boa ]] + "]" => [[ args >array body ]] Literal = (ConstantReference | FloatingPointLiteral @@ -129,7 +129,7 @@ UnaryMessage = OptionalWhiteSpace BinaryMessage = OptionalWhiteSpace BinaryMessageSelector:selector OptionalWhiteSpace - (MessageSend | Operand):rhs + (UnaryMessageSend | Operand):rhs => [[ selector { rhs } ast-message boa ]] KeywordMessageSegment = Keyword:k OptionalWhiteSpace (BinaryMessageSend | UnaryMessageSend | Operand):arg => [[ { k arg } ]] @@ -140,13 +140,13 @@ KeywordMessage = OptionalWhiteSpace Message = BinaryMessage | UnaryMessage | KeywordMessage -UnaryMessageSend = (MessageSend | Operand):lhs - Message:h +UnaryMessageSend = (UnaryMessageSend | Operand):lhs + UnaryMessage:h (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t => [[ lhs t h prefix >array ]] -BinaryMessageSend = (MessageSend | Operand):lhs - Message:h +BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs + BinaryMessage:h (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t => [[ lhs t h prefix >array ]] @@ -155,10 +155,8 @@ KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t => [[ lhs t h prefix >array ]] -MessageSend = BinaryMessageSend | UnaryMessageSend | KeywordMessageSend - Expression = OptionalWhiteSpace - (MessageSend | Operand):e + (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e => [[ e ]] AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i @@ -176,13 +174,15 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace => [[ t h prefix ]] )?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]] -ExecutableCode = (LocalVariableDeclarationList)?:locals - ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h - FinalStatement:t (".")? => [[ h t suffix ]])?:body - OptionalWhiteSpace - => [[ body locals [ suffix ] when* >array ]] +EndStatement = "." -TopLevelForm = ExecutableCode => [[ ast-sequence boa ]] +ExecutableCode = (LocalVariableDeclarationList)?:locals + (Statement:s OptionalWhiteSpace EndStatement => [[ s ]])*:h + (FinalStatement:t (EndStatement)? => [[ t ]])?:t + OptionalWhiteSpace + => [[ h t [ suffix ] when* locals [ prefix ] when* >array ]] + +TopLevelForm = ExecutableCode => [[ ]] UnaryMethodHeader = UnaryMessageSelector:selector => [[ { selector { } } ]] @@ -200,7 +200,7 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader: OptionalWhiteSpace "[" ExecutableCode:code "]" - => [[ header first2 code ast-block boa ast-method boa ]] + => [[ header first2 code ast-method boa ]] ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name OptionalWhiteSpace @@ -209,9 +209,9 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name (OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars (MethodDeclaration:h (OptionalWhiteSpace - "." + EndStatement OptionalWhiteSpace - MethodDeclaration:m => [[ m ]])*:t (".")? + MethodDeclaration:m => [[ m ]])*:t (EndStatement)? => [[ t h prefix ]] )?:methods OptionalWhiteSpace "]" diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st index 8a1ae12145..063f20882a 100644 --- a/extra/smalltalk/parser/test.st +++ b/extra/smalltalk/parser/test.st @@ -31,9 +31,9 @@ class TreeNode extends Object [ nextPutAll: 'long lived tree of depth '; print: maxDepth; tab; nextPutAll: ' check: '; print: longLivedTree itemCheck; nl ]. - - method binarytrees [ - self binarytrees: self arg to: self stdout. + + method binarytrees: arg [ + self binarytrees: arg to: self stdout. ^'' ]. @@ -63,4 +63,3 @@ class TreeNode extends Object [ ] ]. -Tests binarytrees From 0ff66788503d96999b4b273a5bfe8c5fda8aab5f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Apr 2009 02:08:49 -0500 Subject: [PATCH 16/20] Load smalltalk.library by default and remove useless smalltalk.factor --- extra/smalltalk/eval/eval.factor | 3 ++- extra/smalltalk/smalltalk.factor | 4 ---- 2 files changed, 2 insertions(+), 5 deletions(-) delete mode 100644 extra/smalltalk/smalltalk.factor diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor index d874000a0f..56841beafd 100644 --- a/extra/smalltalk/eval/eval.factor +++ b/extra/smalltalk/eval/eval.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.files io.encodings.utf8 -compiler.units smalltalk.parser smalltalk.compiler ; +compiler.units smalltalk.parser smalltalk.compiler +smalltalk.library ; IN: smalltalk.eval : eval-smalltalk ( string -- result ) diff --git a/extra/smalltalk/smalltalk.factor b/extra/smalltalk/smalltalk.factor deleted file mode 100644 index 27cd9912ed..0000000000 --- a/extra/smalltalk/smalltalk.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: ; -IN: smalltalk From 8ab7328899458ad12c391272a7e0018bddbca742 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Apr 2009 02:09:49 -0500 Subject: [PATCH 17/20] Add new vocabs --- .../compiler/assignment/assignment.factor | 36 +++++++++++++ .../smalltalk/compiler/assignment/authors.txt | 1 + extra/smalltalk/compiler/return/authors.txt | 1 + extra/smalltalk/compiler/return/return.factor | 50 +++++++++++++++++++ 4 files changed, 88 insertions(+) create mode 100644 extra/smalltalk/compiler/assignment/assignment.factor create mode 100644 extra/smalltalk/compiler/assignment/authors.txt create mode 100644 extra/smalltalk/compiler/return/authors.txt create mode 100644 extra/smalltalk/compiler/return/return.factor diff --git a/extra/smalltalk/compiler/assignment/assignment.factor b/extra/smalltalk/compiler/assignment/assignment.factor new file mode 100644 index 0000000000..3a0a769f86 --- /dev/null +++ b/extra/smalltalk/compiler/assignment/assignment.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel sequences sets smalltalk.ast ; +IN: smalltalk.compiler.assignment + +GENERIC: assigned-locals ( ast -- seq ) + +M: ast-return assigned-locals value>> assigned-locals ; + +M: ast-block assigned-locals + [ body>> assigned-locals ] [ arguments>> ] bi diff ; + +M: ast-message-send assigned-locals + [ receiver>> assigned-locals ] + [ arguments>> assigned-locals ] + bi append ; + +M: ast-cascade assigned-locals + [ receiver>> 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 + body>> assigned-locals ; + +M: array assigned-locals + [ assigned-locals ] map concat ; + +M: object assigned-locals drop f ; \ No newline at end of file diff --git a/extra/smalltalk/compiler/assignment/authors.txt b/extra/smalltalk/compiler/assignment/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/compiler/assignment/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/compiler/return/authors.txt b/extra/smalltalk/compiler/return/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/smalltalk/compiler/return/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/smalltalk/compiler/return/return.factor b/extra/smalltalk/compiler/return/return.factor new file mode 100644 index 0000000000..31b4a1511b --- /dev/null +++ b/extra/smalltalk/compiler/return/return.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators.short-circuit continuations +fry generalizations kernel locals.rewrite.closures namespaces +sequences smalltalk.ast ; +IN: smalltalk.compiler.return + +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? ; + +M: ast-message-send need-return-continuation? + { + [ receiver>> 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? + body>> need-return-continuation? ; + +M: array need-return-continuation? [ need-return-continuation? ] any? ; + +M: object need-return-continuation? drop f ; + +: make-return ( quot n block -- quot ) + need-return-continuation? [ + '[ + [ + _ _ ncurry + [ return-continuation set ] prepose callcc1 + ] with-scope + ] + ] [ drop ] if + rewrite-closures first ; \ No newline at end of file From 3885ba02a6cdf78682f06d75d3865e5183084987 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Apr 2009 02:47:51 -0500 Subject: [PATCH 18/20] Fixing up smalltalk to the point where it can run fib, slowly --- extra/smalltalk/ast/ast.factor | 4 +++ extra/smalltalk/compiler/compiler.factor | 31 +++++++++++++------ extra/smalltalk/compiler/lexenv/lexenv.factor | 3 +- .../compiler/return/return-tests.factor | 3 ++ extra/smalltalk/compiler/return/return.factor | 23 ++++++-------- extra/smalltalk/eval/eval-tests.factor | 4 ++- extra/smalltalk/eval/fib.st | 11 +++++++ extra/smalltalk/parser/parser-tests.factor | 5 +-- extra/smalltalk/parser/parser.factor | 2 +- 9 files changed, 57 insertions(+), 29 deletions(-) create mode 100644 extra/smalltalk/compiler/return/return-tests.factor create mode 100644 extra/smalltalk/eval/fib.st diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor index e9759b2197..fc415aa361 100644 --- a/extra/smalltalk/ast/ast.factor +++ b/extra/smalltalk/ast/ast.factor @@ -45,5 +45,9 @@ M: ast-sequence arguments>> drop { } ; [ ast-cascade boa ] if ; +! Methods return self by default +: ( class arguments body -- method ) + self suffix ast-method boa ; + TUPLE: symbol { name string } ; MEMO: intern ( name -- symbol ) symbol boa ; \ No newline at end of file diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor index e61b44ffae..0b6f17e3fa 100644 --- a/extra/smalltalk/compiler/compiler.factor +++ b/extra/smalltalk/compiler/compiler.factor @@ -21,11 +21,22 @@ 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 - [ compile-arguments ] +: compile-ifTrue:ifFalse: ( lexenv ast -- quot ) [ receiver>> compile-ast ] - [ nip selector>> selector>generic ] - 2tri [ append ] dip suffix ; + [ compile-arguments ] 2bi + [ if ] 3append ; + +M: ast-message-send compile-ast + dup selector>> { + { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] } + [ + drop + [ compile-arguments ] + [ receiver>> compile-ast ] + [ nip selector>> selector>generic ] + 2tri [ append ] dip suffix + ] + } case ; M: ast-cascade compile-ast [ receiver>> compile-ast ] @@ -40,8 +51,8 @@ M: ast-cascade compile-ast ] 2bi append ; M: ast-return compile-ast - value>> compile-ast - [ return-continuation get continue-with ] append ; + [ value>> compile-ast ] [ drop return>> 1quotation ] 2bi + [ continue-with ] 3append ; : (compile-sequence) ( lexenv asts -- quot ) [ drop [ nil ] ] [ @@ -106,7 +117,7 @@ M: ast-block compile-ast [ lexenv self>> suffix ] dip ; : compile-method-body ( lexenv block -- quot ) - [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep + [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] 2keep make-return ; : compile-method ( lexenv ast-method -- ) @@ -115,7 +126,7 @@ M: ast-block compile-ast 2bi define ; : ( class -- lexenv ) - swap >>class "self" >>self ; + swap >>class "self" >>self "^" >>return ; M: ast-class compile-ast nip @@ -136,5 +147,5 @@ M: ast-foreign compile-ast [ nil ] ; : compile-smalltalk ( statement -- quot ) - [ [ empty-lexenv ] dip compile-sequence nip 0 ] - keep make-return ; \ No newline at end of file + [ empty-lexenv ] dip [ compile-sequence nip 0 ] + 2keep make-return ; \ No newline at end of file diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor index 6b6d283761..cd06314fd9 100644 --- a/extra/smalltalk/compiler/lexenv/lexenv.factor +++ b/extra/smalltalk/compiler/lexenv/lexenv.factor @@ -10,7 +10,7 @@ IN: smalltalk.compiler.lexenv ! self: word or f for top-level forms ! class: class word or f for top-level forms ! method: generic word or f for top-level forms -TUPLE: lexenv local-readers local-writers self class method ; +TUPLE: lexenv local-readers local-writers self return class method ; : ( -- lexenv ) lexenv new ; inline @@ -21,6 +21,7 @@ CONSTANT: empty-lexenv T{ lexenv } [ [ local-readers>> ] bi@ assoc-union >>local-readers ] [ [ local-writers>> ] bi@ assoc-union >>local-writers ] [ [ self>> ] either? >>self ] + [ [ return>> ] either? >>return ] [ [ class>> ] either? >>class ] [ [ method>> ] either? >>method ] } 2cleave ; diff --git a/extra/smalltalk/compiler/return/return-tests.factor b/extra/smalltalk/compiler/return/return-tests.factor new file mode 100644 index 0000000000..15a3406ffc --- /dev/null +++ b/extra/smalltalk/compiler/return/return-tests.factor @@ -0,0 +1,3 @@ +USING: smalltalk.parser smalltalk.compiler.return tools.test ; + +[ t ] [ "(i <= 1) ifTrue: [^1] ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)]" parse-smalltalk need-return-continuation? ] unit-test \ No newline at end of file diff --git a/extra/smalltalk/compiler/return/return.factor b/extra/smalltalk/compiler/return/return.factor index 31b4a1511b..8c36bdac64 100644 --- a/extra/smalltalk/compiler/return/return.factor +++ b/extra/smalltalk/compiler/return/return.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators.short-circuit continuations -fry generalizations kernel locals.rewrite.closures namespaces -sequences smalltalk.ast ; +fry generalizations kernel locals locals.types locals.rewrite.closures +namespaces make sequences smalltalk.ast ; IN: smalltalk.compiler.return SYMBOL: return-continuation @@ -17,13 +17,13 @@ M: ast-message-send need-return-continuation? { [ receiver>> need-return-continuation? ] [ arguments>> need-return-continuation? ] - } 1&& ; + } 1|| ; M: ast-cascade need-return-continuation? { [ receiver>> need-return-continuation? ] [ messages>> need-return-continuation? ] - } 1&& ; + } 1|| ; M: ast-message need-return-continuation? arguments>> need-return-continuation? ; @@ -38,13 +38,8 @@ M: array need-return-continuation? [ need-return-continuation? ] any? ; M: object need-return-continuation? drop f ; -: make-return ( quot n block -- quot ) - need-return-continuation? [ - '[ - [ - _ _ ncurry - [ return-continuation set ] prepose callcc1 - ] with-scope - ] - ] [ drop ] if - rewrite-closures first ; \ No newline at end of file +:: make-return ( quot n lexenv block -- quot ) + block need-return-continuation? [ + quot clone [ lexenv return>> '[ _ ] prepend ] change-body + n '[ _ _ ncurry callcc1 ] + ] [ quot ] if rewrite-closures first ; \ No newline at end of file diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor index 8a7756054a..95366d65b9 100644 --- a/extra/smalltalk/eval/eval-tests.factor +++ b/extra/smalltalk/eval/eval-tests.factor @@ -1,5 +1,5 @@ IN: smalltalk.eval.tests -USING: smalltalk.eval tools.test io.streams.string ; +USING: smalltalk.eval tools.test io.streams.string kernel ; [ 3 ] [ "1+2" eval-smalltalk ] unit-test [ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test @@ -7,3 +7,5 @@ USING: smalltalk.eval tools.test io.streams.string ; [ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test [ 5 ] [ "|x| x:=5. x" eval-smalltalk ] unit-test [ 11 ] [ "[:i| |x| x:=5. i+x] value: 6" eval-smalltalk ] unit-test +[ t ] [ "class Blah [method foo [5]]. Blah new foo" eval-smalltalk tuple? ] unit-test +[ 196418 ] [ "vocab:smalltalk/eval/fib.st" eval-smalltalk-file ] unit-test \ No newline at end of file diff --git a/extra/smalltalk/eval/fib.st b/extra/smalltalk/eval/fib.st new file mode 100644 index 0000000000..41ab8f56cc --- /dev/null +++ b/extra/smalltalk/eval/fib.st @@ -0,0 +1,11 @@ +class Fib [ + |i| + method i: newI [i:=newI]. + method compute [ + (i <= 1) + ifTrue: [^1] + ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)] + ]. +]. + +[(Fib new i: 26) compute] time \ No newline at end of file diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor index ff9cbc208b..9027290e6a 100644 --- a/extra/smalltalk/parser/parser-tests.factor +++ b/extra/smalltalk/parser/parser-tests.factor @@ -1,5 +1,6 @@ IN: smalltalk.parser.tests -USING: smalltalk.parser smalltalk.ast peg.ebnf tools.test accessors +USING: smalltalk.parser smalltalk.ast +peg.ebnf tools.test accessors io.files io.encodings.ascii kernel ; EBNF: test-Character @@ -296,4 +297,4 @@ test = [ ] [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test -[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test +[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test \ No newline at end of file diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor index 1958861606..c7cafe94dd 100644 --- a/extra/smalltalk/parser/parser.factor +++ b/extra/smalltalk/parser/parser.factor @@ -200,7 +200,7 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader: OptionalWhiteSpace "[" ExecutableCode:code "]" - => [[ header first2 code ast-method boa ]] + => [[ header first2 code ]] ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name OptionalWhiteSpace From 11eff11fb753cc2b97ed73e5e1698bde60efc359 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Apr 2009 02:53:30 -0500 Subject: [PATCH 19/20] Add silly optimization for 'new'; this will be removed when compiler improves --- extra/smalltalk/compiler/compiler.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor index 0b6f17e3fa..2eeee30692 100644 --- a/extra/smalltalk/compiler/compiler.factor +++ b/extra/smalltalk/compiler/compiler.factor @@ -21,6 +21,11 @@ M: ast-name compile-ast name>> swap lookup-reader ; : compile-arguments ( lexenv ast -- quot ) arguments>> [ compile-ast ] with map [ ] join ; +: compile-new ( lexenv ast -- quot ) + [ receiver>> compile-ast ] + [ compile-arguments ] 2bi + [ new ] 3append ; + : compile-ifTrue:ifFalse: ( lexenv ast -- quot ) [ receiver>> compile-ast ] [ compile-arguments ] 2bi @@ -29,6 +34,7 @@ M: ast-name compile-ast name>> swap lookup-reader ; M: ast-message-send compile-ast dup selector>> { { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] } + { "new" [ compile-new ] } [ drop [ compile-arguments ] From e37627fa8f3441f7cb552193702022b2f7c0634e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 04:28:53 -0500 Subject: [PATCH 20/20] fix linux64 blas --- basis/math/blas/ffi/ffi.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 0603a91370..bc98f72d8b 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -11,7 +11,6 @@ IN: math.blas.ffi [ os [ freebsd? ] [ linux? cpu x86.32? and ] bi or ] [ "libblas.so" gfortran-abi add-fortran-library ] } - { [ os [ freebsd? ] [ linux? ] bi or ] [ "libblas.so" gfortran-abi add-fortran-library ] } [ "libblas.so" f2c-abi add-fortran-library ] } cond >>