// $Source$
// $Revision$
// $Date$


************************************  ************************************
************ Упорядоченное хранилище клешей и операции с ним *************

$use Access Apply Arithm Box Compare StdIO Table;

$use "rfp_const";
$use "rfp_vars";
$use "rfp_list";
$use "rfp_helper";
$use "rfp_compile";


/*
 * Собственно, хранилище.
 */
$box Clashes;
/*
 * Хранятся в нём клеши в следующем формате:
 *
 * t.clash ::= (s.idx (e.Re) (s.dir e.Pe) e.boxes)
 *
 * e.boxes -- список ящиков, обозначающих свойства данного клеша.  В этих
 * ящиках находятся номера клешей, обладающих заданным свойством и, возможно,
 * некая дополнительная информация для каждого клеша.
 *
 * 
 * Ящики бывают следующие.
 * 
 */
$box Ready-Source;
/*
 * Хранит просто номера клешей.  Означает, что правая часть клеша --
 * переменная, либо константное выражение, следовательно, над ней можно
 * производить разные операции, такие как взятие подвыражений, отщепления,
 * всевозможные проверки и т.п.
 *
 */


$table Hard-Parts;






$func Add-Clash-To-Var e = e;

Add-Clash-To-Var t.clash t.var =
  <Set-Var (Clashes <Get-Var Clashes t.var> t.clash) t.var>;

$func Classify-Lengths t.clash = e.boxes;

Classify-Lengths (s.idx (e.Re) (s.dir e.Pe) e) =
  <Get-Known-Length e.Re> :: e.len-Re (e.vars-Re),
  <Get-Known-Length e.Pe> :: e.len-Pe (e.vars-Pe),
  {
    /*
     * Если длины всех переменных на верхних уровнях e.Re и e.Pe
     * известны, кладём клеш в ящик &Known-Lengths.
     */
    e.vars-Re : /*empty*/, e.vars-Pe : /*empty*/ =
      <Bind &Known-Lengths (s.idx) ((e.len-Re) (e.len-Pe))>,
      &Known-Lengths;
    /*
     * Если на верхнем уровне во всём клеше ровно одна переменная с
     * неизвестной длинной, и она входит в левую и правую части разное
     * кол-во раз, то её длину можно вычислить.
     * В каждой переменной делаем пометку, что она используется в этом клеше.
     * Кладём клеш в ящик &Compute-Length.
     */
    <"-" <Length e.vars-Re> <Length e.vars-Pe>> :: s.diff,
      <"/=" (s.diff) (0)>,
      <Nub e.vars-Re e.vars-Pe> : t.var =
      {
        <"<" (s.diff) (0)> = <"*" s.diff -1> (e.len-Re) (e.len-Pe);
        s.diff (e.len-Pe) (e.len-Re);
      } :: s.mult (e.minuend) (e.subtrahend),
      <Map &Add-Clash-To-Var s.idx (e.vars-Re e.vars-Pe)> : e,
      <Bind &Compute-Length (s.idx) (t.var s.mult (e.minuend) (e.subtrahend))>,
      &Compute-Length;
    /*
     * В оставшихся случаях, всё, что мы можем сделать -- выписать
     * граничные условия и ждать, пока не появится новой информации о длине
     * каких-либо переменных.
     * В каждой переменной делаем пометку, что она используется в этом клеше.
     * Кладём клеш в таблицу &Unknown-Lengths.
     */
    <Map &Add-Clash-To-Var s.idx (e.vars-Re e.vars-Pe)> : e,
      <Bind &Unknown-Lengths
        (s.idx) ((e.len-Re) (e.len-Pe) (e.vars-Re) (e.vars-Pe))>,
      &Unknown-Lengths;
  };


/*
 * Может оказаться, что клеша с номером s.idx уже нет в хранилище -- из памяти
 * переменных клеши не удаляются.  В этом случае просто не надо ничего делать.
 */
Reclassify-Clash s.idx, {
  <? &Clashes> : e1 (s.idx (e.Re) (s.dir e.Pe) e.boxes) e2,
  <Sub (e.boxes) &Compute-Length &Unknown-Lengths> :: e.boxes1,
  <Unbind &Compute-Length s.idx>,
  <Unbind &Unknown-Lengths s.idx>,
  <Classify-Lengths (s.idx (e.Re) (s.dir e.Pe))> :: e.boxes2,
  <Store &Clashes e1 (s.idx (e.Re) (s.dir e.Pe) e.boxes1 e.boxes2) e2>;;
};



