Fixing up smalltalk to the point where it can run fib, slowly
parent
8ab7328899
commit
3885ba02a6
extra/smalltalk
ast
compiler
|
@ -45,5 +45,9 @@ M: ast-sequence arguments>> drop { } ;
|
||||||
[ ast-cascade boa ]
|
[ ast-cascade boa ]
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
|
! Methods return self by default
|
||||||
|
: <ast-method> ( class arguments body -- method )
|
||||||
|
self suffix <ast-block> ast-method boa ;
|
||||||
|
|
||||||
TUPLE: symbol { name string } ;
|
TUPLE: symbol { name string } ;
|
||||||
MEMO: intern ( name -- symbol ) symbol boa ;
|
MEMO: intern ( name -- symbol ) symbol boa ;
|
|
@ -21,11 +21,22 @@ M: ast-name compile-ast name>> swap lookup-reader ;
|
||||||
: compile-arguments ( lexenv ast -- quot )
|
: compile-arguments ( lexenv ast -- quot )
|
||||||
arguments>> [ compile-ast ] with map [ ] join ;
|
arguments>> [ compile-ast ] with map [ ] join ;
|
||||||
|
|
||||||
M: ast-message-send compile-ast
|
: compile-ifTrue:ifFalse: ( lexenv ast -- quot )
|
||||||
[ compile-arguments ]
|
|
||||||
[ receiver>> compile-ast ]
|
[ receiver>> compile-ast ]
|
||||||
[ nip selector>> selector>generic ]
|
[ compile-arguments ] 2bi
|
||||||
2tri [ append ] dip suffix ;
|
[ 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
|
M: ast-cascade compile-ast
|
||||||
[ receiver>> compile-ast ]
|
[ receiver>> compile-ast ]
|
||||||
|
@ -40,8 +51,8 @@ M: ast-cascade compile-ast
|
||||||
] 2bi append ;
|
] 2bi append ;
|
||||||
|
|
||||||
M: ast-return compile-ast
|
M: ast-return compile-ast
|
||||||
value>> compile-ast
|
[ value>> compile-ast ] [ drop return>> 1quotation ] 2bi
|
||||||
[ return-continuation get continue-with ] append ;
|
[ continue-with ] 3append ;
|
||||||
|
|
||||||
: (compile-sequence) ( lexenv asts -- quot )
|
: (compile-sequence) ( lexenv asts -- quot )
|
||||||
[ drop [ nil ] ] [
|
[ drop [ nil ] ] [
|
||||||
|
@ -106,7 +117,7 @@ M: ast-block compile-ast
|
||||||
[ lexenv self>> suffix ] dip <lambda> ;
|
[ lexenv self>> suffix ] dip <lambda> ;
|
||||||
|
|
||||||
: compile-method-body ( lexenv block -- quot )
|
: compile-method-body ( lexenv block -- quot )
|
||||||
[ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep
|
[ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] 2keep
|
||||||
make-return ;
|
make-return ;
|
||||||
|
|
||||||
: compile-method ( lexenv ast-method -- )
|
: compile-method ( lexenv ast-method -- )
|
||||||
|
@ -115,7 +126,7 @@ M: ast-block compile-ast
|
||||||
2bi define ;
|
2bi define ;
|
||||||
|
|
||||||
: <class-lexenv> ( class -- lexenv )
|
: <class-lexenv> ( class -- lexenv )
|
||||||
<lexenv> swap >>class "self" <local-reader> >>self ;
|
<lexenv> swap >>class "self" <local> >>self "^" <local> >>return ;
|
||||||
|
|
||||||
M: ast-class compile-ast
|
M: ast-class compile-ast
|
||||||
nip
|
nip
|
||||||
|
@ -136,5 +147,5 @@ M: ast-foreign compile-ast
|
||||||
[ nil ] ;
|
[ nil ] ;
|
||||||
|
|
||||||
: compile-smalltalk ( statement -- quot )
|
: compile-smalltalk ( statement -- quot )
|
||||||
[ [ empty-lexenv ] dip compile-sequence nip 0 ]
|
[ empty-lexenv ] dip [ compile-sequence nip 0 ]
|
||||||
keep make-return ;
|
2keep make-return ;
|
|
@ -10,7 +10,7 @@ IN: smalltalk.compiler.lexenv
|
||||||
! self: word or f for top-level forms
|
! self: word or f for top-level forms
|
||||||
! class: class 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
|
! 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 ) lexenv new ; inline
|
: <lexenv> ( -- lexenv ) lexenv new ; inline
|
||||||
|
|
||||||
|
@ -21,6 +21,7 @@ CONSTANT: empty-lexenv T{ lexenv }
|
||||||
[ [ local-readers>> ] bi@ assoc-union >>local-readers ]
|
[ [ local-readers>> ] bi@ assoc-union >>local-readers ]
|
||||||
[ [ local-writers>> ] bi@ assoc-union >>local-writers ]
|
[ [ local-writers>> ] bi@ assoc-union >>local-writers ]
|
||||||
[ [ self>> ] either? >>self ]
|
[ [ self>> ] either? >>self ]
|
||||||
|
[ [ return>> ] either? >>return ]
|
||||||
[ [ class>> ] either? >>class ]
|
[ [ class>> ] either? >>class ]
|
||||||
[ [ method>> ] either? >>method ]
|
[ [ method>> ] either? >>method ]
|
||||||
} 2cleave ;
|
} 2cleave ;
|
||||||
|
|
|
@ -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
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays combinators.short-circuit continuations
|
USING: accessors arrays combinators.short-circuit continuations
|
||||||
fry generalizations kernel locals.rewrite.closures namespaces
|
fry generalizations kernel locals locals.types locals.rewrite.closures
|
||||||
sequences smalltalk.ast ;
|
namespaces make sequences smalltalk.ast ;
|
||||||
IN: smalltalk.compiler.return
|
IN: smalltalk.compiler.return
|
||||||
|
|
||||||
SYMBOL: return-continuation
|
SYMBOL: return-continuation
|
||||||
|
@ -17,13 +17,13 @@ M: ast-message-send need-return-continuation?
|
||||||
{
|
{
|
||||||
[ receiver>> need-return-continuation? ]
|
[ receiver>> need-return-continuation? ]
|
||||||
[ arguments>> need-return-continuation? ]
|
[ arguments>> need-return-continuation? ]
|
||||||
} 1&& ;
|
} 1|| ;
|
||||||
|
|
||||||
M: ast-cascade need-return-continuation?
|
M: ast-cascade need-return-continuation?
|
||||||
{
|
{
|
||||||
[ receiver>> need-return-continuation? ]
|
[ receiver>> need-return-continuation? ]
|
||||||
[ messages>> need-return-continuation? ]
|
[ messages>> need-return-continuation? ]
|
||||||
} 1&& ;
|
} 1|| ;
|
||||||
|
|
||||||
M: ast-message need-return-continuation?
|
M: ast-message need-return-continuation?
|
||||||
arguments>> 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 ;
|
M: object need-return-continuation? drop f ;
|
||||||
|
|
||||||
: make-return ( quot n block -- quot )
|
:: make-return ( quot n lexenv block -- quot )
|
||||||
need-return-continuation? [
|
block need-return-continuation? [
|
||||||
'[
|
quot clone [ lexenv return>> <def> '[ _ ] prepend ] change-body
|
||||||
[
|
n '[ _ _ ncurry callcc1 ]
|
||||||
_ _ ncurry
|
] [ quot ] if rewrite-closures first ;
|
||||||
[ return-continuation set ] prepose callcc1
|
|
||||||
] with-scope
|
|
||||||
]
|
|
||||||
] [ drop ] if
|
|
||||||
rewrite-closures first ;
|
|
|
@ -1,5 +1,5 @@
|
||||||
IN: smalltalk.eval.tests
|
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
|
[ 3 ] [ "1+2" eval-smalltalk ] unit-test
|
||||||
[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" 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
|
[ 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
|
[ 5 ] [ "|x| x:=5. x" eval-smalltalk ] unit-test
|
||||||
[ 11 ] [ "[:i| |x| x:=5. i+x] value: 6" 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
|
|
@ -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
|
|
@ -1,5 +1,6 @@
|
||||||
IN: smalltalk.parser.tests
|
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 ;
|
io.files io.encodings.ascii kernel ;
|
||||||
|
|
||||||
EBNF: test-Character
|
EBNF: test-Character
|
||||||
|
|
|
@ -200,7 +200,7 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:
|
||||||
OptionalWhiteSpace "["
|
OptionalWhiteSpace "["
|
||||||
ExecutableCode:code
|
ExecutableCode:code
|
||||||
"]"
|
"]"
|
||||||
=> [[ header first2 code <ast-block> ast-method boa ]]
|
=> [[ header first2 code <ast-method> ]]
|
||||||
|
|
||||||
ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
|
ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
|
||||||
OptionalWhiteSpace
|
OptionalWhiteSpace
|
||||||
|
|
Loading…
Reference in New Issue