core/effects/effects.factor

   1 ! Copyright (C) 2006, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math namespaces sequences strings words assocs
   4 combinators ;
   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 construct-boa ;
  12
  13 : effect-height ( effect -- n )
  14     dup effect-out length swap effect-in length - ;
  15
  16 : effect<= ( eff1 eff2 -- ? )
  17     {
  18         { [ dup not ] [ t ] }
  19         { [ over effect-terminated? ] [ t ] }
  20         { [ dup effect-terminated? ] [ f ] }
  21         { [ 2dup [ effect-in length ] 2apply > ] [ f ] }
  22         { [ 2dup [ effect-height ] 2apply = not ] [ f ] }
  23         { [ t ] [ t ] }
  24     } cond 2nip ;
  25
  26 GENERIC: (stack-picture) ( obj -- str )
  27 M: string (stack-picture) ;
  28 M: word (stack-picture) word-name ;
  29 M: integer (stack-picture) drop "object" ;
  30
  31 : stack-picture ( seq -- string )
  32     [ [ (stack-picture) % CHAR: \s , ] each ] "" make ;
  33
  34 : effect>string ( effect -- string )
  35     [
  36         "( " %
  37         dup effect-in stack-picture %
  38         "-- " %
  39         dup effect-out stack-picture %
  40         effect-terminated? [ "* " % ] when
  41         ")" %
  42     ] "" make ;
  43
  44 : stack-effect ( word -- effect/f )
  45     dup symbol? [
  46         drop 0 1 <effect>
  47     ] [
  48         { "declared-effect" "inferred-effect" }
  49         swap word-props [ at ] curry map [ ] find nip
  50     ] if ;
  51
  52 M: effect clone
  53     [ effect-in clone ] keep effect-out clone <effect> ;