steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

smalltalk: adding a small library, fix various bugs

db4
Slava Pestov 2009-03-30 20:45:01 -05:00
parent 00c9cde8e2
commit 381dbb957c
12 changed files with 343 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
extra/smalltalk/compiler/compiler-tests.factor
View File

@ -3,8 +3,15 @@ stack-checker locals.rewrite.closures kernel accessors
compiler.units sequences ;
IN: smalltalk.compiler.tests
[ 2 1 ] [
: test-compilation ( ast -- quot )
[
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" }
{
@ -14,20 +21,17 @@ IN: smalltalk.compiler.tests
{ 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 "asmal" }
"+"
{ T{ ast-name f "b" } }
}
@ -39,7 +43,42 @@ IN: smalltalk.compiler.tests
}
T{ ast-return f T{ ast-name f "c" } }
}
} compile-method
[ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
] with-compilation-unit
} 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

45
extra/smalltalk/compiler/compiler.factor
View File

@ -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
<lambda> '[ @ ] ;
<lambda> '[ _ ] ;
: compile-method ( block -- quot )
[ [ empty-lexenv ] dip compile-ast ] [ arguments>> length ] [ need-return-continuation? ] tri
[ [ 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 ;

10
extra/smalltalk/compiler/lexenv/lexenv.factor
View File

@ -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> lexenv
: <lexenv> ( local-readers local-writers -- lexenv )
f f f lexenv boa ; inline
CONSTANT: empty-lexenv T{ lexenv }

1
extra/smalltalk/library/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

75
extra/smalltalk/library/library.factor Normal file
View File

@ -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 ) ;

1
extra/smalltalk/listener/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

18
extra/smalltalk/listener/listener.factor Normal file
View File

@ -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

77
extra/smalltalk/parser/parser-tests.factor
View File

@ -53,6 +53,21 @@ test = <foreign parse-smalltalk Literal>
[ 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
@ -86,6 +101,24 @@ test = <foreign parse-smalltalk Expression>
]
[ "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 = <foreign parse-smalltalk Expression>
}
]
[ "(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>

19
extra/smalltalk/parser/parser.factor
View File

@ -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
@ -201,3 +204,13 @@ End = !(.)
Program = ClassDeclaration* End
;EBNF
EBNF: parse-smalltalk-statement
Statement = <foreign parse-smalltalk Statement>
End = !(.)
Program = Statement? => [[ nil or ]] End
;EBNF

1
extra/smalltalk/printer/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

34
extra/smalltalk/printer/printer.factor Normal file
View File

@ -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 ;

6
extra/smalltalk/selectors/selectors.factor
View File

@ -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 ;