factor: trim using lists

[factor.git] / extra / smalltalk / compiler / compiler.factor

diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index e61b44ffaea34fde05f289c4832f1b2df5756d76..88e0f8a1199de071a5a2a1703c9064909ba5faed 100644 (file)
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -1,11 +1,10 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! 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 splitting math
-locals.rewrite.closures generic words combinators locals smalltalk.ast
-smalltalk.compiler.lexenv smalltalk.compiler.assignment
-smalltalk.compiler.return smalltalk.selectors smalltalk.classes ;
+USING: accessors arrays assocs combinators continuations
+generic kernel locals.types math quotations sequences
+sequences.generalizations sets smalltalk.ast smalltalk.classes
+smalltalk.compiler.assignment smalltalk.compiler.lexenv
+smalltalk.compiler.return smalltalk.selectors splitting words ;
 IN: smalltalk.compiler
 
 GENERIC: compile-ast ( lexenv ast -- quot )
@@ -21,11 +20,28 @@ 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-new ( lexenv ast -- quot )
+    [ receiver>> compile-ast ]
+    [ compile-arguments ] 2bi
+    [ new ] 3append ;
+
+: 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: ] }
+        { "new" [ compile-new ] }
+        [
+            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 +56,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 ] ] [
@@ -50,12 +66,9 @@ M: ast-return compile-ast
 
 : block-lexenv ( block -- lexenv )
     [ [ arguments>> ] [ temporaries>> ] bi append ]
-    [ body>> [ assigned-locals ] map concat unique ] bi
+    [ body>> [ assigned-locals ] map concat fast-set ] bi
     '[
-        dup dup _ key?
-        [ <local-reader> ]
-        [ <local> ]
-        if
+        dup dup _ in? [ <local-reader> ] [ <local> ] if
     ] H{ } map>assoc
     dup
     [ nip local-reader? ] assoc-filter
@@ -106,7 +119,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,13 +128,13 @@ 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
     [
         [ name>> ] [ superclass>> ] [ ivars>> ] tri
-        define-class <class-lexenv> 
+        define-class <class-lexenv>
     ]
     [ methods>> ] bi
     [ compile-method ] with each
@@ -131,10 +144,10 @@ ERROR: no-word name ;
 
 M: ast-foreign compile-ast
     nip
-    [ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ]
+    [ class>> dup ":" split1 lookup-word [ ] [ no-word ] ?if ]
     [ name>> ] bi define-foreign
     [ 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 ;