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

$use Access Arithm Box Compare Convert List StdIO Table;

$use "rfpc";
$use "rfp_err";
$use "rfp_compile";
$use "rfp_format";
$use "rfp_helper";
$use "rfp_vars";

// verifies that all constructions in e.Sentence have right formats
$func? IsSatisfies_Format (e.InFormat) (e.OutFormat) e.Sentence = ;

// verifies that all function calls found in e.expr have appropriate input
// formats
$func Check_Inputs e.Sentence = ;

// verifies that all vars in e.Sentence are defined for the moment of use and
// that there aren't repeated indexes in hard expressions
$func Check_Vars (e.vars) e.Sentence = ;

// for each new var verifies that it is realy new (then adds it to the var
// list) or that it has right type
$func Update_Vars s.format (e.vars) e.new_vars = e.updated_vars;

// returns the maximum (by length) sequence of cuts contained in the argument
$func? Get_Cuts t.Branch_or_Block = e.cuts_sequence;

// Print error or warning message
$func Print_Error s.Iswarning_or_error e.description t.pragma = ;

$func Print_Pragma s.channel t.Pragma = ;

$func AS_To_Ref e.AS_Expr = e.Refal_Expr;


RFP_Check e.Items, {
  e.Items : e t.item e,
    {
      <Lookup &RFP_Options ITEMS> : v.targets =
        v.targets : e t.name e,
        t.item : (t t t t.name e);;
    },
    t.item : (s.linkage s.tag t.pragma t.name (e.in) (e.out) t.branch),
    s.tag : \{ FUNC; "FUNC?"; TFUNC; },
    { <IsSatisfies_Format (<Format_Exp e.in>) (<Format_Exp e.out>) t.branch>;; },
    <Check_Vars (<Vars e.in>) t.branch>,
    { <Print_Error "Error!" Cut <R 0 <Get_Cuts t.branch>>>;; },
    $fail;;
};

/*
 *  Verifies that:
 * 1) Result of e.Sentence computing has format not wider than e.OutFormat.
 * 2) All constructions in e.Sentence returns expressions of right formats.
 * 3) e.Sentence deals with expressions with format under e.InFormat only.
 * 4) All function calls are performed with expressions of right formats.
 */
IsSatisfies_Format (e.InFormat) (e.OutFormat) e.Sentence, \{
  e.Sentence : $r e.Snt (ERROR t) e.queue =
    <IsSatisfies_Format () ((EVAR)) e.queue>,
    <IsSatisfies_Format (e.InFormat) () e.Snt>;
  e.Sentence (e.OutFormat) $iter {
    e.Sentence : e.Snt t.Statement,
      t.Statement : {
        (RESULT t.Pragma e.ResultExpression) =
          {
            e.ResultExpression : (s.block e), s.block : \{ BLOCK; "BLOCK?"; } =
              <IsSatisfies_Format () (e.OutFormat) e.ResultExpression>,
              e.Snt ();
            <IsSubformat (e.OutFormat) (<Format_Exp e.ResultExpression>)> =
              <Check_Inputs e.ResultExpression>,
              e.Snt ();
            <Print_Error "Error!" Re t.Pragma> = $fail;
              /*
               * So in the case of an error we can only return
               * coordinates of the whole result expression, but
               * not the concrete position of the error in a
               * block if the later has place.
               */
          };
        (FORMAT t.Pragma e.HardExpression) =
//          \{
//            <Subformat? (e.OutFormat) ()> =
              e.Snt (<Format_Exp e.HardExpression>);
//            <Print-Error Error! Re t.Statement>, $fail;
//          };
        (s.block t e.Branches), s.block : \{ BLOCK; "BLOCK?"; } =
          {
            e.Snt : /*empty*/ = /*empty*/;
            (Comp Branch);
          } :: e.pref,
          {
            e.Branches : e (BRANCH t e.Snt1) e,
              <IsSatisfies_Format (e.InFormat) (e.OutFormat) e.pref e.Snt1>,
              $fail;
            e.Snt ((EVAR));
          };
        (NOT (BRANCH t e.Snt1)) =
          \{
            <IsSubformat (e.OutFormat) ()>,
              e.Snt e.Snt1 ();
            <Print_Error "Error!" Re t.Statement>, $fail;
          };
        (ITER (BRANCH t e.Snt1) (FORMAT t.Pragma e.HardExp) (BRANCH t e.Snt2)) =
          <Format_Exp e.HardExp> :: e.HardFormat,
          <IsSatisfies_Format () (e.HardFormat) e.Snt1>,
          e.Snt (FORMAT t.Pragma e.HardExp) e.Snt2 (e.OutFormat);
        (TRY (BRANCH t e.Snt1) e.NOFAIL t.CatchBlock) = 
          <IsSatisfies_Format () (e.OutFormat) e.Snt1>,
          <IsSatisfies_Format ((EVAR)) (e.OutFormat) t.CatchBlock>,
          e.Snt ();
        (s.tag t.Pragma e.PatternExpression), s.tag : \{ LEFT; RIGHT; } =
//          {
//            <Subformat? (e.OutFormat) ()>,
              {
                e.Snt : /*empty*/ =
                  <Format_Exp e.PatternExpression> :: e.PatternFormat,
                  {
                    <IsSubformat (e.InFormat) (e.PatternFormat)> =
                      /*empty*/ ();
                    <Print_Error "Error!" Pattern t.Pragma> = $fail;
                  };
                e.Snt ((EVAR));
              };
//            <Print-Error Error! Re t.Statement> \! $fail;
//          };
        NOFAIL = e.Snt ();
        (FAIL t) = e.Snt ();
        (CUTALL t) = e.Snt ();
        (CUT t) = e.Snt ();
        (STAKE t) = e.Snt ();
        (BRANCH t e.Snt1) =
          <IsSatisfies_Format (e.InFormat) (e.OutFormat) e.Snt1> ();
        (Comp Branch) = /*empty*/ ();
      };
  } :: e.Sentence (e.OutFormat),
  e.Sentence : /*empty*/;
};

