basis/stack-checker/branches/branches.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry vectors sequences assocs math accessors kernel
   4 combinators quotations namespaces stack-checker.state
   5 stack-checker.backend stack-checker.errors stack-checker.visitor
   6 ;
   7 IN: stack-checker.branches
   8
   9 : balanced? ( pairs -- ? )
  10     [ second ] filter [ first2 length - ] map all-equal? ;
  11
  12 SYMBOL: +bottom+
  13
  14 : unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
  15     dup [ [ - +bottom+ <repetition> ] dip append ] [ 3drop f ] if ;
  16
  17 : pad-with-bottom ( seq -- newseq )
  18     dup empty? [
  19         dup [ length ] map supremum
  20         '[ , +bottom+ pad-left ] map
  21     ] unless ;
  22
  23 : phi-inputs ( max-d-in pairs -- newseq )
  24     dup empty? [ nip ] [
  25         swap '[ [ , ] dip first2 unify-inputs ] map
  26         pad-with-bottom
  27     ] if ;
  28
  29 : remove-bottom ( seq -- seq' )
  30     +bottom+ swap remove ;
  31
  32 : unify-values ( values -- phi-out )
  33     remove-bottom
  34     [ <value> ] [
  35         [ known ] map dup all-eq?
  36         [ first make-known ] [ drop <value> ] if
  37     ] if-empty ;
  38
  39 : phi-outputs ( phi-in -- stack )
  40     flip [ unify-values ] map ;
  41
  42 SYMBOL: quotations
  43
  44 : unify-branches ( ins stacks -- in phi-in phi-out )
  45     zip [ 0 { } { } ] [
  46         [ keys supremum ] [ ] [ balanced? ] tri
  47         [ dupd phi-inputs dup phi-outputs ]
  48         [ quotations get unbalanced-branches-error ]
  49         if
  50     ] if-empty ;
  51
  52 : branch-variable ( seq symbol -- seq )
  53     '[ [ , ] dip at ] map ;
  54
  55 : active-variable ( seq symbol -- seq )
  56     [ [ terminated? over at [ drop f ] when ] map ] dip
  57     branch-variable ;
  58
  59 : datastack-phi ( seq -- phi-in phi-out )
  60     [ d-in branch-variable ] [ meta-d active-variable ] bi
  61     unify-branches
  62     [ d-in set ] [ ] [ dup >vector meta-d set ] tri* ;
  63
  64 : terminated-phi ( seq -- terminated )
  65     terminated? branch-variable ;
  66
  67 : terminate-branches ( seq -- )
  68     [ terminated? swap at ] all? [ terminate ] when ;
  69
  70 : compute-phi-function ( seq -- )
  71     [ quotation active-variable sift quotations set ]
  72     [ [ datastack-phi ] [ terminated-phi ] bi #phi, ]
  73     [ terminate-branches ]
  74     tri ;
  75
  76 : copy-inference ( -- )
  77     meta-d [ clone ] change
  78     V{ } clone meta-r set
  79     d-in [ ] change ;
  80
  81 : infer-branch ( literal -- namespace )
  82     [
  83         copy-inference
  84         nest-visitor
  85         [ value>> quotation set ] [ infer-literal-quot ] bi
  86         check->r
  87     ] H{ } make-assoc ; inline
  88
  89 : infer-branches ( branches -- input children data )
  90     [ pop-d ] dip
  91     [ infer-branch ] map
  92     [ stack-visitor branch-variable ] keep ;
  93
  94 : (infer-if) ( branches -- )
  95     infer-branches [ first2 #if, ] dip compute-phi-function ;
  96
  97 : infer-if ( -- )
  98     2 consume-d
  99     dup [ known [ curried? ] [ composed? ] bi or ] contains? [
 100         output-d
 101         [ rot [ drop call ] [ nip call ] if ]
 102         recursive-state get infer-quot
 103     ] [
 104         [ #drop, ] [ [ literal ] map (infer-if) ] bi
 105     ] if ;
 106
 107 : infer-dispatch ( -- )
 108     pop-literal nip [ <literal> ] map
 109     infer-branches [ #dispatch, ] dip compute-phi-function ;