! 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 } ;
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 ;
+
+: <ast-block> ( arguments body -- block )
+ unclip-temporaries ast-block boa ;
+
+: <ast-sequence> ( 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
: <ast-cascade> ( receiver messages -- ast )
dup length 1 =
[ first [ selector>> ] [ arguments>> ] bi ast-message-send boa ]
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 ;
[ 0 1 ] [
T{ ast-block f
+ { }
{ }
{
T{ ast-message-send
[ "a" ] [
T{ ast-block f
+ { }
{ }
{ { T{ ast-block { body { "a" } } } } }
} test-compilation call first call
! 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 ;
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?
+ [ <local-reader> ]
+ [ <local> ]
+ if
+ ] H{ } map>assoc
+ dup
+ [ nip local-reader? ] assoc-filter
+ [ <local-writer> ] assoc-map
+ <lexenv> 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
+ [ <def> [ 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 -- ? )
M: ast-assignment compile-ast
[ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
-: block-lexenv ( block -- lexenv )
- [ arguments>> ] [ body>> [ assigned-locals ] map concat unique ] bi
- '[
- dup dup _ key?
- [ <local-reader> ]
- [ <local> ]
- if
- ] { } map>assoc
- dup
- [ nip local-reader? ] assoc-filter
- [ <local-writer> ] assoc-map
- <lexenv> 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 <lambda> '[ _ ] ;
-
-: 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 )
+ compile-sequence <lambda> '[ _ ] ;
-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 <lambda> ;
+:: (compile-method-body) ( lexenv block -- lambda )
+ lexenv block compile-sequence
+ [ lexenv self>> suffix ] dip <lambda> ;
: compile-method-body ( lexenv block -- quot )
[ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep
: <class-lexenv> ( class -- lexenv )
<lexenv> swap >>class "self" <local-reader> >>self ;
-M: ast-class compile-smalltalk ( ast-class -- quot )
+M: ast-class compile-ast
+ nip
[
[ name>> ] [ superclass>> ] [ ivars>> ] tri
define-class <class-lexenv>
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
[ 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
! 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 ;
! 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
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: *
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:
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:
! 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 -- )
[ 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
]
[ "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 } }
[ T{ ast-local-variables f { "i" "j" } } ] [ " | i j |" test-LocalVariableDeclarationList ] unit-test
-EBNF: test-MessageSend
-test = <foreign parse-smalltalk MessageSend>
-;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
{ 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" }
[ "class Test [|a|]" parse-smalltalk ] unit-test
[
- T{ ast-sequence f
+ T{ ast-sequence f { }
{
T{ ast-class
{ name "Test1" }
=> [[ args ]]
)?:args
ExecutableCode:body
- "]" => [[ args >array body ast-block boa ]]
+ "]" => [[ args >array body <ast-block> ]]
Literal = (ConstantReference
| FloatingPointLiteral
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 } ]]
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 <ast-cascade> ]]
-BinaryMessageSend = (MessageSend | Operand):lhs
- Message:h
+BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+ BinaryMessage:h
(OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
=> [[ lhs t h prefix >array <ast-cascade> ]]
(OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
=> [[ lhs t h prefix >array <ast-cascade> ]]
-MessageSend = BinaryMessageSend | UnaryMessageSend | KeywordMessageSend
-
Expression = OptionalWhiteSpace
- (MessageSend | Operand):e
+ (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
=> [[ e ]]
AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
=> [[ t h prefix ]]
)?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
+EndStatement = "."
+
ExecutableCode = (LocalVariableDeclarationList)?:locals
- ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h
- FinalStatement:t (".")? => [[ h t suffix ]])?:body
+ (Statement:s OptionalWhiteSpace EndStatement => [[ s ]])*:h
+ (FinalStatement:t (EndStatement)? => [[ t ]])?:t
OptionalWhiteSpace
- => [[ body locals [ suffix ] when* >array ]]
+ => [[ h t [ suffix ] when* locals [ prefix ] when* >array ]]
-TopLevelForm = ExecutableCode => [[ ast-sequence boa ]]
+TopLevelForm = ExecutableCode => [[ <ast-sequence> ]]
UnaryMethodHeader = UnaryMessageSelector:selector
=> [[ { selector { } } ]]
OptionalWhiteSpace "["
ExecutableCode:code
"]"
- => [[ header first2 code ast-block boa ast-method boa ]]
+ => [[ header first2 code <ast-block> ast-method boa ]]
ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
OptionalWhiteSpace
(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 "]"
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.
^''
].
]
].
-Tests binarytrees
projects / factor.git / commitdiff