core/effects/effects.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math math.parser namespaces make sequences strings
   4 words assocs combinators accessors arrays ;
   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: effect>string ( obj -- str )
  26 M: string effect>string ;
  27 M: object effect>string drop "object" ;
  28 M: word effect>string name>> ;
  29 M: integer effect>string number>string ;
  30 M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
  31
  32 : stack-picture ( seq -- string )
  33     dup integer? [ "object" <repetition> ] when
  34     [ [ effect>string % CHAR: \s , ] each ] "" make ;
  35
  36 M: effect effect>string ( effect -- string )
  37     [
  38         "( " %
  39         [ in>> stack-picture % "-- " % ]
  40         [ out>> stack-picture % ]
  41         [ terminated?>> [ "* " % ] when ]
  42         tri
  43         ")" %
  44     ] "" make ;
  45
  46 GENERIC: stack-effect ( word -- effect/f )
  47
  48 M: word stack-effect "declared-effect" word-prop ;
  49
  50 M: deferred stack-effect call-next-method (( -- * )) or ;
  51
  52 M: effect clone
  53     [ in>> clone ] [ out>> clone ] bi <effect> ;
  54
  55 : stack-height ( word -- n )
  56     stack-effect effect-height ;
  57
  58 : split-shuffle ( stack shuffle -- stack1 stack2 )
  59     in>> length cut* ;
  60
  61 : shuffle-mapping ( effect -- mapping )
  62     [ out>> ] [ in>> ] bi [ index ] curry map ;
  63
  64 : shuffle ( stack shuffle -- newstack )
  65     shuffle-mapping swap nths ;