From 381dbb957c44f8f17cd975329b1ca6f0277cc5dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 30 Mar 2009 20:45:01 -0500 Subject: [PATCH] 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