// $Id$

$use Apply Arithm Box Class Compare List StdIO Table;

$func Simplify_Infix t.asail_term = t.asail_term;
$func Simplify_Arithm e = e;

$func? Simplify_Cmp s.op (expr1) (expr2) = e;

$func Simplify e.asail = e.asail;

$func Remove_Unreachable e.asail = e.asail;

$func Remove_Dupl_Decl (e.decls) (e.subst) e.asail = e.asail;

$func Process_Var (e.decls) (e.subst) s.type t.var = e.maybe_decl (e.decls) (e.subst);

$func Free_Idx = s.idx;

$box Idx;


Simplify_ASAIL (MODULE t.ModuleName e.asail) =
  <Store &Idx>,
  (MODULE t.ModuleName <Remove_Dupl_Decl () () <Remove_Unreachable <Simplify e.asail>>>);

Simplify {
  t.first e.rest, t.first : {
    ("IF-INT-CMP" s.op (e.arg1) (e.arg2) e.body) = {
      <Simplify_Cmp s.op (<Simplify_Arithm (e.arg1)>) (<Simplify_Arithm (e.arg2)>)> : {
        (e1) (e2) = ("IF-INT-CMP" s.op (e1) (e2) <Simplify e.body>);
        /*empty*/ = <Simplify e.body>;
      };;
    };
    (IF t.cond e.body) = (IF t.cond <Simplify e.body>);
    (ASSIGN (INT t.var) e.expr) = (ASSIGN (INT t.var) <Simplify_Arithm (e.expr)>);
    (e1) = (<Simplify e1>);
    s1   = s1;
  } :: e.first =
    e.first <Simplify e.rest>;;
};

$box Blocks;
$table Breaks;
$box Last_Breaks;

$func? GetR s.box = t.right_term;
GetR s.box =
  <Get s.box> : e1 t2,
  <Store s.box e1>,
  t2;

Remove_Unreachable {
  t1 e2, t1 : \{
    (FUNC t.name t.in t.out e.body) =
      <Put &Blocks (FUNC t.name t.in t.out)>,
      <ClearTable &Breaks>,
      e.body;
    ("FUNC?" t.name t.in t.out e.body) =
      <Put &Blocks ("FUNC?" t.name t.in t.out)>,
      <ClearTable &Breaks>,
      e.body;
    (FOR (e.cont) (e.break) (e.cond) (e.step) e.body) =
      <Put &Blocks (FOR (e.cont) (e.break) (e.cond) (e.step))>, e.body;
    (LABEL (t.label) e.body) =
      <Put &Blocks (LABEL (t.label))>, e.body;
    (IF t.cond e.body) =
      <Put &Blocks (IF t.cond)>, e.body;
    ("IF-INT-CMP" s.op t.arg1 t.arg2 e.body) =
      <Put &Blocks ("IF-INT-CMP" s.op t.arg1 t.arg2)>, e.body;
    (TRY e.body) =
      <Put &Blocks (TRY)>, e.body;
    ("CATCH-ERROR" e.body) =
      <Put &Blocks ("CATCH-ERROR")>, e.body;
  } :: e.body =
    <Put &Last_Breaks ()>,
    <Remove_Unreachable e.body> :: e.body,
    <GetR &Blocks> : {
      (LABEL (t.label)) = {
        <IsInTable &Breaks t.label> = (LABEL (t.label) e.body) (e2);
        {
          <Get &Blocks> : e (LABEL (t.other_label)),
            <Lookup &Breaks t.other_label> : /*empty*/ =
            <Unbind &Breaks t.other_label>;;
        } =
          /*empty*/ (e.body e2);
      };
      (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step)) = {
        <IsInTable &Breaks e.break> =
          (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step) e.body) (e2);
        (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step) e.body) ();
      };
      (TRY) = {
        <Get &Last_Breaks> : e (e "Normal-Exit") =
          (TRY e.body) (e2);
        e2 : ("CATCH-ERROR" e.catch_body) e3,
          (TRY e.body) (("CATCH-ERROR" e.catch_body e3));
      };
      (e.item) = (e.item e.body) (e2);
    } :: e.t1 (e2),
    <GetR &Last_Breaks> :: t.breaks,
    {
      e.t1 : v,
        t.breaks : (e t.l e),
        <Bind &Breaks (t.l) (Persistent)>,
        $fail;;
    },
    e.t1 <Remove_Unreachable e2>;
  t1 e2, t1 : \{
    (BREAK t.label) =
      <GetR &Last_Breaks> : (e.breaks),
      <Put &Last_Breaks (e.breaks t.label)>,
      {
        <Get &Blocks> : e (LABEL (t.label));
        <Bind &Breaks (t.label) ()>, t1;
      };
    (CONTINUE t.label) = {
      <Get &Blocks> : e (FOR (t.label) (e.break) (e.cond) (e.step));
      t1;
    };
    RETFAIL = t1;
    (ERROR e) = t1;
    FATAL = t1;
  };
  t1 e2 = t1 <Remove_Unreachable e2>;
  /*empty*/ =
    {
      <GetR &Last_Breaks> : (e.breaks),
        <Put &Last_Breaks (e.breaks "Normal-Exit")>;;
    };
};


