source: to-imperative/trunk/compiler/rfp_format.rf @ 2043

// $Source$
// $Revision: 2043 $
// $Date: 2006-08-01 17:25:13 +0000 (Tue, 01 Aug 2006) $

$use Access List StdIO Table;

$use "rfp_compile";
$use "rfp_vars";

$func Split-Rt t.Ft t.Rt = e.splited-Rt;

//$func MSG-Exprs (e.Fe1) e.Fe2 = e.Fe;
$func MSG-Exprs e = e;

$func MSG-Terms t.Ft1 t.Ft2 = t.Ft;

// is t.name a $const'ant with an empty value?
$func? Empty-Const? t.name = ;

// is e.expr an empty expression with regard of $const'ant values?
$func? Empty-Expr? e.expr = ;

// if in the end the value of $const'ant t.name is term then return that term
$func? Get-Const-Term t.name = term;

// if expr becomes term after unfolding all $const'ants then return that term
$func? Get-Term expr = term;


/*
 * Returns format of given result or hard expression or pattern.
 */
Format-Exp 
//e1 = <WriteLN Format-Exp e1>, e1 :
{
  t.first e.rest, t.first :
    {
      s.ObjectSymbol = s.ObjectSymbol;
      (REF t.Name) = {
        <In-Table? &Const t.Name> = (REF t.Name);
        (SVAR);
      };
      (CALL t.Pragma t.Fname e) =
        <L 4 <Lookup-Func t.Fname>> : (e.FOut) = e.FOut;
      (CALL t.Fname e), // Is needed anywhere ???
        <L 4 <Lookup-Func t.Fname>> : (e.FOut) = e.FOut;
      // (BLOCK e.Branches) = ...
      (PAREN e.Expression) = (PAREN <Format-Exp e.Expression>);
      (VAR t.name) = $fail;
      (s.VariableTag e) = (s.VariableTag); // s.VariableTag ::= SVAR | TVAR
    } :: e.first-format =          //         | VVAR | EVAR
    e.first-format <Format-Exp e.rest>;
  = ;
};

/*
 * Split-Re (e.Format) e.Re 
 * Returns (e.1) (e.2) ... (e.n) where each e.i is a part of e.Re
 * corresponded to a variable in e.Format.
 */
Split-Re /*(e1) e2, <WriteLN Split-Re (e1) e2>, (e1) e2 :*/ {
  (t.Ft e.Fe) t.Rt e.Re,
    \{
      /*
       * If the term isn't ve-variable or $const then split it out with Split-Rt.
       */
      # \{ 
        t.Ft : \{ (VVAR); (EVAR); (REF e); };
        <Format-Exp t.Rt> : (REF e);
      } = 
        <Split-Rt t.Ft t.Rt> <Split-Re (e.Fe) e.Re>;
    };
  (v.Fe t.Ft) e.Re t.Rt,
    \{
      /*
       * If the term isn't ve-variable or $const then split it out with Split-Rt.
       */
      # \{
        t.Ft : \{ (VVAR); (EVAR); (REF e); };
        <Format-Exp t.Rt> : (REF e);
      } =
        <Split-Re (v.Fe) e.Re> <Split-Rt t.Ft t.Rt>;
    };
  ((REF t.name) e.Fe) e.Re, {
    e.Re : t.Rt e.Rest, <Format-Exp t.Rt> : (REF t.name) = <Split-Re (e.Fe) e.Rest>;
    <Split-Re (<Middle 3 0 <Lookup &Const t.name>> e.Fe) e.Re>;
  };
  (v.Fe (REF t.name)) e.Re, {
    e.Re : e.Rest t.Rt, <Format-Exp t.Rt> : (REF t.name) = <Split-Re (v.Fe) e.Rest>;
    <Split-Re (v.Fe <Middle 3 0 <Lookup &Const t.name>>) e.Re>;
  };
  ((VVAR)) e.Re = (e.Re);
  ((EVAR)) e.Re = (e.Re);
  (e.Fe) t.Rt e.Re, <Format-Exp t.Rt> : (REF t.name) =
    <Split-Re (e.Fe) <Middle 3 0 <Lookup &Const t.name>> e.Re>;
  (e.Fe) v.Re t.Rt, <Format-Exp t.Rt> : (REF t.name) =
    <Split-Re (e.Fe) v.Re <Middle 3 0 <Lookup &Const t.name>>>;
  () /*empty*/ = /*empty*/;
};

