core/effects/effects.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math namespaces sequences strings words assocs
   4 combinators accessors ;
   5 IN: effects
   6
   7 TUPLE: effect in out terminated? ;
   8
   9 : <effect> ( in out -- effect )
  10     dup { "*" } sequence= [ drop { } t ] [ f ] if
  11     effect boa ;
  12
  13 : effect-height ( effect -- n )
  14     [ out>> length ] [ in>> length ] bi - ;
  15
  16 : effect<= ( eff1 eff2 -- ? )
  17     {
  18         { [ over terminated?>> ] [ t ] }
  19         { [ dup terminated?>> ] [ f ] }
  20         { [ 2dup [ in>> length ] bi@ > ] [ f ] }
  21         { [ 2dup [ effect-height ] bi@ = not ] [ f ] }
  22         [ t ]
  23     } cond 2nip ;
  24
  25 GENERIC: (stack-picture) ( obj -- str )
  26 M: string (stack-picture) ;
  27 M: word (stack-picture) word-name ;
  28 M: integer (stack-picture) drop "object" ;
  29
  30 : stack-picture ( seq -- string )
  31     [ [ (stack-picture) % CHAR: \s , ] each ] "" make ;
  32
  33 : effect>string ( effect -- string )
  34     [
  35         "( " %
  36         [ in>> stack-picture % "-- " % ]
  37         [ out>> stack-picture % ]
  38         [ terminated?>> [ "* " % ] when ]
  39         tri
  40         ")" %
  41     ] "" make ;
  42
  43 GENERIC: stack-effect ( word -- effect/f )
  44
  45 M: symbol stack-effect drop (( -- symbol )) ;
  46
  47 M: word stack-effect
  48     { "declared-effect" "inferred-effect" }
  49     swap word-props [ at ] curry map [ ] find nip ;
  50
  51 M: effect clone
  52     [ in>> clone ] [ out>> clone ] bi <effect> ;
  53
  54 : split-shuffle ( stack shuffle -- stack1 stack2 )
  55     in>> length cut* ;
  56
  57 : load-shuffle ( stack shuffle -- )
  58     in>> [ set ] 2each ;
  59
  60 : shuffled-values ( shuffle -- values )
  61     out>> [ get ] map ;
  62
  63 : shuffle* ( stack shuffle -- newstack )
  64     [ [ load-shuffle ] keep shuffled-values ] with-scope ;
  65
  66 : shuffle ( stack shuffle -- newstack )
  67     [ split-shuffle ] keep shuffle* append ;