core/effects/effects.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays classes combinators kernel make math
   4 math.order math.parser sequences sequences.private strings words ;
   5 IN: effects
   6
   7 TUPLE: effect
   8 { in array read-only }
   9 { out array read-only }
  10 { terminated? read-only }
  11 { in-var read-only }
  12 { out-var read-only } ;
  13
  14 : ?terminated ( out -- out terminated? )
  15     dup { "*" } = [ drop { } t ] [ f ] if ;
  16
  17 : <effect> ( in out -- effect )
  18     ?terminated f f effect boa ;
  19
  20 : <terminated-effect> ( in out terminated? -- effect )
  21     f f effect boa ; inline
  22
  23 : <variable-effect> ( in-var in out-var out -- effect )
  24     swap rotd [ ?terminated ] 2dip effect boa ;
  25
  26 : effect-height ( effect -- n )
  27     [ out>> length ] [ in>> length ] bi - ; inline
  28
  29 : variable-effect? ( effect -- ? )
  30     [ in-var>> ] [ out-var>> ] bi or ;
  31
  32 : bivariable-effect? ( effect -- ? )
  33     [ in-var>> ] [ out-var>> ] bi = not ;
  34
  35 : effect<= ( effect1 effect2 -- ? )
  36     {
  37         { [ over terminated?>> ] [ t ] }
  38         { [ dup terminated?>> ] [ f ] }
  39         { [ 2dup [ bivariable-effect? ] either? ] [ f ] }
  40         { [ 2dup [ variable-effect? ] [ variable-effect? not ] bi* and ] [ f ] }
  41         { [ 2dup [ in>> length ] bi@ > ] [ f ] }
  42         { [ 2dup [ effect-height ] same? not ] [ f ] }
  43         [ t ]
  44     } cond 2nip ; inline
  45
  46 : effect= ( effect1 effect2 -- ? )
  47     [ [ in>> length ] same? ]
  48     [ [ out>> length ] same? ]
  49     [ [ terminated?>> ] same? ]
  50     2tri and and ;
  51
  52 GENERIC: effect>string ( obj -- str )
  53 M: string effect>string ;
  54 M: object effect>string drop "object" ;
  55 M: word effect>string name>> ;
  56 M: integer effect>string number>string ;
  57 M: pair effect>string
  58     first2-unsafe over [
  59         [ effect>string ] bi@ ": " glue
  60     ] [
  61         nip effect>string ":" prepend
  62     ] if ;
  63
  64 <PRIVATE
  65
  66 : stack-picture% ( seq -- )
  67     [ effect>string % CHAR: \s , ] each ;
  68
  69 : var-picture% ( var -- )
  70     [ ".." % % CHAR: \s , ] when* ;
  71
  72 PRIVATE>
  73
  74 M: effect effect>string
  75     [
  76         "( " %
  77         dup in-var>> var-picture%
  78         dup in>> stack-picture% "-- " %
  79         dup out-var>> var-picture%
  80         dup out>> stack-picture%
  81         dup terminated?>> [ "* " % ] when
  82         drop
  83         ")" %
  84     ] "" make ;
  85
  86 GENERIC: effect>type ( obj -- type )
  87 M: object effect>type drop object ;
  88 M: word effect>type ;
  89 M: pair effect>type second-unsafe effect>type ;
  90 M: classoid effect>type ;
  91
  92 : effect-in-types ( effect -- input-types )
  93     in>> [ effect>type ] map ;
  94
  95 : effect-out-types ( effect -- input-types )
  96     out>> [ effect>type ] map ;
  97
  98 GENERIC: stack-effect ( word -- effect/f )
  99
 100 M: word stack-effect
 101     dup "declared-effect" word-prop [ nip ] [
 102         parent-word dup [ stack-effect ] when
 103     ] if* ;
 104
 105 M: deferred stack-effect call-next-method ( -- * ) or ;
 106
 107 M: effect clone
 108     {
 109         [ in>> clone ]
 110         [ out>> clone ]
 111         [ terminated?>> ]
 112         [ in-var>> ]
 113         [ out-var>> ]
 114     } cleave effect boa ;
 115
 116 : stack-height ( word -- n )
 117     stack-effect effect-height ; inline
 118
 119 : shuffle-mapping ( effect -- mapping )
 120     [ out>> ] [ in>> ] bi [ index ] curry map ;
 121
 122 : shuffle ( stack shuffle -- newstack )
 123     shuffle-mapping swap nths ;
 124
 125 : add-effect-input ( effect -- effect' )
 126     [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri
 127     <terminated-effect> ;
 128
 129 : compose-effects ( effect1 effect2 -- effect' )
 130     over terminated?>> [
 131         drop
 132     ] [
 133         [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
 134         [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
 135         [ nip terminated?>> ] 2tri
 136         [ [ "x" <array> ] bi@ ] dip
 137         <terminated-effect>
 138     ] if ; inline
 139
 140 : curry-effect ( effect -- effect' )
 141     [ in>> length ] [ out>> length ] [ terminated?>> ] tri
 142     pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
 143     [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;
 144
 145 ERROR: bad-stack-effect word got expected ;
 146
 147 : check-stack-effect ( word effect -- )
 148     over stack-effect 2dup effect=
 149     [ 3drop ] [ bad-stack-effect ] if ;