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" } }
+ }
+ }
+ T{ ast-message-send f
+ T{ ast-name f "b" }
+ "blah:"
+ { 123.456 }
}
- } compile-method
- [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
- ] with-compilation-unit
+ 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
! 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
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 )
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 )
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 ;
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
bi-curry* bi
append
] if-empty
- <lambda> '[ @ ] ;
+ <lambda> '[ _ ] ;
: 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 ;
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> lexenv
+: <lexenv> ( local-readers local-writers -- lexenv )
+ f f f lexenv boa ; inline
CONSTANT: empty-lexenv T{ lexenv }
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ) ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
[ 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 = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
;EBNF
]
[ "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
}
]
[ "(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 = <foreign parse-smalltalk FinalStatement>
;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 = <foreign parse-smalltalk LocalVariableDeclarationList>
| 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 ]]
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
End = !(.)
Program = ClassDeclaration* End
+;EBNF
+
+EBNF: parse-smalltalk-statement
+
+Statement = <foreign parse-smalltalk Statement>
+
+End = !(.)
+
+Program = Statement? => [[ nil or ]] End
+
;EBNF
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
! 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 ;
[ "selector-" prepend "smalltalk.selectors" create dup ]
[ selector>effect ]
bi define-simple-generic ;
+
+SYNTAX: SELECTOR: scan selector>generic drop ;
\ No newline at end of file
projects / factor.git / commitdiff