/*
 * Verifies that all function calls found in e.expr have appropriate input
 * formats.
 */
Check_Inputs {
  t.first e.rest, t.first : {
    (CALL t.Pragma t.Fname e.ResultExpression), {
      <L 3 <Lookup_Func t.Fname>> : (e.Fin),
        # <IsSubformat (e.Fin) (<Format_Exp e.ResultExpression>)> =
        <Print_Error "Error!" Call t.Pragma>;;
    },
      <Check_Inputs e.ResultExpression>;
    (PAREN e.paren_expr) = <Check_Inputs e.paren_expr>;
    t.var_or_symbol = /*empty*/;
  },
    <Check_Inputs e.rest>;
  /*empty*/ = /*empty*/;
};

/*
 * Verifies that all vars in e.Sentence are defined for the moment of use and
 * that there are not repeated indexes in hard expressions.
 * e.vars are known variables for the moment we have e.Sentence to dial with.
 */
Check_Vars (e.vars) e.Sentence =
  (e.vars) e.Sentence $iter \{
    e.Sentence : t.Statement e.Snt,
      t.Statement : {
        (RESULT t e.Re) = <Check_Vars (e.vars) e.Re>, e.vars;
        (PAREN e.Re) = <Check_Vars (e.vars) e.Re>, e.vars;
        (CALL t t e.Re) = <Check_Vars (e.vars) e.Re>, e.vars;
        (s.type t.Pragma e.name), s.type : \{ EVAR; SVAR; TVAR; VVAR; } =
          {
            e.vars : e (s.t t.p e.name) e,
              {
                s.t : s.type;
                <Print_Error "Error!" "Var-Type" (s.t t.p e.name) s.type t.Pragma>;
              };
            <Print_Error "Error!" "Var-Re" (s.type t.Pragma e.name) t.Pragma>;
          },
          e.vars;
        (FORMAT t e.He) =
          <Vars e.He> : e.He_vars,
          {
            \? e.He_vars : e (s1 t.p1 e3) e (s2 t.p2 e3) e4,
              {
                s1 : s2;
                <Print_Error "Error!" "Var-Type" (s1 t.p1 e3) s2 t.p2>;
              },
              <Print_Error "Error!" "Var-Hard" (s1 t.p1 e3) t.p2>,
              e4 : /*empty*/ \! $fail;
            <Update_Vars Format (e.vars) <Reverse e.He_vars>>;
          };
        (LEFT  t e.Pe) = <Update_Vars Pattern (e.vars) <Vars e.Pe>>;
        (RIGHT t e.Pe) = <Update_Vars Pattern (e.vars) <Vars e.Pe>>;
        (s.block t e.Branches), s.block : \{ BLOCK; "BLOCK?"; } =
          {
            e.Branches : e t.branch e,
              <Check_Vars (e.vars) t.branch>,
              $fail;
            e.vars;
          };
        (BRANCH t e.Snt1) =
          <Check_Vars (e.vars) e.Snt1>,
          e.vars;
        (ITER t.IterBody t.IterVars t.IterCondition) =
          <Check_Vars (e.vars) t.IterVars t.IterBody>,
          t.IterVars : (FORMAT t e.He),
          <Update_Vars Format (e.vars) <Vars e.He>> :: e.vars,
          <Check_Vars (e.vars) t.IterCondition>,
          e.vars;
        (TRY t.TryBranch e.NOFAIL t.CatchBlock) =
          <Check_Vars (e.vars) t.TryBranch>,
          <Check_Vars (e.vars) t.CatchBlock>,
          e.vars;
        t.any_other = e.vars;
      } :: e.vars,
      (e.vars) e.Snt;
  } :: (e.vars) e.Sentence,
  e.Sentence : /*empty*/;

/*
 * For each new var verifies that it is realy new (then adds it to the var
 * list) or that it has right type. Returns updated list of variables.
 */
