basis/stack-checker/row-polymorphism/row-polymorphism.factor

   1 ! Copyright (C) 2010 Joe Groff
   2 ! See https://factorcode.org/license.txt for BSD license
   3 USING: accessors arrays assocs combinators
   4 combinators.short-circuit effects fry kernel locals math
   5 math.order namespaces sequences stack-checker.errors
   6 stack-checker.state stack-checker.values ;
   7 IN: stack-checker.row-polymorphism
   8
   9 : with-inner-d ( quot -- inner-d )
  10     inner-d-index get
  11     [ meta-d length inner-d-index set call ] dip
  12     inner-d-index get [ min inner-d-index set ] keep ; inline
  13
  14 :: (effect-here) ( inner-d old-meta-d-length old-input-count -- effect )
  15     old-meta-d-length inner-d - input-count get old-input-count - +
  16     terminated? get [ [ 0 ] [ meta-d length inner-d - ] if [ "x" <array> ] bi@ ] keep
  17     <terminated-effect> ; inline
  18
  19 : with-effect-here ( quot -- effect )
  20     meta-d length input-count get
  21     [ with-inner-d ] 2dip (effect-here) ; inline
  22
  23 : (diff-variable) ( diff variable vars -- diff' )
  24     [ key? ] [ '[ _ _ at - ] ] [ '[ _ _ set-at 0 ] ] 2tri if ;
  25
  26 : (check-variable) ( actual-count declared-count variable vars -- diff ? )
  27     [ - ] 2dip dupd '[ _ _ (diff-variable) t ] [ dup 0 <= ] if ;
  28
  29 : adjust-variable ( diff var vars -- )
  30     pick 0 >= [ at+ ] [ 3drop ] if ; inline
  31
  32 :: check-variable ( vars declared actual slot var-slot -- diff ok? var )
  33     actual declared [ slot call length ] bi@ declared var-slot call
  34     [ vars (check-variable) ] keep ; inline
  35
  36 :: unify-variables ( in-diff in-ok? in-var out-diff out-ok? out-var vars -- ? )
  37     { [ in-ok? ] [ out-ok? ] [ in-diff out-diff = ] } 0&& dup [
  38         in-var  [ in-diff  swap vars adjust-variable ] when*
  39         out-var [ out-diff swap vars adjust-variable ] when*
  40     ] when ;
  41
  42 ! A bit of a hack. If the declared effect is one-sided monomorphic and the actual effect is a
  43 ! shallow subtype of the root effect, adjust it here
  44 :: (balance-actual-depth) ( declared actual -- depth/f )
  45     {
  46         { [ {
  47             [ declared in-var>> ]
  48             [ declared out-var>> not ]
  49             [ actual out>> length declared out>> length < ]
  50         } 0&& ] [ declared out>> length actual out>> length - ] }
  51         { [ {
  52             [ declared in-var>> not ]
  53             [ declared out-var>> ]
  54             [ actual in>> length declared in>> length < ]
  55         } 0&& ] [ declared in>> length actual in>> length - ] }
  56         [ f ]
  57     } cond ;
  58
  59 : (balance-by) ( effect n -- effect' )
  60     "x" <array> swap
  61     [ in>> append ]
  62     [ out>> append ]
  63     [ nip terminated?>> ] 2tri <terminated-effect> ;
  64
  65 : balance-actual ( declared actual -- declared actual' )
  66     2dup (balance-actual-depth) [ (balance-by) ] when* ;
  67
  68 : (check-variables) ( vars declared actual -- ? )
  69     balance-actual
  70     [ [ in>>  ] [ in-var>>  ] check-variable ]
  71     [ [ out>> ] [ out-var>> ] check-variable ]
  72     [ 2drop ] 3tri unify-variables ;
  73
  74 : check-variables ( vars declared actual -- ? )
  75     dup terminated?>> [ 3drop t ] [ (check-variables) ] if ;
  76
  77 : combinator-branches-effects ( branches -- quots declareds actuals )
  78     [ [ known>callable ] { } map-as ]
  79     [ [ effect>> ] { } map-as ]
  80     [ [ actual>> ] { } map-as ] tri ;
  81
  82 : combinator-unbalanced-branches-error ( known -- * )
  83     [ word>> ] [ branches>> <reversed> combinator-branches-effects ] bi
  84     unbalanced-branches-error ;
  85
  86 : check-declared-effect ( known effect -- )
  87     [ >>actual ] keep
  88     2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
  89     [ 2drop ] [ drop combinator-unbalanced-branches-error ] if ;