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 classes.algebra classes ;
   6 IN: effects
   7
   8 TUPLE: effect
   9 { in array read-only }
  10 { out array read-only }
  11 { terminated? read-only }
  12 { in-var read-only }
  13 { out-var read-only } ;
  14
  15 : ?terminated ( out -- out terminated? )
  16     dup { "*" } = [ drop { } t ] [ f ] if ;
  17
  18 : <effect> ( in out -- effect )
  19     ?terminated f f effect boa ;
  20
  21 : <terminated-effect> ( in out terminated? -- effect )
  22     f f effect boa ; inline
  23
  24 : <variable-effect> ( in-var in out-var out -- effect )
  25     swap [ rot ] dip [ ?terminated ] 2dip effect boa ;
  26
  27 : effect-height ( effect -- n )
  28     [ out>> length ] [ in>> length ] bi - ; inline
  29
  30 : variable-effect? ( effect -- ? )
  31     [ in-var>> ] [ out-var>> ] bi or ;
  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 ] bi@ = not ] [ f ] }
  43         [ t ]
  44     } cond 2nip ; inline
  45
  46 : effect= ( effect1 effect2 -- ? )
  47     [ [ in>> length ] bi@ = ]
  48     [ [ out>> length ] bi@ = ]
  49     [ [ terminated?>> ] bi@ = ]
  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 first2 [ effect>string ] bi@ ": " glue ;
  58
  59 : stack-picture ( seq -- string )
  60     [ [ effect>string % CHAR: \s , ] each ] "" make ;
  61
  62 : var-picture ( var -- string )
  63     [ ".." " " surround ]
  64     [ "" ] if* ;
  65
  66 M: effect effect>string ( effect -- string )
  67     [
  68         "( " %
  69         dup in-var>> var-picture %
  70         dup in>> stack-picture % "-- " %
  71         dup out-var>> var-picture %
  72         dup out>> stack-picture %
  73         dup terminated?>> [ "* " % ] when
  74         drop
  75         ")" %
  76     ] "" make ;
  77
  78 GENERIC: effect>type ( obj -- type )
  79 M: object effect>type drop object ;
  80 M: word effect>type ;
  81 M: pair effect>type second effect>type ;
  82 M: classoid effect>type ;
  83
  84 : effect-in-types ( effect -- input-types )
  85     in>> [ effect>type ] map ;
  86
  87 : effect-out-types ( effect -- input-types )
  88     out>> [ effect>type ] map ;
  89
  90 GENERIC: stack-effect ( word -- effect/f )
  91
  92 M: word stack-effect
  93     [ "declared-effect" word-prop ]
  94     [ parent-word dup [ stack-effect ] when ] bi or ;
  95
  96 M: deferred stack-effect call-next-method ( -- * ) or ;
  97
  98 M: effect clone
  99     [ in>> clone ] [ out>> clone ] bi <effect> ;
 100
 101 : stack-height ( word -- n )
 102     stack-effect effect-height ; inline
 103
 104 : shuffle-mapping ( effect -- mapping )
 105     [ out>> ] [ in>> ] bi [ index ] curry map ;
 106
 107 : shuffle ( stack shuffle -- newstack )
 108     shuffle-mapping swap nths ;
 109
 110 : add-effect-input ( effect -- effect' )
 111     [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri <terminated-effect> ;
 112
 113 : compose-effects ( effect1 effect2 -- effect' )
 114     over terminated?>> [
 115         drop
 116     ] [
 117         [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
 118         [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
 119         [ nip terminated?>> ] 2tri
 120         [ [ "x" <array> ] bi@ ] dip
 121         <terminated-effect>
 122     ] if ; inline
 123
 124 : curry-effect ( effect -- effect' )
 125     [ in>> length ] [ out>> length ] [ terminated?>> ] tri
 126     pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
 127     [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;