Add new vocabs

extra/smalltalk/compiler/assignment/assignment.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel sequences sets smalltalk.ast ;
+IN: smalltalk.compiler.assignment
+
+GENERIC: assigned-locals ( ast -- seq )
+
+M: ast-return assigned-locals value>> assigned-locals ;
+
+M: ast-block assigned-locals
+    [ body>> assigned-locals ] [ arguments>> ] bi diff ;
+
+M: ast-message-send assigned-locals
+    [ receiver>> assigned-locals ]
+    [ arguments>> assigned-locals ]
+    bi append ;
+
+M: ast-cascade assigned-locals
+    [ receiver>> assigned-locals ]
+    [ messages>> assigned-locals ]
+    bi append ;
+
+M: ast-message assigned-locals
+    arguments>> assigned-locals ;
+
+M: ast-assignment assigned-locals
+    [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
+    [ value>> assigned-locals ] bi append ;
+
+M: ast-sequence assigned-locals
+    body>> assigned-locals ;
+
+M: array assigned-locals
+    [ assigned-locals ] map concat ;
+
+M: object assigned-locals drop f ;

extra/smalltalk/compiler/assignment/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/smalltalk/compiler/return/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/smalltalk/compiler/return/return.factor

@@ -0,0 +1,50 @@
+! 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 ;
+IN: smalltalk.compiler.return
+
+SYMBOL: return-continuation
+
+GENERIC: need-return-continuation? ( ast -- ? )
+
+M: ast-return need-return-continuation? drop t ;
+
+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? ]
+    } 1&& ;
+
+M: ast-cascade need-return-continuation?
+    {
+        [ receiver>> need-return-continuation? ]
+        [ messages>> need-return-continuation? ]
+    } 1&& ;
+
+M: ast-message need-return-continuation?
+    arguments>> need-return-continuation? ;
+
+M: ast-assignment need-return-continuation?
+    value>> need-return-continuation? ;
+
+M: ast-sequence need-return-continuation?
+    body>> need-return-continuation? ;
+
+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 ;