extra/smalltalk/compiler/return/return.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators.short-circuit continuations
   4 generalizations kernel locals.rewrite locals.types sequences
   5 smalltalk.ast ;
   6 IN: smalltalk.compiler.return
   7
   8 SYMBOL: return-continuation
   9
  10 GENERIC: need-return-continuation? ( ast -- ? )
  11
  12 M: ast-return need-return-continuation? drop t ;
  13
  14 M: ast-block need-return-continuation? body>> need-return-continuation? ;
  15
  16 M: ast-message-send need-return-continuation?
  17     {
  18         [ receiver>> need-return-continuation? ]
  19         [ arguments>> need-return-continuation? ]
  20     } 1|| ;
  21
  22 M: ast-cascade need-return-continuation?
  23     {
  24         [ receiver>> need-return-continuation? ]
  25         [ messages>> need-return-continuation? ]
  26     } 1|| ;
  27
  28 M: ast-message need-return-continuation?
  29     arguments>> need-return-continuation? ;
  30
  31 M: ast-assignment need-return-continuation?
  32     value>> need-return-continuation? ;
  33
  34 M: ast-sequence need-return-continuation?
  35     body>> need-return-continuation? ;
  36
  37 M: array need-return-continuation? [ need-return-continuation? ] any? ;
  38
  39 M: object need-return-continuation? drop f ;
  40
  41 :: make-return ( quot n lexenv block -- quot )
  42     block need-return-continuation? [
  43         quot clone [ lexenv return>> <def> '[ _ ] prepend ] change-body
  44         n '[ _ _ ncurry callcc1 ]
  45     ] [ quot ] if rewrite-closures first ;