********************** Индекс для нумерации клешей ***********************

$box FreeIdx;

$func Free-Index = s.idx;

Free-Index =
  <? &FreeIdx> : s.idx,
  <Store &FreeIdx <"+" s.idx 1>>,
  s.idx;



***************************** Инициализация ******************************

$func Put-In e.clashes = ;  // президент такой был ;-)

Init-Clashes e.clashes =
  <Store &Clashes /*empty*/>,
  <RFP-Clear-Table &Known-Lengths>,
  <RFP-Clear-Table &Compute-Length>,
  <RFP-Clear-Table &Unknown-Lengths>,
  <Store &Checked-Lengths /*empty*/>,
  <Store &Eqs /*empty*/>,
  <Store &Ready-Source /*empty*/>,
  <RFP-Clear-Table &Hard-Parts>,
  <Store &FreeIdx 0>,
  <Put-In e.clashes>;

Put-In {
  (e.Re) (s.dir e.Pe) e.rest =
    /*
     */
    <Free-Index> :: s.idx,
    /*
     */
    <Classify-Lengths (s.idx (e.Re) (s.dir e.Pe))> :: e.boxes1,
    /*
     * Если e.R1 -- переменная или константа, кладём его в ящик
     * &Ready-Source.
     */
    {
      \{
        <Var? e.Re>;
        e.Re : (STATIC e);
        e.Re : (REF e);
      } =
        <Put &Ready-Source s.idx>,
        &Ready-Source;;
    } :: e.boxes2,
    /*
     * Распихав клеш по всем нужным ящикам, сохраняем его в таблице вместе
     * со ссылками на них.
     */
    <Put &Clashes (s.idx (e.Re) (s.dir e.Pe) e.boxes1 e.boxes2)>,
    <Put-In e.rest>;
  /*empty*/ = /*empty*/;
};

$func Compose-Clashes e.clashes = e.clashes;

Compose-Clashes {
  (e.Re) (s.dir e.Pe) e.rest =
    <Free-Index> :: s.idx,
    <Classify-Lengths (s.idx (e.Re) (s.dir e.Pe))> :: e.boxes,
    (s.idx (e.Re) (s.dir e.Pe) e.boxes) <Compose-Clashes e.rest>;;
};




$func UHP (e.conds) (e.assigns) e.clashes = e.clashes (e.actions);

$func UHP-Clash s.dir s.fun s.l s.r (e.conds) (e.assigns) (e.pos) (e.Re) e.Pe =
  e.clashes (e.conds) (e.assigns) (e.pos) (e.Pe);

Update-Hard-Parts =
  <UHP () () <? &Clashes>> :: e.clashes (e.actions),
  <Store &Clashes e.clashes>,
  e.actions;

UHP (e.conds) (e.assigns) e.clashes, e.clashes : {
  t.clash e.rest,
    t.clash : (s.idx (t.Re) (s.dir e.Pe) e),
    \{
      <Get-Var Instantiated? t.Re> : True;
      t.Re : (REF e);
      t.Re : (STATIC e);
    } =
    {
      <Lookup &Hard-Parts s.idx>;
      (0) (0) e.Pe;
    } : (e.left) (e.right) expr,
    <UHP-Clash LEFT  &L- 1 0 () () (e.left ) (t.Re) expr>
      :: e.l-clashes (e.l-conds) (e.l-assigns) (e.left ) (expr),
    <UHP-Clash RIGHT &R- 0 1 () () (e.right) (t.Re) expr>
      :: e.r-clashes (e.r-conds) (e.r-assigns) (e.right) (expr),
    <Bind &Hard-Parts (s.idx) ((e.left) (e.right) expr)>,
    <Compose-Clashes e.l-clashes> t.clash <Compose-Clashes e.r-clashes>
    <UHP (e.conds e.l-conds e.r-conds) (e.assigns e.l-assigns e.r-assigns) e.rest>;
  /*empty*/ = (e.conds e.assigns);
  t.unready-clash e.rest = t.unready-clash <UHP (e.conds) (e.assigns) e.rest>;
};