Split-Rt t.Ft t.Rt/*, <WriteLN Split-Rt t.Ft t.Rt>*/ =
  t.Ft : {
    s.ObjectSymbol = /*empty*/;
    (PAREN e.Fe) = t.Rt : (PAREN e.Re), <Split-Re (e.Fe) e.Re>;
    t.VariableTag = (t.Rt); // t.VariableTag ::= (TVAR) | (SVAR)
  };

MSG {
  exprs (e.Fe) = <Foldr &MSG-Exprs (e.Fe) (exprs)>;
  /*empty*/ = /*empty*/;
};

/*
 * MSG-Exprs (e.Format1) e.Format2
 * Return e.Format3 -- most specific generalizing of formats 1 and 2.
 */
MSG-Exprs {
  (t.Ft1 e.Fe1) t.Ft2 e.Fe2 \?
    /*
     * IF both t.Ft1 and t.Ft2 are hard terms and aren't $const'ants then
     * split them out with MSG-Terms.
     */
    {
      t.Ft1 : \{ (EVAR); (VVAR); (REF e); } \! $fail;
      t.Ft2 : \{ (EVAR); (VVAR); (REF e); } \! $fail;
      <MSG-Terms t.Ft1 t.Ft2> <MSG-Exprs (e.Fe1) e.Fe2>;
    };
  (e.Fe1 t.Ft1) e.Fe2 t.Ft2 \?
    /*
     * IF both t.Ft1 and t.Ft2 are hard terms and aren't $const'ants then
     * split them out with MSG-Terms.
     */
    {
      t.Ft1 : \{ (EVAR); (VVAR); (REF e); } \! $fail;
      t.Ft2 : \{ (EVAR); (VVAR); (REF e); } \! $fail;
      <MSG-Exprs (e.Fe1) e.Fe2> <MSG-Terms t.Ft1 t.Ft2>;
    };
  ((REF t.name) e.Fe1) e.Fe2, {
    e.Fe2 : (REF t.name) e.Rest = (REF t.name) <MSG-Exprs (e.Fe1) e.Rest>;
    <MSG-Exprs (<Format-Exp <Lookup &Const t.name>> e.Fe1) e.Fe2>;
  };
  (e.Fe1 (REF t.name)) e.Fe2, {
    e.Fe2 : e.Rest (REF t.name) = <MSG-Exprs (e.Fe1) e.Rest> (REF t.name);
    <MSG-Exprs (e.Fe1 <Format-Exp <Lookup &Const t.name>>) e.Fe2>;
  };
  (e.Fe1) (REF t.name) e.Fe2 =
    <MSG-Exprs (e.Fe1) <Format-Exp <Lookup &Const t.name>> e.Fe2>;
  (e.Fe1) e.Fe2 (REF t.name) =
    <MSG-Exprs (e.Fe1) e.Fe2 <Format-Exp <Lookup &Const t.name>>>;
  (e.Fe1) e.Fe2, {
    <Empty-Expr? e.Fe1>, <Empty-Expr? e.Fe2> = /*empty*/;
    /* 
     * If both e.Fe1 and e.Fe2 have non-(EVAR) terms then we can unify
     * them to (VVAR). Be VERY careful! We can meet &C, but it easy can be
     * that it points to empty expression.
     */
    \?
    e.Fe1 : e t.Ft1 e, t.Ft1 : \{
      (VVAR);
      (REF t.name), # <Empty-Const? t.name>;
    } \!
      e.Fe2 : e t.Ft2 e, t.Ft2 : \{
        (VVAR);
        (REF t.name), # <Empty-Const? t.name>;
      } =
      (VVAR);
    /*
     * Else at least one of expressions has form of (EVAR)...(EVAR). So we
     * should return (EVAR).
     */
    (EVAR);
  };
};

MSG-Terms {
  (PAREN e.Fe1) (PAREN e.Fe2) = (PAREN <MSG-Exprs (e.Fe1) e.Fe2>);
  t.Ft t.Ft = t.Ft;
  s s = (SVAR);
  (SVAR) s = (SVAR);
  s (SVAR) = (SVAR);
  (SVAR) (SVAR) = (SVAR);
  t t = (TVAR);
};

/*
 * Ends good if e.Format2 is a special case of e.Format1 or coincide it.
 */