Remove_Dupl_Decl (e.decls) (e.subst) e.items, e.items : {
  t1 e.rest = {
    t1 : (DECL s.type t.var) =
      <Process_Var (e.decls) (e.subst) s.type t.var> :: e.d (e.decls) (e.subst),
      e.d <Remove_Dupl_Decl (e.decls) (e.subst) e.rest>;
    t1 : (s.split expr (e.len) t.var1 t.var2), s.split : \{ LSPLIT; RSPLIT; } =
      <Remove_Dupl_Decl (e.decls) (e.subst) expr (e.len)> :: expr,
      <Process_Var (e.decls) (e.subst) Split t.var1> :: e.decl1 (e.decls) (e.subst),
      {
        e.decl1 : (DECL s.type t.new_var) = t.new_var;
        t.var1;
      } :: t.var1,
      <Process_Var (e.decls) (e.subst) Split t.var2> :: e.decl2 (e.decls) (e.subst),
      {
        e.decl2 : (DECL s.type t.new_var) = t.new_var;
        t.var2;
      } :: t.var2,
      (s.split expr t.var1 t.var2) <Remove_Dupl_Decl (e.decls) (e.subst) e.rest>;
    e.subst : e (t1 t.new_var) e =
      <Remove_Dupl_Decl (e.decls) (e.subst) t.new_var e.rest>;
    t1 : (e2) =
      (<Remove_Dupl_Decl (e.decls) (e.subst) e2>) <Remove_Dupl_Decl (e.decls) (e.subst) e.rest>;
    t1 <Remove_Dupl_Decl (e.decls) (e.subst) e.rest>;
  };
  /*empty*/ = /*empty*/;
};

Process_Var (e.decls) (e.subst) s.type t.var, {
  e.decls : $r e (DECL s.type_old t.var) e = {
    s.type : s.type_old = /*empty*/ (e.decls) (e.subst);
    t.var : (s.tag e (e.name)),
      (s.tag 'dd' (e.name <Free_Idx>)) :: t.new_var,
      (DECL s.type t.new_var) :: t.decl,
      t.decl (e.decls t.decl) (e.subst (t.var t.new_var));
  };
  (DECL s.type t.var) (e.decls (DECL s.type t.var)) (e.subst);
};


$func Eval_Mult e = e;
$func Eval_Div e = e;
$func Eval_Rem e = e;
$func Eval_Add e = e;
$func Eval__ e = e;

Simplify_Infix /*txxx = <WriteLN SSS txxx>, txxx :*/ {
  (INFIX s.op e.args), s.op : {
    "*" = <Foldr1 &Eval_Mult (<Map &Simplify_Arithm (e.args)>)>;
    "/" = <Foldr1 &Eval_Div (<Map &Simplify_Arithm (e.args)>)>;
    "%" = <Foldr1 &Eval_Rem (<Map &Simplify_Arithm (e.args)>)>;
    "+" = <Foldr1 &Eval_Add (<Map &Simplify_Arithm (e.args)>)>;
    "-" = <Foldr1 &Eval__ (<Map &Simplify_Arithm (e.args)>)>;
    s   = <Map &Simplify_Arithm (e.args)>;
  } : {
    t1 = t1;
    e1   = (INFIX s.op <Paren e1>);
  };
  (e1) = (<Map &Simplify_Infix (e1)>);
  s1   = s1;
};

Simplify_Arithm (e.args) =
  <Foldr1 &Eval_Add (<Map &Simplify_Infix (e.args)>)> : {
    t1 = t1;
    e1 = (INFIX "+" <Paren e1>);
  };

Eval_Mult {
  0  e     = 0;
  e  0     = 0;
  1  e2    = e2;
  e1 1     = e1;
  s1 e2 s3 = e2 <Mult s1 s3>;
  s1 e2    = e2 s1;
  e2       = e2;
};

Eval_Add {
  0  e2    = e2;
  e1 0     = e1;
  s1 e2 s3 = e2 <Add s1 s3>;
  s1 e2    = e2 s1;
  e2       = e2;
};

Eval_Div {
  e1 1 = e1;
  e1   = e1;
};

Eval_Rem {
  e1 1 = 0;
  e1   = e1;
};

Eval__ {
  e1 0 = e1;
  e1   = e1;
};

$func? Cmp s.fn (expr1) (expr2) = e;

Simplify_Cmp s.op (expr1) (expr2) =
  s.op : { "!=" = &Ne; ">" = &Gt; "<" = &Lt; } :: s.op,
  <Cmp s.op (expr1) (expr2)>;

Cmp {
  s.fn (e11 tx e12) (e21 tx e22) =
    <Cmp s.fn (e11 e12) (e21 e22)>;
  s.fn (e1) (e2), <All &IsInt (e1)>, <All &IsInt (e2)> =
    <Apply s.fn (<Foldr1 &Add (e1)>) (<Foldr1 &Add (e2)>)>;
  s.fn (e1) (e2) = (e1) (e2);
};
  

Free_Idx =
  {
    <Get &Idx> : s1 = <Add s1 1>;
    1;
  } :: s1,
  <Store &Idx s1>,
  s1;