UHP-Clash s.dir s.fun s.l s.r (e.conds) (e.assigns) (e.pos) (e.Re) e.Pe, {
  <Apply s.fun 0 e.Pe> : t.Pt, {
    <Get-Known-Length t.Pt> : e.len (), {
      t.Pt : (PAREN expr) = 
        <Gener-Vars ((VAR)) "deref_" e.Re> : t.var,
        <Set-Var (Instantiated? True) t.var>,
        ((SYMBOL? e.Re (s.dir e.pos)))
        ((DEREF t.var e.Re (s.dir e.pos)))
        (t.var) (s.dir expr);
      <Put &Eqs ((e.Re) (s.dir e.pos) t.Pt (e.len))>,
        () () /*empty*/;
    } :: (e.cond) (e.assign) e.clash =
      e.clash
      <UHP-Clash s.dir s.fun s.l s.r (e.conds e.cond) (e.assigns e.assign)
        (e.pos e.len) (e.Re) <Middle s.l s.r e.Pe>>;
    (e.conds) (e.assigns) (e.pos) (e.Pe);
  };
  (e.conds) (e.assigns) (e.pos) ();
};




$func Prepare-Source e.source = t.var;

Prepare-Source t.var = t.var;




Compose-Source-For-Deref = ();






Get-Cycle =
  <? &Clashes> : e (s.idx (e.Re) (s.dir e.Pe) e.b1 &Unknown-Lengths e.b2) e.rest =
  <Prepare-Source e.Re> :: t.var,
  <Get-Known-Length t.var> : e.len (),
  <Lookup &Hard-Parts s.idx> : (e.left) (e.right) e.expr,
  s.dir : {
    LEFT =
      e.expr : t.var-e1 e.Pe-rest,
      t.var-e1 "lsplit_" e.Pe-rest;
    RIGHT =
      e.expr : e.Pe-rest t.var-e1,
      t.var-e1 "rsplit_" e.Pe-rest;
  } :: t.var-e1 s.pref-e2 e.Pe-rest,
  {
    <Var? e.Pe-rest> = e.Pe-rest ();
    <Gener-Vars ((VAR)) s.pref-e2 t.var> : t.var-e2,
      t.var-e2 ((t.var-e2) (s.dir e.Pe-rest));
  } : t.var-e2 (e.clash),
  {
    <Flat? e.Re> = (Flat? True);;
  } :: e.flat?,
  <Set-Var (Instantiated? True) e.flat? t.var-e1>,
  <Set-Var (Instantiated? True) e.flat? t.var-e2>,
  <Store &Clashes <Compose-Clashes e.clash> e.rest>,
  <Get-Var Clashes t.var-e1> :: e.clashes,
  <Map &Reclassify-Clash (<Sub (e.clashes) <? &Checked-Lengths>>)> : e,
  (e.left) (e.right) (e.len) t.var t.var-e1 t.var-e2;




$func Ref-Len t.name = e.length;

/*
 * Из верхнего уровня выражения изымаются все переменные, длина которых не
 * может быть посчитана (она неизвестна из формата, и переменная ещё не
 * получила значение в run-time).  Список этих переменных возвращается вторым
 * параметром.  Первым параметром возвращается длина оставшегося после их
 * изъятия выражения.
 */
Get-Known-Length e.Re =
  e.Re (/*e.length*/) (/*e.unknown-vars*/) $iter {
    e.Re : t.Rt e.rest, t.Rt : {
      s.ObjectSymbol = 1 ();	// Может появиться из константы.
      (PAREN e) = 1 ();
      (REF t.name) = <Ref-Len t.name> ();
      (STATIC t.name) = <Get-Known-Length <Get-Static t.Rt>>;
      t, <Var? t.Rt>, {
        <Get-Var Length t.Rt> : v.len = v.len ();
        /*empty*/ (t.Rt);
      };
    } :: e.len (e.var),
      e.rest (e.length e.len) (e.unknown-vars e.var);
  } :: e.Re (e.length) (e.unknown-vars),
  e.Re : /*empty*/ =
  {
    e.length : /*empty*/ = 0 (e.unknown-vars);
    e.length (e.unknown-vars);
  };

$table Const-Len;  // Fixme: инициализировать когда?

Ref-Len t.name = {
  <Lookup &Const-Len t.name>;
  <Get-Known-Length <Middle 3 0 <Lookup &Const t.name>>> :: e.len t =
    <Bind &Const-Len (t.name) (e.len)>,
    e.len;
  1;
};