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

   1 ! (c)2010 Joe Groff bsd license
   2 USING: accessors arrays assocs combinators combinators.short-circuit
   3 continuations effects fry kernel locals math math.order namespaces
   4 quotations sequences splitting
   5 stack-checker.backend
   6 stack-checker.errors
   7 stack-checker.known-words
   8 stack-checker.state
   9 stack-checker.values
  10 stack-checker.visitor ;
  11 IN: stack-checker.row-polymorphism
  12
  13 : with-inner-d ( quot -- inner-d )
  14     inner-d-index get
  15     [ meta-d length inner-d-index set call ] dip
  16     inner-d-index get [ min inner-d-index set ] keep ; inline
  17
  18 :: (effect-here) ( inner-d old-meta-d-length old-input-count -- effect )
  19     old-meta-d-length inner-d - input-count get old-input-count - +
  20     meta-d length inner-d -
  21     [ "x" <array> ] bi@ terminated? get <terminated-effect> ; inline
  22
  23 : with-effect-here ( quot -- effect )
  24     meta-d length input-count get
  25     [ with-inner-d ] 2dip (effect-here) ; inline
  26
  27 : (diff-variable) ( diff variable vars -- diff' )
  28     [ at* nip ] [ '[ _ _ at - ] ] [ '[ _ _ set-at 0 ] ] 2tri if ;
  29
  30 : (check-variable) ( actual-count declared-count variable vars -- diff ? )
  31     [ - ] 2dip dupd '[ _ _ (diff-variable) t ] [ dup 0 <= ] if ;
  32
  33 : adjust-variable ( diff var vars -- )
  34     pick 0 >= [ at+ ] [ 3drop ] if ; inline
  35
  36 :: check-variable ( vars declared actual slot var-slot -- diff ok? var )
  37     actual declared [ slot call length ] bi@ declared var-slot call
  38     [ vars (check-variable) ] keep ; inline
  39
  40 :: unify-variables ( in-diff in-ok? in-var out-diff out-ok? out-var vars -- ? )
  41     { [ in-ok? ] [ out-ok? ] [ in-diff out-diff = ] } 0&& dup [
  42         in-var  [ in-diff  swap vars adjust-variable ] when*
  43         out-var [ out-diff swap vars adjust-variable ] when*
  44     ] when ;
  45
  46 : (check-variables) ( vars declared actual -- ? )
  47     [ [ in>>  ] [ in-var>>  ] check-variable ]
  48     [ [ out>> ] [ out-var>> ] check-variable ]
  49     [ 2drop ] 3tri unify-variables ;
  50
  51 : check-variables ( vars declared actual -- ? )
  52     dup terminated?>> [ 3drop t ] [ (check-variables) ] if ;
  53
  54 : combinator-branches-effects ( branches -- quots declareds actuals )
  55     [ [ known>callable ] { } map-as ]
  56     [ [ effect>> ] { } map-as ]
  57     [ [ actual>> ] { } map-as ] tri ;
  58
  59 : combinator-unbalanced-branches-error ( known -- * )
  60     [ word>> ] [ branches>> <reversed> combinator-branches-effects ] bi
  61     unbalanced-branches-error ;
  62
  63 : check-declared-effect ( known effect -- )
  64     [ >>actual ] keep
  65     2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
  66     [ 2drop ] [ drop combinator-unbalanced-branches-error ] if ;
  67