source: to-imperative/trunk/compiler/rfp_asail2asail.rf @ 1950

// $Id: rfp_asail2asail.rf 1950 2006-05-07 01:17:28Z orlov $

$use Arithm Box List StdIO Table;
$use "rfp_helper";

$func Simplify-Infix t.asail-term = t.asail-term;
$func Simplify-Arithm e = e;

$func Simplify e.asail = e.asail;

$func Remove-Unreachable e.asail = e.asail;

Simplify-ASAIL e.asail =
  <Remove-Unreachable <Simplify e.asail>>;

Simplify {
  t.first e.rest, t.first : {
    (IF (e.cond) e.body) =
      <Map &Simplify-Infix (e.cond)> : {
        0 = /*empty*/;
        1 = <Simplify e.body>;
        e.c = (IF (e.c) <Simplify e.body>);
      };
    (INT t.var e.expr) = (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 =
  <? 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)>,
      <RFP-Clear-Table &Breaks>,
      e.body;
    (FUNC? t.name t.in t.out e.body) =
      <Put &Blocks (FUNC? t.name t.in t.out)>,
      <RFP-Clear-Table &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 (e.cond) e.body) =
      <Put &Blocks (IF (e.cond))>, 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)) = {
        <In-Table? &Breaks t.label> = (LABEL (t.label) e.body) (e2);
        {
          <? &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)) = {
        <In-Table? &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) ();
      };
      (CATCH-ERROR) = (CATCH-ERROR e.body) ();
      (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)>,
      {
        <? &Blocks> : e (LABEL (t.label));
        <Bind &Breaks (t.label) ()>, t1;
      };
    (CONTINUE t.label) = {
      <? &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*/ = /*empty*/;
};


$func "Eval *" e = e;
$func "Eval /" e = e;
$func "Eval %" e = e;
$func "Eval +" e = e;
$func "Eval -" e = e;

Simplify-Infix /*txxx = <WriteLN SSS txxx>, txxx :*/ {
  (INFIX s.op e.args), s.op : {
    "*" = <Foldr1 &"Eval *" (<Map &Simplify-Arithm (e.args)>)>;
    "/" = <Foldr1 &"Eval /" (<Map &Simplify-Arithm (e.args)>)>;
    "%" = <Foldr1 &"Eval %" (<Map &Simplify-Arithm (e.args)>)>;
    "+" = <Foldr1 &"Eval +" (<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 +" (<Map &Simplify-Infix (e.args)>)> : {
    t1 = t1;
    e1 = (INFIX "+" <Paren e1>);
  };

"Eval *" {
  0  e     = 0;
  e  0     = 0;
  1  e2    = e2;
  e1 1     = e1;
  s1 e2 s3 = e2 <"*" s1 s3>;
  s1 e2    = e2 s1;
  e2       = e2;
};

"Eval +" {
  0  e2    = e2;
  e1 0     = e1;
  s1 e2 s3 = e2 <"+" s1 s3>;
  s1 e2    = e2 s1;
  e2       = e2;
};

"Eval /" {
  e1 1 = e1;
  e1   = e1;
};

"Eval %" {
  e1 1 = 0;
  e1   = e1;
};

"Eval -" {
  e1 0 = e1;
  e1   = e1;
};