source: to-imperative/trunk/compiler/rfp_clashes.rf @ 1006

// $Source$
// $Revision: 1006 $
// $Date: 2003-07-12 07:37:29 +0000 (Sat, 12 Jul 2003) $


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

$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 -- список ящиков, обозначающих свойства данного клеша.  В этих
 * ящиках находятся номера клешей, обладающих заданным свойством и, возможно,
 * некая дополнительная информация для каждого клеша.
 *
 * 
 * Ящики бывают следующие.
 * 
 */


/*
 * Образец может иметь жёсткие по длине части слева и справа.  Сопоставление с
 * этими частями выливается в проверку условий возможности такого сопоставления
 * и заведение новых переменных.  Всё это делается до компиляции циклической
 * части образца.
 *
 * В результате означивания новых переменных, жёсткие части образца могут
 * удлинняться.  Следующая таблица по индексу клеша хранит запись вида:
 * (e.left) (e.right) expr.
 * e.left  -- выражение, в ран-тайм получающее значение длины жёсткой части
 * слева.
 * e.right -- аналогичное выражение для длины жёсткой части справа.
 * expr    -- часть выражения между жёсткими кусками.
 */
$table Hard-Parts;


$box Parenth1;
$box Parenth2;





$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 Compose-Clashes e.clashes = e.clashes;

Init-Clashes e.clashes =
  <RFP-Clear-Table &Known-Lengths>,
  <RFP-Clear-Table &Compute-Length>,
  <RFP-Clear-Table &Unknown-Lengths>,
  <Store &Checked-Lengths /*empty*/>,
  <Store &Eqs /*empty*/>,
  <Store &Parenth1 /*empty*/>,
  <Store &Parenth2 /*empty*/>,
  <RFP-Clear-Table &Hard-Parts>,
  <Store &FreeIdx 0>,
  <Store &Clashes <Compose-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,
    {
      \{
        <Get-Var Instantiated? e.Re> : True;
        e.Re : (REF e);
        e.Re : (STATIC e);
      };
      {
        e.Re : t = &Parenth1;
        &Parenth2;
      } :: s.box,
        {
          e.Pe : e1 (PAREN e) e2 =
            <Put s.box (s.idx (<Vars e.Re>) <Vars e1>)>,
            {
              e2 : $r e (PAREN e) e3 =
                <Put s.box (s.idx (<Vars e.Re>) <Vars e3>)>;;
            };;
        };
    },
    (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);

/*
 * Просматриваем все имеющиеся клеши.
 * Если в результате новой информации о переменных, входящих в образец, можно
 * утверждать что жёсткие части удлиннились, запоминаем эту информацию в
 * таблице &Hard-Parts, заводим новые клеши, получающиеся из скобок в образце,
 * и возвращаем условия и присваивания, нужные, чтобы завести эти клеши.
 * Новые, входящие в жёсткие, части образца, не являющиеся скобками, кладутся в
 * ящик &Eqs вместе с результатным выражением и с позицией в этом выражении с
 * которой надо эти части сопоставлять.
 */
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>;
  t.unready-clash e.rest = t.unready-clash <UHP (e.conds) (e.assigns) e.rest>;
  /*empty*/ = (e.conds e.assigns);
};

/*
 * Функция, занимающаяся непосредственно проверкой составляющих образца на
 * вычислимость длин, начиная слева или справа, в зависимости от s.dir.
 * 
 * Если очередной терм -- это скобки, то должен быть заведён новый клеш,
 * образованный из содержимого скобок.  Перед этим надо произвести проверку на
 * то, что в результатном выражении в этом месте тоже стоят скобки, и завести
 * переменную, обозначающую их содержимое.
 * 
 * Данная функция возвращает всю информацию, необходимую для этих действий.
 */
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 e.assign;

$func Define-Vars e.vars = e.eqs;

Prepare-Source {
  t.Re =
    {
      \{
        <Get-Var Instantiated? t.Re> : True;
        t.Re : (REF e);
        t.Re : (STATIC e);
      } =
        t.Re /*empty*/;
      t.Re <Define-Vars t.Re>;
    };
  e.Re =
    <Gener-Vars ((EVAR)) "compose"> : t.var,
    <Set-Var (Instantiated? True) t.var>,
    <Vars-Decl t.var> : e, // ???
    t.var <Define-Vars <Vars e.Re>> (EXPR <Vars-Print t.var> e.Re);
};

Define-Vars {
  t.var e.rest =
    {
      <Get-Var Instantiated? t.var> : True;
      <? &Eqs> : e1 (t.Re t.pos t.var t.len) e2 =
        <Store &Eqs e1 e2>,
        (t.Re t.pos t.var t.len) <Define-Vars e.rest>;
      <Set-Var (Instantiated? True) t.var>; // STUB!!!
    };
  /*empty*/ = /*empty*/;
};



$func Find-SFD e.parenth = e.parenth (e.idx);

Compose-Source-For-Deref =
  <Find-SFD <? &Parenth1>> :: e.parenth1 (e.idx),
  <Store &Parenth1 e.parenth1>,
  {
    e.idx : s.i = s.i;
    <Find-SFD <? &Parenth2>> :: e.parenth2 (e.idx),
      <Store &Parenth2 e.parenth2>,
      e.idx : s.i = s.i;
    /*else*/ = $fail;
  } :: s.idx,
  <? &Clashes> : e1 (s.idx (e.Re) (s.dir e.Pe) e) e2 =
  <Prepare-Source e.Re> :: t.var e.assign,
  <Store &Clashes e1 <Compose-Clashes (t.var) (s.dir e.Pe)> e2>,
  e.assign;

$func? Not-Instantiated-Var e = e;

Find-SFD {
  (s.idx (e.Re-vars) e.Pe-vars) e.rest =
    <Filter &Not-Instantiated-Var (e.Re-vars)> : {
      v.r-vars = (s.idx (v.r-vars) e.Pe-vars) <Find-SFD e.rest>;
      /*empty*/ = <Get-Known-Length e.Pe-vars> : {
        e (v.p-vars) = (s.idx () v.p-vars) <Find-SFD e.rest>;
        e () = e.rest (s.idx);
      };
    };
  /*empty*/ = ();
};

Not-Instantiated-Var t.var = # \{
  <Get-Var Instantiated? t.var> : True;
  <? &Eqs> : e (t t t.var t) e;
};



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 e.assign,
  <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),
  <Set-Var (Instantiated? True) t.var-e1>,
  <Set-Var (Instantiated? True) 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.assign (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;
};