Update_Vars s.Isformat (e.vars) e.new_vars =
  (e.vars) e.new_vars $iter {
    e.new_vars : (s.type t.p2 e.name) e.rest,
      e.vars : {
        e (s.type t e.name) e = (e.vars) e.rest;
        e1 (s.t t.p1 e.name) e2, {
          s.Isformat : Format =
            (e1 e2 (s.type t.p2 e.name)) e.rest;
          <Print_Error "Error!" "Var-Type" (s.t t.p1 e.name) s.type t.p2>,
            (e.vars) e.rest;
        };
        e = (e.vars (s.type t.p2 e.name)) e.rest;
      };
  } :: (e.vars) e.new_vars,
  e.new_vars : /*empty*/,
  e.vars;

/*
 * Returns the maximum (by length) sequence of cuts contained in t.arg.
 * Cuts are represented by their pragmas.
 * Fails and prints error message if there are unbalanced cuts after '=' or
 * after $error. Prints error message, but not fails if there are unbalanced
 * cuts in negation or trap-sentence.
 */
Get_Cuts t.arg, t.arg : {
  (BRANCH t e.Sentence) = () e.Sentence;
  t.Block = () t.Block;
} $iter {
  e.Sentence : e.Snt t.Statement, {
    t.Statement : \{ (CUTALL t); (ERROR t); } =
      {
        <Print_Error "Error!" Cut <R 0 e.cuts>> = $fail;
        () e.Snt;
      };
    t.Statement : {
      (CUT t.Pragma) = e.cuts t.Pragma;
      (STAKE t) = { <Middle 0 1 e.cuts>;; };
      (NOT t.Branch) =
        { <Print_Error "Error!" Cut <R 0 <Get_Cuts t.Branch>>>;; },
        e.cuts;
      (s.block t e.Branches), s.block : \{ BLOCK; "BLOCK?"; } =
        () e.Branches $iter {
          e.Branches : t.Branch e.rest =
            { <Get_Cuts t.Branch>;; } :: e.branch_cuts,
            {
              <Gt (<Length e.branch_cuts>) (<Length e.longest_cuts>)> =
                (e.branch_cuts) e.rest;
              (e.longest_cuts) e.rest;
            };
        } :: (e.longest_cuts) e.Branches,
        e.Branches : /*empty*/ =
        {
          <Gt (<Length e.cuts>) (<Length e.longest_cuts>)> =
            e.cuts;
          e.longest_cuts;
        };
      (ITER t.IterBody t.IterVars t.IterCond) =
        <Get_Cuts t.IterCond> :: e.cuts,
        <Get_Cuts t.IterBody> :: e.body_cuts,
        {
          <Gt (<Length e.cuts>) (<Length e.body_cuts>)> =
            e.cuts;
          e.body_cuts;
        };
      (TRY t.TryBranch e.NOFAIL t.CatchBlock) =
        { <Print_Error "Error!" Cut <R 0 <Get_Cuts t.TryBranch>>>;; },
        <Get_Cuts t.CatchBlock>;
//              <Get-Cuts e.CatchSnt> :: e.catch-cuts,
//              {
//                <">" (<Length e.cuts>) (<Length e.catch-cuts>)> =
//                  e.cuts;
//                e.catch-cuts;
//              };
      t.any_other = e.cuts;
    } :: e.cuts,
      (e.cuts) e.Snt;
  };
} :: (e.cuts) e.Sentence,
  e.Sentence : /*empty*/,
  e.cuts;



Print_Error s.WE e.Descrip t.Pragma =
  {
    <Get &Error_Counter> : s.n = s.n;
    0;
  } :: s.n,
  <Store &Error_Counter <Arithm.Add s.n 1>>,
  <Print_Pragma &StdErr t.Pragma>,
  <PrintCh &StdErr " " s.WE " ">,
  s.WE e.Descrip : {
    "Error!" Re = <PrintLnCh &StdErr "Wrong format of result expression">;
    "Error!" Call = <PrintLnCh &StdErr "Wrong argument format in function call">;
    "Error!" Pattern = <PrintLnCh &StdErr "Wrong format of pattern expression">;
    "Warning!" Pattern = <PrintLnCh &StdErr "Clash can't be solved">;
    "Error!" "Var-Re" t.var =
      <PrintLnCh &StdErr "Unknown variable '"
                <AS_To_Ref t.var> "' in result expression">;
    "Error!" "Var-Hard" t.var =
      <PrintLnCh &StdErr "Repeated occurence of the variable '"
                <AS_To_Ref t.var> "' in hard expression">;
    "Error!" "Var-Type" t.var s.type =
      <PrintLnCh &StdErr "Incorrect type '" <AS_To_Ref s.type>
                "' of the variable '" <AS_To_Ref t.var> "'">;
    "Error!" Cut = <PrintLnCh &StdErr "'\\!' without corresponding '\\?'">;
  };

Print_Pragma s.channel (PRAGMA e.pragmas),
  e.pragmas : {
    e (FILE e.file_name) e, <PrintCh s.channel e.file_name>, $fail;
    e (LINE s.line s.col) e, <PrintCh s.channel (s.line ", " s.col)>, $fail;
    e = <PrintCh s.channel ":">;
  };

AS_To_Ref {
  SVAR = 's';
  TVAR = 't';
  VVAR = 'v';
  EVAR = 'e';
  (s.tag t (e.name)) = <AS_To_Ref s.tag> '.' <ToChars e.name>;
};