core/continuations.factor

   1 ! Copyright (C) 2003, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: kernel-internals
   4 USING: vectors ;
   5
   6 : catchstack* ( -- catchstack )
   7     6 getenv { vector } declare ; inline
   8
   9 IN: errors
  10 USING: kernel kernel-internals ;
  11
  12 : catchstack ( -- catchstack ) catchstack* clone ; inline
  13 : set-catchstack ( catchstack -- ) >vector 6 setenv ; inline
  14
  15 IN: kernel
  16 USING: arrays namespaces sequences ;
  17
  18 TUPLE: continuation data retain call name catch ;
  19
  20 : continuation ( -- continuation )
  21     datastack retainstack callstack namestack catchstack
  22     <continuation> ; inline
  23
  24 : >continuation< ( continuation -- data retain call name catch )
  25     [ continuation-data ] keep
  26     [ continuation-retain ] keep
  27     [ continuation-call ] keep
  28     [ continuation-name ] keep
  29     continuation-catch ; inline
  30
  31 : ifcc ( terminator balance -- )
  32     >r >r f [ continuation nip t ] call r> r> if ; inline
  33
  34 : callcc0 ( quot -- ) [ ] ifcc ; inline
  35
  36 : callcc1 ( quot -- obj ) callcc0 ; inline
  37
  38 DEFER: continue-with
  39
  40 : set-walker-hook 2 setenv ; inline
  41
  42 : get-walker-hook 2 getenv f set-walker-hook ; inline
  43
  44 : (continue) ( continuation -- )
  45     >continuation<
  46     set-catchstack
  47     set-namestack
  48     set-callstack
  49     set-retainstack
  50     set-datastack ; inline
  51
  52 : (continue-with) ( obj continuation -- )
  53     #! There's no good way to avoid this code duplication!
  54     swap 9 setenv
  55     >continuation<
  56     set-catchstack
  57     set-namestack
  58     set-callstack
  59     set-retainstack
  60     set-datastack
  61     9 getenv swap ; inline
  62
  63 : continue ( continuation -- )
  64     get-walker-hook [ (continue-with) ] [ (continue) ] if* ;
  65     inline
  66
  67 : continue-with ( obj continuation -- )
  68     get-walker-hook [ >r 2array r> ] when* (continue-with) ;
  69     inline
  70
  71 M: continuation clone
  72     [ continuation-data clone ] keep
  73     [ continuation-retain clone ] keep
  74     [ continuation-call clone ] keep
  75     [ continuation-name clone ] keep
  76     continuation-catch clone <continuation> ;