From 00c9cde8e2edaf806d31b7ef676e16219f53b06a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 30 Mar 2009 05:31:50 -0500 Subject: [PATCH 01/37] 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/37] 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/37] 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/37] 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 15cb926afb6504bb24095f2788df3fdf0d2612ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 21:23:09 -0500 Subject: [PATCH 05/37] 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 06/37] 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 ab7f433aa2dc175e5ac656052092b6cee855ebd7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 31 Mar 2009 23:39:11 -0500 Subject: [PATCH 07/37] 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 08/37] 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 09/37] 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 10/37] 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 11/37] 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 12/37] 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 aa37871ff9681750013da1b6e3d9f631db878293 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 02:32:48 -0500 Subject: [PATCH 13/37] rename get-next to peek-next, get-char to current --- extra/html/parser/state/state.factor | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 2369b1d750..177a427716 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -12,30 +12,30 @@ TUPLE: state-parser sequence n ; swap >>sequence 0 >>n ; -: (get-char) ( n state -- char/f ) +: state-parser-nth ( n state -- char/f ) sequence>> ?nth ; inline -: get-char ( state -- char/f ) - [ n>> ] keep (get-char) ; inline +: current ( state -- char/f ) + [ n>> ] keep state-parser-nth ; inline -: get-next ( state -- char/f ) - [ n>> 1 + ] keep (get-char) ; inline +: peek-next ( state -- char/f ) + [ n>> 1 + ] keep state-parser-nth ; inline : next ( state -- state ) [ 1 + ] change-n ; inline : get+increment ( state -- char/f ) - [ get-char ] [ next drop ] bi ; inline + [ current ] [ next drop ] bi ; inline : state-parse ( sequence quot -- ) [ ] dip call ; inline :: skip-until ( state quot: ( obj -- ? ) -- ) - state get-char [ + state current [ quot call [ state next quot skip-until ] unless ] when* ; inline recursive -: state-parse-end? ( state -- ? ) get-next not ; +: state-parse-end? ( state -- ? ) peek-next not ; : take-until ( state quot: ( obj -- ? ) -- sequence/f ) over state-parse-end? [ @@ -65,3 +65,7 @@ TUPLE: state-parser sequence n ; : take-until-object ( state obj -- sequence ) '[ _ = ] take-until ; + +: take-stuff ( state delimiter -- sequence ) + + ; From 99c3cd95174041e8b3bb82d8fbf57e6059960984 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 02:33:38 -0500 Subject: [PATCH 14/37] more renaing get-char to current --- extra/html/parser/analyzer/analyzer.factor | 12 ++++++++++-- extra/html/parser/parser.factor | 10 +++++----- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index b344ce160f..54b8c8fc69 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -3,7 +3,7 @@ USING: assocs html.parser kernel math sequences strings ascii arrays generalizations shuffle unicode.case namespaces make splitting http accessors io combinators http.client urls -urls.encoding fry prettyprint ; +urls.encoding fry prettyprint sets ; IN: html.parser.analyzer TUPLE: link attributes clickable ; @@ -126,7 +126,15 @@ TUPLE: link attributes clickable ; [ [ [ name>> "a" = ] [ attributes>> "href" swap key? ] bi and ] filter - ] map sift [ [ attributes>> "href" swap at ] map ] map concat ; + ] map sift + [ [ attributes>> "href" swap at ] map ] map concat ; + +: find-frame-links ( vector -- vector' ) + [ name>> "frame" = ] find-between-all + [ [ attributes>> "src" swap at ] map sift ] map concat sift ; + +: find-all-links ( vector -- vector' ) + [ find-hrefs ] [ find-frame-links ] bi append prune ; : find-forms ( vector -- vector' ) "form" over find-opening-tags-by-name diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 94ef59bdfd..9209e2dbc8 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -64,7 +64,7 @@ SYMBOL: tagstack : read-value ( state-parser -- string ) skip-whitespace - dup get-char quote? [ read-quote ] [ read-token ] if + dup current quote? [ read-quote ] [ read-token ] if [ blank? ] trim ; : read-comment ( state-parser -- ) @@ -74,7 +74,7 @@ SYMBOL: tagstack ">" take-until-sequence make-dtd-tag push-tag ; : read-bang ( state-parser -- ) - next dup { [ get-char CHAR: - = ] [ get-next CHAR: - = ] } 1&& [ + next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& [ next next read-comment ] [ @@ -83,7 +83,7 @@ SYMBOL: tagstack : read-tag ( state-parser -- string ) [ [ "><" member? ] take-until ] - [ dup get-char CHAR: < = [ next ] unless drop ] bi ; + [ dup current CHAR: < = [ next ] unless drop ] bi ; : read-until-< ( state-parser -- string ) [ CHAR: < = ] take-until ; @@ -111,7 +111,7 @@ SYMBOL: tagstack ] state-parse ; : read-< ( state-parser -- string/f ) - next dup get-char [ + next dup current [ CHAR: ! = [ read-bang f ] [ read-tag ] if ] [ drop f @@ -121,7 +121,7 @@ SYMBOL: tagstack read-< [ (parse-tag) make-tag push-tag ] unless-empty ; : (parse-html) ( state-parser -- ) - dup get-next [ + dup peek-next [ [ parse-text ] [ parse-tag ] [ (parse-html) ] tri ] [ drop ] if ; From f994654af31bcabe23a695fb6ddaffd10c5cc992 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 02:45:20 -0500 Subject: [PATCH 15/37] add take-while to state parser --- extra/html/parser/state/state.factor | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 177a427716..e1951fbd7c 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -18,6 +18,9 @@ TUPLE: state-parser sequence n ; : current ( state -- char/f ) [ n>> ] keep state-parser-nth ; inline +: previous ( state -- char/f ) + [ n>> 1 - ] keep state-parser-nth ; inline + : peek-next ( state -- char/f ) [ n>> 1 + ] keep state-parser-nth ; inline @@ -27,9 +30,6 @@ TUPLE: state-parser sequence n ; : get+increment ( state -- char/f ) [ current ] [ next drop ] bi ; inline -: state-parse ( sequence quot -- ) - [ ] dip call ; inline - :: skip-until ( state quot: ( obj -- ? ) -- ) state current [ quot call [ state next quot skip-until ] unless @@ -46,6 +46,9 @@ TUPLE: state-parser sequence n ; [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq ] if ; inline +: take-while ( state quot: ( obj -- ? ) -- sequence/f ) + [ not ] compose take-until ; inline + :: take-until-sequence ( state-parser sequence -- sequence' ) sequence length :> growing state-parser @@ -66,6 +69,5 @@ TUPLE: state-parser sequence n ; : take-until-object ( state obj -- sequence ) '[ _ = ] take-until ; -: take-stuff ( state delimiter -- sequence ) - - ; +: state-parse ( sequence quot -- ) + [ ] dip call ; inline From 3885ba02a6cdf78682f06d75d3865e5183084987 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Apr 2009 02:47:51 -0500 Subject: [PATCH 16/37] 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 17/37] 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 20df429a506770e1fc05e02865297c6c352ee5f2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 03:13:38 -0500 Subject: [PATCH 18/37] take-until doesnt pass the element to the quotation anymore --- extra/html/parser/parser.factor | 14 +++++++------- extra/html/parser/state/state-tests.factor | 4 ++-- extra/html/parser/state/state.factor | 10 +++++----- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 9209e2dbc8..61088d1b5e 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -42,10 +42,10 @@ SYMBOL: tagstack : make-dtd-tag ( string -- tag ) dtd new-tag ; inline : read-single-quote ( state-parser -- string ) - [ [ CHAR: ' = ] take-until ] [ next drop ] bi ; + [ [ current CHAR: ' = ] take-until ] [ next drop ] bi ; : read-double-quote ( state-parser -- string ) - [ [ CHAR: " = ] take-until ] [ next drop ] bi ; + [ [ current CHAR: " = ] take-until ] [ next drop ] bi ; : read-quote ( state-parser -- string ) dup get+increment CHAR: ' = @@ -53,14 +53,14 @@ SYMBOL: tagstack : read-key ( state-parser -- string ) skip-whitespace - [ { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ; + [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ; : read-= ( state-parser -- ) skip-whitespace - [ [ CHAR: = = ] take-until drop ] [ next drop ] bi ; + [ [ current CHAR: = = ] take-until drop ] [ next drop ] bi ; : read-token ( state-parser -- string ) - [ blank? ] take-until ; + [ current blank? ] take-until ; : read-value ( state-parser -- string ) skip-whitespace @@ -82,11 +82,11 @@ SYMBOL: tagstack ] if ; : read-tag ( state-parser -- string ) - [ [ "><" member? ] take-until ] + [ [ current "><" member? ] take-until ] [ dup current CHAR: < = [ next ] unless drop ] bi ; : read-until-< ( state-parser -- string ) - [ CHAR: < = ] take-until ; + [ current CHAR: < = ] take-until ; : parse-text ( state-parser -- ) read-until-< [ make-text-tag push-tag ] unless-empty ; diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor index f9862e1e69..835b54d0d3 100644 --- a/extra/html/parser/state/state-tests.factor +++ b/extra/html/parser/state/state-tests.factor @@ -7,7 +7,7 @@ IN: html.parser.state.tests [ "hi" " how are you?" ] [ "hi how are you?" - [ [ [ blank? ] take-until ] [ take-rest ] bi ] state-parse + [ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse ] unit-test [ "foo" ";bar" ] @@ -30,7 +30,7 @@ IN: html.parser.state.tests ] unit-test [ { 1 2 } ] -[ { 1 2 3 } [ 3 = ] take-until ] unit-test +[ { 1 2 3 } [ current 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 e1951fbd7c..3f899446c0 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -32,8 +32,8 @@ TUPLE: state-parser sequence n ; :: skip-until ( state quot: ( obj -- ? ) -- ) state current [ - quot call [ state next quot skip-until ] unless - ] when* ; inline recursive + state quot call [ state next quot skip-until ] unless + ] when ; inline recursive : state-parse-end? ( state -- ? ) peek-next not ; @@ -53,7 +53,7 @@ TUPLE: state-parser sequence n ; sequence length :> growing state-parser [ - growing push-growing-circular + current growing push-growing-circular sequence growing sequence= ] take-until :> found found dup length @@ -61,13 +61,13 @@ TUPLE: state-parser sequence n ; state-parser next drop ; : skip-whitespace ( state -- state ) - [ [ blank? not ] take-until drop ] keep ; + [ [ current blank? not ] take-until drop ] keep ; : take-rest ( state -- sequence ) [ drop f ] take-until ; inline : take-until-object ( state obj -- sequence ) - '[ _ = ] take-until ; + '[ current _ = ] take-until ; : state-parse ( sequence quot -- ) [ ] dip call ; inline From e37627fa8f3441f7cb552193702022b2f7c0634e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 04:28:53 -0500 Subject: [PATCH 19/37] 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 >> From 393df94d38c49b5ec29172f034151f889b81728a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 11:03:10 -0500 Subject: [PATCH 20/37] add chicago-talk to demos --- extra/chicago-talk/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/chicago-talk/tags.txt diff --git a/extra/chicago-talk/tags.txt b/extra/chicago-talk/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/chicago-talk/tags.txt @@ -0,0 +1 @@ +demos From b35bb10123a1a7b334b8ddad30c61baeb63e7c4a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 11:08:19 -0500 Subject: [PATCH 21/37] spider - better handling of relative links for frames, dont spider things twice --- extra/spider/spider.factor | 30 +++++++++++++++++++++--------- 1 file changed, 21 insertions(+), 9 deletions(-) diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index d08276a9bb..aeb4676767 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -4,11 +4,12 @@ USING: accessors fry html.parser html.parser.analyzer http.client kernel tools.time sets assocs sequences concurrency.combinators io threads namespaces math multiline math.parser inspector urls logging combinators.short-circuit -continuations calendar prettyprint dlists deques locals ; +continuations calendar prettyprint dlists deques locals +present ; IN: spider TUPLE: spider base count max-count sleep max-depth initial-links -filters spidered todo nonmatching quiet ; +filters spidered todo nonmatching quiet currently-spidering ; TUPLE: spider-result url depth headers fetch-time parsed-html links processing-time timestamp ; @@ -25,10 +26,16 @@ TUPLE: unique-deque assoc deque ; : ( -- unique-deque ) H{ } clone unique-deque boa ; +: url-exists? ( url unique-deque -- ? ) + [ url>> ] [ assoc>> ] bi* key? ; + : push-url ( url depth unique-deque -- ) - [ ] dip - [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ] - [ deque>> push-back ] 2bi ; + [ ] dip 2dup url-exists? [ + 2drop + ] [ + [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ] + [ deque>> push-back ] 2bi + ] if ; : pop-url ( unique-deque -- todo-url ) deque>> pop-front ; @@ -38,6 +45,7 @@ TUPLE: unique-deque assoc deque ; >url spider new over >>base + over >>currently-spidering swap 0 [ push-url ] keep >>todo >>nonmatching 0 >>max-depth @@ -71,9 +79,12 @@ TUPLE: unique-deque assoc deque ; [ add-nonmatching ] [ tuck [ apply-filters ] 2dip add-todo ] 2bi ; +: url-absolute? ( url -- ? ) + present "http://" head? ; + : normalize-hrefs ( links spider -- links' ) - [ [ >url ] map ] dip - base>> swap [ derive-url ] with map ; + currently-spidering>> present swap + [ dup url-absolute? [ derive-url ] [ url-append-path >url ] if ] with map ; : print-spidering ( url depth -- ) "depth: " write number>string write @@ -83,7 +94,7 @@ TUPLE: unique-deque assoc deque ; f url spider spidered>> set-at [ url http-get ] benchmark :> fetch-time :> html :> headers [ - html parse-html [ ] [ find-hrefs spider normalize-hrefs ] bi + html parse-html [ ] [ find-all-links spider normalize-hrefs ] bi ] benchmark :> processing-time :> links :> parsed-html url depth headers fetch-time parsed-html links processing-time now spider-result boa ; @@ -110,6 +121,7 @@ TUPLE: unique-deque assoc deque ; } 1&& ; : setup-next-url ( spider -- spider url depth ) + dup todo>> peek-url url>> present >>currently-spidering dup todo>> pop-url [ url>> ] [ depth>> ] bi ; : spider-next-page ( spider -- ) @@ -119,7 +131,7 @@ PRIVATE> : run-spider-loop ( spider -- ) dup spider-page? [ - [ spider-next-page ] [ run-spider-loop ] bi + [ spider-next-page ] [ spider-sleep ] [ run-spider-loop ] tri ] [ drop ] if ; From a172d61f2e908d51113133950270056af6a59f4e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 11:11:15 -0500 Subject: [PATCH 22/37] fix deployed name in minneapolis-talk, add summary/deploy to chicago talk --- extra/chicago-talk/deploy.factor | 12 ++++++++++++ extra/chicago-talk/summary.txt | 1 + extra/minneapolis-talk/deploy.factor | 2 +- extra/minneapolis-talk/summary.txt | 2 +- 4 files changed, 15 insertions(+), 2 deletions(-) create mode 100755 extra/chicago-talk/deploy.factor create mode 100755 extra/chicago-talk/summary.txt diff --git a/extra/chicago-talk/deploy.factor b/extra/chicago-talk/deploy.factor new file mode 100755 index 0000000000..8f8adc18d8 --- /dev/null +++ b/extra/chicago-talk/deploy.factor @@ -0,0 +1,12 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { deploy-name "Chicago Talk" } +} diff --git a/extra/chicago-talk/summary.txt b/extra/chicago-talk/summary.txt new file mode 100755 index 0000000000..229e1a363b --- /dev/null +++ b/extra/chicago-talk/summary.txt @@ -0,0 +1 @@ +Slides for a talk at the Pycon VM Summit, Chicago, IL, March 2009 diff --git a/extra/minneapolis-talk/deploy.factor b/extra/minneapolis-talk/deploy.factor index 2f7f79da9d..32b78a2c13 100755 --- a/extra/minneapolis-talk/deploy.factor +++ b/extra/minneapolis-talk/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { deploy-name "Catalyst Talk" } + { deploy-name "Minnesota Talk" } } diff --git a/extra/minneapolis-talk/summary.txt b/extra/minneapolis-talk/summary.txt index 7fcc7abc88..ef8d1bd5e3 100755 --- a/extra/minneapolis-talk/summary.txt +++ b/extra/minneapolis-talk/summary.txt @@ -1 +1 @@ -Slides for a talk at Ruby.mn, Minneapolis MN, January 2008 +Slides for a talk at Ruby.mn, Minneapolis, MN, January 2008 From fdb8c9da1a129b2efe2e1d65e9e9e62bc24289c2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 11:43:30 -0500 Subject: [PATCH 23/37] cleaning up html.parser --- extra/html/parser/parser.factor | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 61088d1b5e..63efa3fdb2 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables html.parser.state -html.parser.utils kernel make namespaces sequences +html.parser.utils kernel namespaces sequences unicode.case unicode.categories combinators.short-circuit quoting ; IN: html.parser @@ -30,17 +30,11 @@ SYMBOL: tagstack : make-tag ( string attribs -- tag ) [ [ closing-tag? ] keep "/" trim1 ] dip rot ; -: new-tag ( string type -- tag ) +: new-tag ( text name -- tag ) tag new swap >>name swap >>text ; inline -: make-text-tag ( string -- tag ) text new-tag ; inline - -: make-comment-tag ( string -- tag ) comment new-tag ; inline - -: make-dtd-tag ( string -- tag ) dtd new-tag ; inline - : read-single-quote ( state-parser -- string ) [ [ current CHAR: ' = ] take-until ] [ next drop ] bi ; @@ -68,10 +62,10 @@ SYMBOL: tagstack [ blank? ] trim ; : read-comment ( state-parser -- ) - "-->" take-until-sequence make-comment-tag push-tag ; + "-->" take-until-sequence comment new-tag push-tag ; : read-dtd ( state-parser -- ) - ">" take-until-sequence make-dtd-tag push-tag ; + ">" take-until-sequence dtd new-tag push-tag ; : read-bang ( state-parser -- ) next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& [ @@ -89,7 +83,7 @@ SYMBOL: tagstack [ current CHAR: < = ] take-until ; : parse-text ( state-parser -- ) - read-until-< [ make-text-tag push-tag ] unless-empty ; + read-until-< [ text new-tag push-tag ] unless-empty ; : (parse-attributes) ( state-parser -- ) skip-whitespace @@ -98,12 +92,12 @@ SYMBOL: tagstack ] [ [ [ read-key >lower ] [ read-= ] [ read-value ] tri - 2array , + swap set ] keep (parse-attributes) ] if ; : parse-attributes ( state-parser -- hashtable ) - [ (parse-attributes) ] { } make >hashtable ; + [ (parse-attributes) ] H{ } make-assoc ; : (parse-tag) ( string -- string' hashtable ) [ From d82b8ba4ebdeb3c948691ca4d7c1954da1086bd6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 11:48:44 -0500 Subject: [PATCH 24/37] more cleanup --- extra/html/parser/parser.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 63efa3fdb2..6d2e02cf1d 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -3,7 +3,7 @@ USING: accessors arrays hashtables html.parser.state html.parser.utils kernel namespaces sequences unicode.case unicode.categories combinators.short-circuit -quoting ; +quoting fry ; IN: html.parser @@ -19,7 +19,7 @@ SYMBOL: tagstack : closing-tag? ( string -- ? ) [ f ] - [ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ; + [ { [ first CHAR: / = ] [ peek CHAR: / = ] } 1|| ] if-empty ; : ( name attributes closing? -- tag ) tag new @@ -35,11 +35,14 @@ SYMBOL: tagstack swap >>name swap >>text ; inline +: (read-quote) ( state-parser ch -- string ) + '[ [ current _ = ] take-until ] [ next drop ] bi ; + : read-single-quote ( state-parser -- string ) - [ [ current CHAR: ' = ] take-until ] [ next drop ] bi ; + CHAR: ' (read-quote) ; : read-double-quote ( state-parser -- string ) - [ [ current CHAR: " = ] take-until ] [ next drop ] bi ; + CHAR: " (read-quote) ; : read-quote ( state-parser -- string ) dup get+increment CHAR: ' = From 7060a5905f89098f265afe0ffcf80b47ff743499 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 12:44:06 -0500 Subject: [PATCH 25/37] add take-sequence to state parser --- extra/html/parser/state/state-tests.factor | 18 ++++++++++ extra/html/parser/state/state.factor | 39 +++++++++++++--------- 2 files changed, 42 insertions(+), 15 deletions(-) diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor index 835b54d0d3..6766cfddc2 100644 --- a/extra/html/parser/state/state-tests.factor +++ b/extra/html/parser/state/state-tests.factor @@ -34,3 +34,21 @@ IN: html.parser.state.tests [ { 1 2 } ] [ { 1 2 3 4 } { 3 4 } take-until-sequence ] unit-test + +[ "ab" ] +[ "abcd" "ab" take-sequence ] unit-test + +[ f ] +[ "abcd" "lol" take-sequence ] unit-test + +[ "ab" ] +[ + "abcd" + [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi +] unit-test + +[ "" ] +[ "abcd" "" take-sequence ] unit-test + +[ "cd" ] +[ "abcd" [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 3f899446c0..85b0b0fbb9 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -12,32 +12,32 @@ TUPLE: state-parser sequence n ; swap >>sequence 0 >>n ; -: state-parser-nth ( n state -- char/f ) +: state-parser-nth ( n state-parser -- char/f ) sequence>> ?nth ; inline -: current ( state -- char/f ) +: current ( state-parser -- char/f ) [ n>> ] keep state-parser-nth ; inline -: previous ( state -- char/f ) +: previous ( state-parser -- char/f ) [ n>> 1 - ] keep state-parser-nth ; inline -: peek-next ( state -- char/f ) +: peek-next ( state-parser -- char/f ) [ n>> 1 + ] keep state-parser-nth ; inline -: next ( state -- state ) +: next ( state-parser -- state-parser ) [ 1 + ] change-n ; inline -: get+increment ( state -- char/f ) +: get+increment ( state-parser -- char/f ) [ current ] [ next drop ] bi ; inline -:: skip-until ( state quot: ( obj -- ? ) -- ) - state current [ - state quot call [ state next quot skip-until ] unless +:: skip-until ( state-parser quot: ( obj -- ? ) -- ) + state-parser current [ + state-parser quot call [ state-parser next quot skip-until ] unless ] when ; inline recursive -: state-parse-end? ( state -- ? ) peek-next not ; +: state-parse-end? ( state-parser -- ? ) peek-next not ; -: take-until ( state quot: ( obj -- ? ) -- sequence/f ) +: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f ) over state-parse-end? [ 2drop f ] [ @@ -46,9 +46,18 @@ TUPLE: state-parser sequence n ; [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq ] if ; inline -: take-while ( state quot: ( obj -- ? ) -- sequence/f ) +: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f ) [ not ] compose take-until ; inline +:: take-sequence ( state-parser sequence -- obj/f ) + state-parser [ n>> dup sequence length + ] [ sequence>> ] bi + sequence sequence= [ + sequence + state-parser [ sequence length + ] change-n drop + ] [ + f + ] if ; + :: take-until-sequence ( state-parser sequence -- sequence' ) sequence length :> growing state-parser @@ -60,13 +69,13 @@ TUPLE: state-parser sequence n ; growing length 1- - head state-parser next drop ; -: skip-whitespace ( state -- state ) +: skip-whitespace ( state-parser -- state-parser ) [ [ current blank? not ] take-until drop ] keep ; -: take-rest ( state -- sequence ) +: take-rest ( state-parser -- sequence ) [ drop f ] take-until ; inline -: take-until-object ( state obj -- sequence ) +: take-until-object ( state-parser obj -- sequence ) '[ current _ = ] take-until ; : state-parse ( sequence quot -- ) From 826d9f18c52fdab38164946a9a7de92f8177e458 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 12:44:38 -0500 Subject: [PATCH 26/37] fix parsing of attributes for nofollows --- extra/html/parser/parser-tests.factor | 13 +++++++++++++ extra/html/parser/parser.factor | 21 +++++++++------------ 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor index 9757f70a67..25251159b1 100644 --- a/extra/html/parser/parser-tests.factor +++ b/extra/html/parser/parser-tests.factor @@ -42,6 +42,19 @@ V{ } ] [ "" parse-html ] unit-test +[ +V{ + T{ tag f "a" + H{ + { "a" "pirsqd" } + { "foo" "bar" } + { "href" "http://factorcode.org/" } + { "baz" "quux" } + { "nofollow" f } + } f f } +} +] [ "" parse-html ] unit-test + [ V{ T{ tag f "html" H{ } f f } diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 6d2e02cf1d..317337073b 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -6,7 +6,6 @@ unicode.case unicode.categories combinators.short-circuit quoting fry ; IN: html.parser - TUPLE: tag name attributes text closing? ; SINGLETON: text @@ -52,7 +51,7 @@ SYMBOL: tagstack skip-whitespace [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ; -: read-= ( state-parser -- ) +: read-=1 ( state-parser -- ) skip-whitespace [ [ current CHAR: = = ] take-until drop ] [ next drop ] bi ; @@ -71,12 +70,8 @@ SYMBOL: tagstack ">" take-until-sequence dtd new-tag push-tag ; : read-bang ( state-parser -- ) - next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& [ - next next - read-comment - ] [ - read-dtd - ] if ; + next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& + [ next next read-comment ] [ read-dtd ] if ; : read-tag ( state-parser -- string ) [ [ current "><" member? ] take-until ] @@ -88,15 +83,17 @@ SYMBOL: tagstack : parse-text ( state-parser -- ) read-until-< [ text new-tag push-tag ] unless-empty ; +: parse-key/value ( state-parser -- key value ) + [ read-key >lower ] + [ skip-whitespace "=" take-sequence ] + [ swap [ read-value ] [ drop f ] if ] tri ; + : (parse-attributes) ( state-parser -- ) skip-whitespace dup state-parse-end? [ drop ] [ - [ - [ read-key >lower ] [ read-= ] [ read-value ] tri - swap set - ] keep (parse-attributes) + [ parse-key/value swap set ] [ (parse-attributes) ] bi ] if ; : parse-attributes ( state-parser -- hashtable ) From 9ecf8ec3db08d986ff26a93e59a7d696112df7cd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 12:47:17 -0500 Subject: [PATCH 27/37] remove dead code --- extra/html/parser/parser.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 317337073b..f95684ae15 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -51,10 +51,6 @@ SYMBOL: tagstack skip-whitespace [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ; -: read-=1 ( state-parser -- ) - skip-whitespace - [ [ current CHAR: = = ] take-until drop ] [ next drop ] bi ; - : read-token ( state-parser -- string ) [ current blank? ] take-until ; From 28dae46b7dffd39b3aa856110564a672d778fc99 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 12:48:51 -0500 Subject: [PATCH 28/37] make html.parser words private --- extra/html/parser/parser.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index f95684ae15..498691e2b2 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -11,6 +11,9 @@ TUPLE: tag name attributes text closing? ; SINGLETON: text SINGLETON: dtd SINGLETON: comment + + + : parse-html ( string -- vector ) [ (parse-html) tagstack get ] tag-parse ; From 09e4d34ff24c231ef1cea12ab2b736d666a10672 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 12:52:02 -0500 Subject: [PATCH 29/37] rename next to advance --- extra/html/parser/parser.factor | 10 +++++----- extra/html/parser/state/state.factor | 8 ++++---- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 498691e2b2..4aae6a25c4 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -38,7 +38,7 @@ SYMBOL: tagstack swap >>text ; inline : (read-quote) ( state-parser ch -- string ) - '[ [ current _ = ] take-until ] [ next drop ] bi ; + '[ [ current _ = ] take-until ] [ advance drop ] bi ; : read-single-quote ( state-parser -- string ) CHAR: ' (read-quote) ; @@ -69,12 +69,12 @@ SYMBOL: tagstack ">" take-until-sequence dtd new-tag push-tag ; : read-bang ( state-parser -- ) - next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& - [ next next read-comment ] [ read-dtd ] if ; + advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& + [ advance advance read-comment ] [ read-dtd ] if ; : read-tag ( state-parser -- string ) [ [ current "><" member? ] take-until ] - [ dup current CHAR: < = [ next ] unless drop ] bi ; + [ dup current CHAR: < = [ advance ] unless drop ] bi ; : read-until-< ( state-parser -- string ) [ current CHAR: < = ] take-until ; @@ -104,7 +104,7 @@ SYMBOL: tagstack ] state-parse ; : read-< ( state-parser -- string/f ) - next dup current [ + advance dup current [ CHAR: ! = [ read-bang f ] [ read-tag ] if ] [ drop f diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 85b0b0fbb9..4a050306e9 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -24,15 +24,15 @@ TUPLE: state-parser sequence n ; : peek-next ( state-parser -- char/f ) [ n>> 1 + ] keep state-parser-nth ; inline -: next ( state-parser -- state-parser ) +: advance ( state-parser -- state-parser ) [ 1 + ] change-n ; inline : get+increment ( state-parser -- char/f ) - [ current ] [ next drop ] bi ; inline + [ current ] [ advance drop ] bi ; inline :: skip-until ( state-parser quot: ( obj -- ? ) -- ) state-parser current [ - state-parser quot call [ state-parser next quot skip-until ] unless + state-parser quot call [ state-parser advance quot skip-until ] unless ] when ; inline recursive : state-parse-end? ( state-parser -- ? ) peek-next not ; @@ -67,7 +67,7 @@ TUPLE: state-parser sequence n ; ] take-until :> found found dup length growing length 1- - head - state-parser next drop ; + state-parser advance drop ; : skip-whitespace ( state-parser -- state-parser ) [ [ current blank? not ] take-until drop ] keep ; From d52535b63a71b216cac816cc87fe14db0ca57924 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 13:42:38 -0500 Subject: [PATCH 30/37] set non-key/value attributes to themselves --- extra/html/parser/parser-tests.factor | 2 +- extra/html/parser/parser.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor index 25251159b1..ca276fc54e 100644 --- a/extra/html/parser/parser-tests.factor +++ b/extra/html/parser/parser-tests.factor @@ -50,7 +50,7 @@ V{ { "foo" "bar" } { "href" "http://factorcode.org/" } { "baz" "quux" } - { "nofollow" f } + { "nofollow" "nofollow" } } f f } } ] [ "" parse-html ] unit-test diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 4aae6a25c4..61315a4925 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -85,7 +85,7 @@ SYMBOL: tagstack : parse-key/value ( state-parser -- key value ) [ read-key >lower ] [ skip-whitespace "=" take-sequence ] - [ swap [ read-value ] [ drop f ] if ] tri ; + [ swap [ read-value ] [ drop dup ] if ] tri ; : (parse-attributes) ( state-parser -- ) skip-whitespace From 1e4eebda3a5e82bcdf30ee5e30790f2c2161ca39 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 14:36:08 -0500 Subject: [PATCH 31/37] refactor state parser some more, add a word to parse escaped strings --- extra/html/parser/state/state-tests.factor | 14 +++++++++++ extra/html/parser/state/state.factor | 29 +++++++++++++++------- 2 files changed, 34 insertions(+), 9 deletions(-) diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor index 6766cfddc2..4e0d512e89 100644 --- a/extra/html/parser/state/state-tests.factor +++ b/extra/html/parser/state/state-tests.factor @@ -52,3 +52,17 @@ IN: html.parser.state.tests [ "cd" ] [ "abcd" [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test + + +[ f ] +[ + "\"abc\" asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi +] unit-test + +[ "asdf" ] +[ + "\"abc\" asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] + [ skip-whitespace "asdf" take-sequence ] bi +] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 4a050306e9..22e901a310 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math kernel sequences accessors fry circular -unicode.case unicode.categories locals ; +unicode.case unicode.categories locals combinators.short-circuit ; IN: html.parser.state @@ -12,21 +12,22 @@ TUPLE: state-parser sequence n ; swap >>sequence 0 >>n ; -: state-parser-nth ( n state-parser -- char/f ) - sequence>> ?nth ; inline +: offset ( state-parser offset -- char/f ) + swap + [ n>> + ] [ sequence>> ?nth ] bi ; inline -: current ( state-parser -- char/f ) - [ n>> ] keep state-parser-nth ; inline +: current ( state-parser -- char/f ) 0 offset ; inline -: previous ( state-parser -- char/f ) - [ n>> 1 - ] keep state-parser-nth ; inline +: previous ( state-parser -- char/f ) -1 offset ; inline -: peek-next ( state-parser -- char/f ) - [ n>> 1 + ] keep state-parser-nth ; inline +: peek-next ( state-parser -- char/f ) 1 offset ; inline : advance ( state-parser -- state-parser ) [ 1 + ] change-n ; inline +: advance* ( state-parser -- ) + advance drop ; inline + : get+increment ( state-parser -- char/f ) [ current ] [ advance drop ] bi ; inline @@ -80,3 +81,13 @@ TUPLE: state-parser sequence n ; : state-parse ( sequence quot -- ) [ ] dip call ; inline + +:: take-quoted-string ( state-parser escape-char quote-char -- string ) + state-parser advance + [ + { + [ { [ previous quote-char = ] [ current quote-char = ] } 1&& ] + [ current quote-char = not ] + } 1|| + ] take-while + state-parser advance* ; From 947bcc3d3323e9895a8b8ea187a8f1fcfbf08a80 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 14:50:43 -0500 Subject: [PATCH 32/37] state-parser take-quoted-string rewinds if the string is not found --- extra/html/parser/state/state-tests.factor | 13 +++++++++++++ extra/html/parser/state/state.factor | 9 +++++++-- 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor index 4e0d512e89..316fe31805 100644 --- a/extra/html/parser/state/state-tests.factor +++ b/extra/html/parser/state/state-tests.factor @@ -66,3 +66,16 @@ IN: html.parser.state.tests [ CHAR: \ CHAR: " take-quoted-string drop ] [ skip-whitespace "asdf" take-sequence ] bi ] unit-test + +[ f ] +[ + "\"abc asdf" + CHAR: \ CHAR: " take-quoted-string +] unit-test + +[ "\"abc" ] +[ + "\"abc asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] + [ "\"abc" take-sequence ] bi +] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 22e901a310..8a9084b91b 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -83,11 +83,16 @@ TUPLE: state-parser sequence n ; [ ] dip call ; inline :: take-quoted-string ( state-parser escape-char quote-char -- string ) + state-parser n>> :> start-n state-parser advance [ { [ { [ previous quote-char = ] [ current quote-char = ] } 1&& ] [ current quote-char = not ] } 1|| - ] take-while - state-parser advance* ; + ] take-while :> string + state-parser current quote-char = [ + state-parser advance* string + ] [ + start-n state-parser (>>n) f + ] if ; From 432ff9b07fbe4da2f23c8cabec4c2c4637df99c8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 1 Apr 2009 14:52:43 -0500 Subject: [PATCH 33/37] Make math.blas library and ABI choice configurable --- basis/alien/fortran/fortran-docs.factor | 8 +++---- basis/math/blas/config/config-docs.factor | 23 +++++++++++++++++++ basis/math/blas/config/config.factor | 23 +++++++++++++++++++ basis/math/blas/ffi/ffi.factor | 15 +++--------- basis/math/blas/matrices/matrices-docs.factor | 5 ++-- 5 files changed, 56 insertions(+), 18 deletions(-) create mode 100644 basis/math/blas/config/config-docs.factor create mode 100644 basis/math/blas/config/config.factor diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor index c5d124e198..8027020c75 100644 --- a/basis/alien/fortran/fortran-docs.factor +++ b/basis/alien/fortran/fortran-docs.factor @@ -7,10 +7,10 @@ IN: alien.fortran ARTICLE: "alien.fortran-abis" "Fortran ABIs" "Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:" { $list - { { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." } - { { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." } - { { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." } - { { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." } + { { $link gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." } + { { $link f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." } + { { $link intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." } + { { $link intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." } } "A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ; diff --git a/basis/math/blas/config/config-docs.factor b/basis/math/blas/config/config-docs.factor new file mode 100644 index 0000000000..60eaff25c2 --- /dev/null +++ b/basis/math/blas/config/config-docs.factor @@ -0,0 +1,23 @@ +USING: alien.fortran help.markup help.syntax math.blas.config multiline ; +IN: math.blas.config + +ARTICLE: "math.blas.config" "Configuring the BLAS interface" +"The " { $link "math.blas-summary" } " chooses the underlying BLAS interface to use based on the values of the following global variables:" +{ $subsection blas-library } +{ $subsection blas-fortran-abi } +"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:" +{ $code <" +USING: math.blas.config namespaces ; +"X:\\path\\to\\acml.dll" blas-library set-global +intel-windows-abi blas-fortran-abi set-global +"> } +"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded." +; + +HELP: blas-library +{ $description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ; + +HELP: blas-fortran-abi +{ $description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ; + +ABOUT: "math.blas.config" diff --git a/basis/math/blas/config/config.factor b/basis/math/blas/config/config.factor new file mode 100644 index 0000000000..8ed515625d --- /dev/null +++ b/basis/math/blas/config/config.factor @@ -0,0 +1,23 @@ +USING: alien.fortran combinators kernel namespaces system ; +IN: math.blas.config + +SYMBOLS: blas-library blas-fortran-abi ; + +blas-library [ + { + { [ os macosx? ] [ "libblas.dylib" ] } + { [ os windows? ] [ "blas.dll" ] } + [ "libblas.so" ] + } cond +] initialize + +blas-fortran-abi [ + { + { [ os macosx? ] [ intel-unix-abi ] } + { [ os windows? cpu x86.32? and ] [ f2c-abi ] } + { [ os windows? cpu x86.64? and ] [ gfortran-abi ] } + { [ os freebsd? ] [ gfortran-abi ] } + { [ os linux? cpu x86.32? and ] [ gfortran-abi ] } + [ f2c-abi ] + } cond +] initialize diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index bc98f72d8b..b7748f500f 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -1,18 +1,9 @@ -USING: alien alien.fortran kernel system combinators -alien.libraries ; +USING: alien.fortran kernel math.blas.config namespaces ; IN: math.blas.ffi << -"blas" { - { [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] } - { [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] } - { [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] } - { - [ os [ freebsd? ] [ linux? cpu x86.32? and ] bi or ] - [ "libblas.so" gfortran-abi add-fortran-library ] - } - [ "libblas.so" f2c-abi add-fortran-library ] -} cond +"blas" blas-library blas-fortran-abi [ get ] bi@ +add-fortran-library >> LIBRARY: blas diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index 17d2f9ccd1..5662cd9905 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -2,13 +2,14 @@ USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequence IN: math.blas.matrices ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" -"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:" +"Factor provides an interface to high-performance vector and matrix math routines available in implementations of the BLAS math library. A set of specialized types are provided for handling packed, unboxed vector data:" { $subsection "math.blas-types" } "Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:" { $subsection "math.blas.vectors" } "Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:" { $subsection "math.blas.matrices" } -"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ; +"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary. The BLAS interface can be configured to use different underlying BLAS implementations:" +{ $subsection "math.blas.config" } ; ARTICLE: "math.blas-types" "BLAS interface types" "BLAS vectors come in single- and double-precision, real and complex flavors:" From d64e07af8b2b3cd8243b8a4a818209215814e95f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 15:23:05 -0500 Subject: [PATCH 34/37] fix bug in state-parser, add take-token --- extra/html/parser/state/state-tests.factor | 3 +++ extra/html/parser/state/state.factor | 5 ++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor index 316fe31805..b7a929284b 100644 --- a/extra/html/parser/state/state-tests.factor +++ b/extra/html/parser/state/state-tests.factor @@ -79,3 +79,6 @@ IN: html.parser.state.tests [ CHAR: \ CHAR: " take-quoted-string drop ] [ "\"abc" take-sequence ] bi ] unit-test + +[ "c" ] +[ "c" take-token ] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 8a9084b91b..1b83089c98 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -36,7 +36,7 @@ TUPLE: state-parser sequence n ; state-parser quot call [ state-parser advance quot skip-until ] unless ] when ; inline recursive -: state-parse-end? ( state-parser -- ? ) peek-next not ; +: state-parse-end? ( state-parser -- ? ) current not ; : take-until ( state-parser quot: ( obj -- ? ) -- sequence/f ) over state-parse-end? [ @@ -96,3 +96,6 @@ TUPLE: state-parser sequence n ; ] [ start-n state-parser (>>n) f ] if ; + +: take-token ( state-parser -- string ) + skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ; From 6af6de1aacaa7b39c95c9d192a11fe29fb64c7bc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 15:51:39 -0500 Subject: [PATCH 35/37] make tokenize-line configurable, fix bug in take-quoted-string --- extra/html/parser/state/state-tests.factor | 10 +++++++++- extra/html/parser/state/state.factor | 19 +++++++++++++++++-- 2 files changed, 26 insertions(+), 3 deletions(-) diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor index b7a929284b..e655dbb699 100644 --- a/extra/html/parser/state/state-tests.factor +++ b/extra/html/parser/state/state-tests.factor @@ -53,13 +53,18 @@ IN: html.parser.state.tests [ "cd" ] [ "abcd" [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test - [ f ] [ "\"abc\" asdf" [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi ] unit-test +[ "abc\\\"def" ] +[ + "\"abc\\\"def\" asdf" + CHAR: \ CHAR: " take-quoted-string +] unit-test + [ "asdf" ] [ "\"abc\" asdf" @@ -82,3 +87,6 @@ IN: html.parser.state.tests [ "c" ] [ "c" take-token ] unit-test + +[ { "a" "b" "c" "abcd e \\\"f g" } ] +[ "a b c \"abcd e \\\"f g\"" CHAR: \ CHAR: " tokenize-line ] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 1b83089c98..6cca9f72a9 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math kernel sequences accessors fry circular -unicode.case unicode.categories locals combinators.short-circuit ; +unicode.case unicode.categories locals combinators.short-circuit +make combinators ; IN: html.parser.state @@ -87,7 +88,7 @@ TUPLE: state-parser sequence n ; state-parser advance [ { - [ { [ previous quote-char = ] [ current quote-char = ] } 1&& ] + [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ] [ current quote-char = not ] } 1|| ] take-while :> string @@ -99,3 +100,17 @@ TUPLE: state-parser sequence n ; : take-token ( state-parser -- string ) skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ; + +:: (tokenize-line) ( state-parser escape-char quote-char -- ) + state-parser skip-whitespace + dup current { + { quote-char [ + [ escape-char quote-char take-quoted-string , ] + [ escape-char quote-char (tokenize-line) ] bi + ] } + { f [ drop ] } + [ drop [ take-token , ] [ escape-char quote-char (tokenize-line) ] bi ] + } case ; + +: tokenize-line ( line escape-char quote-char -- seq ) + [ ] 2dip [ (tokenize-line) ] { } make ; From 7b6260ca8c8471e20d30a6bffa760cc93f9e0461 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 17:28:36 -0500 Subject: [PATCH 36/37] remove tokenize-line --- extra/html/parser/state/state-tests.factor | 7 +++++-- extra/html/parser/state/state.factor | 17 +++++++---------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor index e655dbb699..63916a3c1c 100644 --- a/extra/html/parser/state/state-tests.factor +++ b/extra/html/parser/state/state-tests.factor @@ -88,5 +88,8 @@ IN: html.parser.state.tests [ "c" ] [ "c" take-token ] unit-test -[ { "a" "b" "c" "abcd e \\\"f g" } ] -[ "a b c \"abcd e \\\"f g\"" CHAR: \ CHAR: " tokenize-line ] unit-test +[ f ] +[ "" take-token ] unit-test + +[ "abcd e \\\"f g" ] +[ "\"abcd e \\\"f g\"" CHAR: \ CHAR: " take-token* ] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 6cca9f72a9..86adb0f914 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -98,19 +98,16 @@ TUPLE: state-parser sequence n ; start-n state-parser (>>n) f ] if ; -: take-token ( state-parser -- string ) +: (take-token) ( state-parser -- string ) skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ; -:: (tokenize-line) ( state-parser escape-char quote-char -- ) +:: take-token* ( state-parser escape-char quote-char -- string/f ) state-parser skip-whitespace dup current { - { quote-char [ - [ escape-char quote-char take-quoted-string , ] - [ escape-char quote-char (tokenize-line) ] bi - ] } - { f [ drop ] } - [ drop [ take-token , ] [ escape-char quote-char (tokenize-line) ] bi ] + { quote-char [ escape-char quote-char take-quoted-string ] } + { f [ drop f ] } + [ drop (take-token) ] } case ; -: tokenize-line ( line escape-char quote-char -- seq ) - [ ] 2dip [ (tokenize-line) ] { } make ; +: take-token ( state-parser -- string/f ) + CHAR: \ CHAR: " take-token* ; From 1b0c301005c9ddedec40cf6cef362d88ff4b0e33 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Apr 2009 17:29:58 -0500 Subject: [PATCH 37/37] move assoc-heaps to extra --- {basis => extra}/assoc-heaps/assoc-heaps-docs.factor | 0 {basis => extra}/assoc-heaps/assoc-heaps-tests.factor | 0 {basis => extra}/assoc-heaps/assoc-heaps.factor | 0 {basis => extra}/assoc-heaps/authors.txt | 0 {basis => extra}/assoc-heaps/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {basis => extra}/assoc-heaps/assoc-heaps-docs.factor (100%) rename {basis => extra}/assoc-heaps/assoc-heaps-tests.factor (100%) rename {basis => extra}/assoc-heaps/assoc-heaps.factor (100%) rename {basis => extra}/assoc-heaps/authors.txt (100%) rename {basis => extra}/assoc-heaps/summary.txt (100%) diff --git a/basis/assoc-heaps/assoc-heaps-docs.factor b/extra/assoc-heaps/assoc-heaps-docs.factor similarity index 100% rename from basis/assoc-heaps/assoc-heaps-docs.factor rename to extra/assoc-heaps/assoc-heaps-docs.factor diff --git a/basis/assoc-heaps/assoc-heaps-tests.factor b/extra/assoc-heaps/assoc-heaps-tests.factor similarity index 100% rename from basis/assoc-heaps/assoc-heaps-tests.factor rename to extra/assoc-heaps/assoc-heaps-tests.factor diff --git a/basis/assoc-heaps/assoc-heaps.factor b/extra/assoc-heaps/assoc-heaps.factor similarity index 100% rename from basis/assoc-heaps/assoc-heaps.factor rename to extra/assoc-heaps/assoc-heaps.factor diff --git a/basis/assoc-heaps/authors.txt b/extra/assoc-heaps/authors.txt similarity index 100% rename from basis/assoc-heaps/authors.txt rename to extra/assoc-heaps/authors.txt diff --git a/basis/assoc-heaps/summary.txt b/extra/assoc-heaps/summary.txt similarity index 100% rename from basis/assoc-heaps/summary.txt rename to extra/assoc-heaps/summary.txt