Fixing up smalltalk to the point where it can run fib, slowly

diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index e9759b21975b2066063d26548f3860f80ca74b01..fc415aa3611c77c129b80bdf46147018eb43ced6 100644 (file)
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -45,5 +45,9 @@ M: ast-sequence arguments>> drop { } ;
     [ ast-cascade boa ]
     if ;
 
+! Methods return self by default
+: <ast-method> ( class arguments body -- method )
+    self suffix <ast-block> ast-method boa ;
+
 TUPLE: symbol { name string } ;
 MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file

diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index e61b44ffaea34fde05f289c4832f1b2df5756d76..0b6f17e3fafb026aa475b59507ab763d14a5b926 100644 (file)
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -21,11 +21,22 @@ M: ast-name compile-ast name>> swap lookup-reader ;
 : compile-arguments ( lexenv ast -- quot )
     arguments>> [ compile-ast ] with map [ ] join ;
 
-M: ast-message-send compile-ast
-    [ compile-arguments ]
+: compile-ifTrue:ifFalse: ( lexenv ast -- quot )
     [ receiver>> compile-ast ]
-    [ nip selector>> selector>generic ]
-    2tri [ append ] dip suffix ;
+    [ compile-arguments ] 2bi
+    [ 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
     [ receiver>> compile-ast ]
@@ -40,8 +51,8 @@ M: ast-cascade compile-ast
     ] 2bi append ;
 
 M: ast-return compile-ast
-    value>> compile-ast
-    [ return-continuation get continue-with ] append ;
+    [ value>> compile-ast ] [ drop return>> 1quotation ] 2bi
+    [ continue-with ] 3append ;
 
 : (compile-sequence) ( lexenv asts -- quot )
     [ drop [ nil ] ] [
@@ -106,7 +117,7 @@ M: ast-block compile-ast
     [ lexenv self>> suffix ] dip <lambda> ;
 
 : compile-method-body ( lexenv block -- quot )
-    [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep
+    [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] 2keep
     make-return ;
 
 : compile-method ( lexenv ast-method -- )
@@ -115,7 +126,7 @@ M: ast-block compile-ast
     2bi define ;
 
 : <class-lexenv> ( class -- lexenv )
-    <lexenv> swap >>class "self" <local-reader> >>self ;
+    <lexenv> swap >>class "self" <local> >>self "^" <local> >>return ;
 
 M: ast-class compile-ast
     nip
@@ -136,5 +147,5 @@ M: ast-foreign compile-ast
     [ nil ] ;
 
 : compile-smalltalk ( statement -- quot )
-    [ [ empty-lexenv ] dip compile-sequence nip 0 ]
-    keep make-return ;
\ No newline at end of file
+    [ empty-lexenv ] dip [ compile-sequence nip 0 ]
+    2keep make-return ;
\ No newline at end of file

diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index 6b6d2837610f156e9e96f87da9682aca7fcab512..cd06314fd9dcf3c818101962113aa5fbbbfe69f4 100644 (file)
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -10,7 +10,7 @@ IN: smalltalk.compiler.lexenv
 ! 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 ;
+TUPLE: lexenv local-readers local-writers self return class method ;
 
 : <lexenv> ( -- lexenv ) lexenv new ; inline
 
@@ -21,6 +21,7 @@ CONSTANT: empty-lexenv T{ lexenv }
         [ [ local-readers>> ] bi@ assoc-union >>local-readers ]
         [ [ local-writers>> ] bi@ assoc-union >>local-writers ]
         [ [ self>> ] either? >>self ]
+        [ [ return>> ] either? >>return ]
         [ [ class>> ] either? >>class ]
         [ [ method>> ] either? >>method ]
     } 2cleave ;

diff --git a/extra/smalltalk/compiler/return/return-tests.factor b/extra/smalltalk/compiler/return/return-tests.factor
new file mode 100644 (file)
index 0000000..15a3406
--- /dev/null
+++ b/extra/smalltalk/compiler/return/return-tests.factor
@@ -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
\ No newline at end of file

diff --git a/extra/smalltalk/compiler/return/return.factor b/extra/smalltalk/compiler/return/return.factor
index 31b4a1511b24f48c58683a58d0e988994cf78ba6..8c36bdac64eb1bc1ef1e2fa79f8d81ecf6023ea9 100644 (file)
--- a/extra/smalltalk/compiler/return/return.factor
+++ b/extra/smalltalk/compiler/return/return.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators.short-circuit continuations
-fry generalizations kernel locals.rewrite.closures namespaces
-sequences smalltalk.ast ;
+fry generalizations kernel locals locals.types locals.rewrite.closures
+namespaces make sequences smalltalk.ast ;
 IN: smalltalk.compiler.return
 
 SYMBOL: return-continuation
@@ -17,13 +17,13 @@ M: ast-message-send need-return-continuation?
     {
         [ receiver>> need-return-continuation? ]
         [ arguments>> need-return-continuation? ]
-    } 1&& ;
+    } 1|| ;
 
 M: ast-cascade need-return-continuation?
     {
         [ receiver>> need-return-continuation? ]
         [ messages>> need-return-continuation? ]
-    } 1&& ;
+    } 1|| ;
 
 M: ast-message 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 ;
 
-: make-return ( quot n block -- quot )
-    need-return-continuation? [
-        '[
-            [
-                _ _ ncurry
-                [ return-continuation set ] prepose callcc1
-            ] with-scope
-        ]
-    ] [ drop ] if
-    rewrite-closures first ;
\ No newline at end of file
+:: make-return ( quot n lexenv block -- quot )
+    block need-return-continuation? [
+        quot clone [ lexenv return>> <def> '[ _ ] prepend ] change-body
+        n '[ _ _ ncurry callcc1 ]
+    ] [ quot ] if rewrite-closures first ;
\ No newline at end of file

diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
index 8a7756054a5c8fdd5f50775fa94a42a731b15e7d..95366d65b918d79f42ab42098dc5e8482f701d63 100644 (file)
--- a/extra/smalltalk/eval/eval-tests.factor
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -1,5 +1,5 @@
 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
 [ "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
 [ 5 ] [ "|x| x:=5. x" 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
\ No newline at end of file

diff --git a/extra/smalltalk/eval/fib.st b/extra/smalltalk/eval/fib.st
new file mode 100644 (file)
index 0000000..41ab8f5
--- /dev/null
+++ b/extra/smalltalk/eval/fib.st
@@ -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
\ No newline at end of file

diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index ff9cbc208b7b39ed92484a3c6d45ffad254adc55..9027290e6a26816e5afab06478c5c0082d0b60c4 100644 (file)
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -1,5 +1,6 @@
 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 ;
 
 EBNF: test-Character
@@ -296,4 +297,4 @@ test         = <foreign parse-smalltalk LocalVariableDeclarationList>
 
 [ ] [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test
 
-[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
+[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
\ No newline at end of file

diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index 1958861606b8a3d3aa79fd28250c68702a8d1647..c7cafe94ddc741c3484273672b4f2445c5cd18b5 100644 (file)
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -200,7 +200,7 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:
         OptionalWhiteSpace "["
         ExecutableCode:code
         "]"
-        => [[ header first2 code <ast-block> ast-method boa ]]
+        => [[ header first2 code <ast-method> ]]
 
 ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
         OptionalWhiteSpace