Subformat? (e.Format1) (e.Format2),/* <WriteLN TTT (e.Format1) (e.Format2)>,*/
  e.Format1 : {
    e.Format2 = ;
    /*empty*/ = <Empty-Expr? e.Format2>;
    (EVAR) = ;
    /* 
     * If e.Format1 is (VVAR) then e.Format2 shouldn't be (EVAR) (EVAR) ...
     * (EVAR). Be VERY careful! We can meet &C, but it easy can be that it
     * points to empty expression.
     */
    (VVAR) =
      e.Format2 : e t.HardTerm e,
      # t.HardTerm : \{ 
        (EVAR);
        (REF t.Name), <Empty-Const? t.Name>;
      };
    (TVAR) =
      e.Format2 : e0 t1 e2,
      \{
        <R 0 e0> :: t0, # <Empty-Expr? t0> = $fail;
        t1 : \{
          (REF t.Name), <Get-Const-Term t.Name> : e;
          s.ObjectSymbol;
          (SVAR);
          (PAREN e);
          (TVAR);
        } =
          <Empty-Expr? e2>;
      };
    (SVAR) =
      e.Format2 : e0 t1 e2,
      \{
        <R 0 e0> :: t0, # <Empty-Expr? t0> = $fail;
        t1 : \{
          (REF t.Name), <Get-Const-Term t.Name> : term =
            term : \{
              s.ObjectSymbol;
              (REF e);        // Reference to an object
            },
            <Empty-Expr? e2>;
          s.ObjectSymbol = <Empty-Expr? e2>;
          (SVAR) = <Empty-Expr? e2>;
        };
      };
    (PAREN e.Format11) =
      e.Format2 : e0 t1 e2,
      \{
        <R 0 e0> :: t0, # <Empty-Expr? t0> = $fail;
        t1 : \{
          (REF t.Name), <Get-Const-Term t.Name> : term =
            term : (PAREN e.Format22),
            <Empty-Expr? e2>,
            <Subformat? (e.Format11) (e.Format22)>;
          (PAREN e.Format22) =
            <Empty-Expr? e2>,
            <Subformat? (e.Format11) (e.Format22)>;
        };
      };
    s.ObjectSymbol =
      e.Format2 : e0 t1 e2,
      \{
        <R 0 e0> :: t0, # <Empty-Expr? t0> = $fail;
        t1 : \{
          (REF t.Name), <Get-Const-Term t.Name> : term =
            <Empty-Expr? e2>,
            term : s.ObjectSymbol;
          symbol =
            <Empty-Expr? e2>,
            symbol : s.ObjectSymbol;
        };
      };
    (REF t.Name) =
      <Subformat? (<Format-Exp <Middle 3 0 <Lookup &Const t.Name>>>) (e.Format2)>;
    v.first1 v.rest1, e.Format2 : e.first2 e.rest2,
      <Subformat? (v.first1) (e.first2)> <Subformat? (v.rest1) (e.rest2)>;
    e, e.Format2 (/*e.format*/) 0 $iter {
      e.Format2 : e1 (REF t.Name) e2 =
        e2 (e.format e1 <Format-Exp <Middle 3 0 <Lookup &Const t.Name>>>) 1;
      (e.format e.Format2) s.success?;
    } :: e.Format2 (e.format) s.success?,
      e.Format2 : /*empty*/ =
      \{
        s.success? : 0 = $fail;
        <Subformat? (e.Format1) (e.format)>;
      };
  };

/*
 * Is t.name a $const'ant with an empty value?
 */
Empty-Const? t.name = <Empty-Expr? <Middle 3 0 <Lookup &Const t.name>>>;

/*
 * Verifies that argument becomes empty expression after unfolding all
 * $const'ants.
 */
Empty-Expr? {
  e t1 e \?
    {
      t1 : (REF t2), <Empty-Const? t2> \! $fail;
      = $fail;
    };
  empty;
};

/*
 * If in the end the value of $const'ant t.name is term then return that term.
 * Else $fail.
 */
Get-Const-Term t.name = <Get-Term <Middle 3 0 <Lookup &Const t.name>>>;

/*
 * If expression becomes term after unfolding all $const'ants then return that
 * term. Else $fail.
 */
Get-Term e0 t1 e2,
  # <Empty-Expr? t1> =
  <Empty-Expr? e2>,
  {
    t1 : (REF t.Name), <Lookup &Const t.Name> :: e.const =
      <Get-Term <Middle 3 0 e.const>>;
    t1;
  };