core/effects/effects.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math math.parser math.order namespaces make
   4 sequences strings words assocs combinators accessors arrays
   5 quotations ;
   6 IN: effects
   7
   8 TUPLE: effect
   9 { in array read-only }
  10 { out array read-only }
  11 { terminated? read-only } ;
  12
  13 : <effect> ( in out -- effect )
  14     dup { "*" } = [ drop { } t ] [ f ] if
  15     effect boa ;
  16
  17 : effect-height ( effect -- n )
  18     [ out>> length ] [ in>> length ] bi - ; inline
  19
  20 : effect<= ( effect1 effect2 -- ? )
  21     {
  22         { [ over terminated?>> ] [ t ] }
  23         { [ dup terminated?>> ] [ f ] }
  24         { [ 2dup [ in>> length ] bi@ > ] [ f ] }
  25         { [ 2dup [ effect-height ] bi@ = not ] [ f ] }
  26         [ t ]
  27     } cond 2nip ; inline
  28
  29 : effect= ( effect1 effect2 -- ? )
  30     [ [ in>> length ] bi@ = ]
  31     [ [ out>> length ] bi@ = ]
  32     [ [ terminated?>> ] bi@ = ]
  33     2tri and and ;
  34
  35 GENERIC: effect>string ( obj -- str )
  36 M: string effect>string ;
  37 M: object effect>string drop "object" ;
  38 M: word effect>string name>> ;
  39 M: integer effect>string number>string ;
  40 M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
  41
  42 : stack-picture ( seq -- string )
  43     [ [ effect>string % CHAR: \s , ] each ] "" make ;
  44
  45 M: effect effect>string ( effect -- string )
  46     [
  47         "( " %
  48         [ in>> stack-picture % "-- " % ]
  49         [ out>> stack-picture % ]
  50         [ terminated?>> [ "* " % ] when ]
  51         tri
  52         ")" %
  53     ] "" make ;
  54
  55 GENERIC: effect>type ( obj -- type )
  56 M: object effect>type drop object ;
  57 M: word effect>type ;
  58 M: pair effect>type second effect>type ;
  59
  60 : effect-in-types ( effect -- input-types )
  61     in>> [ effect>type ] map ;
  62
  63 : effect-out-types ( effect -- input-types )
  64     out>> [ effect>type ] map ;
  65
  66 GENERIC: stack-effect ( word -- effect/f )
  67
  68 M: word stack-effect
  69     [ "declared-effect" word-prop ]
  70     [ parent-word dup [ stack-effect ] when ] bi or ;
  71
  72 M: deferred stack-effect call-next-method (( -- * )) or ;
  73
  74 M: effect clone
  75     [ in>> clone ] [ out>> clone ] bi <effect> ;
  76
  77 : stack-height ( word -- n )
  78     stack-effect effect-height ;
  79
  80 : split-shuffle ( stack shuffle -- stack1 stack2 )
  81     in>> length cut* ;
  82
  83 : shuffle-mapping ( effect -- mapping )
  84     [ out>> ] [ in>> ] bi [ index ] curry map ;
  85
  86 : shuffle ( stack shuffle -- newstack )
  87     shuffle-mapping swap nths ;
  88
  89 : add-effect-input ( effect -- effect' )
  90     [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ;
  91
  92 : compose-effects ( effect1 effect2 -- effect' )
  93     over terminated?>> [
  94         drop
  95     ] [
  96         [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
  97         [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
  98         [ nip terminated?>> ] 2tri
  99         [ [ "x" <array> ] bi@ ] dip
 100         effect boa
 101     ] if ; inline