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

Last change on this file since 2455 was 2455, checked in by orlov, 14 years ago
  • Working compilation to C++. No .hh-files.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.2 KB
Line 
1// $Id: rfp_asail2asail.rf 2455 2007-02-24 05:01:39Z orlov $
2
3$use Apply Arithm Box Class Compare List StdIO Table;
4
5$func Simplify-Infix t.asail-term = t.asail-term;
6$func Simplify-Arithm e = e;
7
8$func? Simplify-Cmp s.op (expr1) (expr2) = e;
9
10$func Simplify e.asail = e.asail;
11
12$func Remove-Unreachable e.asail = e.asail;
13
14$func Remove-Dupl-Decl (e.decls) (e.subst) e.asail = e.asail;
15
16$func Process-Var (e.decls) (e.subst) s.type t.var = e.maybe-decl (e.decls) (e.subst);
17
18$func Free-Idx = s.idx;
19
20$box Idx;
21
22
23Simplify-ASAIL (MODULE t.ModuleName e.asail) =
24  <Store &Idx>,
25  (MODULE t.ModuleName <Remove-Dupl-Decl () () <Remove-Unreachable <Simplify e.asail>>>);
26
27Simplify {
28  t.first e.rest, t.first : {
29    (IF-INT-CMP s.op (e.arg1) (e.arg2) e.body) = {
30      <Simplify-Cmp s.op (<Simplify-Arithm (e.arg1)>) (<Simplify-Arithm (e.arg2)>)> : {
31        (e1) (e2) = (IF-INT-CMP s.op (e1) (e2) <Simplify e.body>);
32        /*empty*/ = <Simplify e.body>;
33      };;
34    };
35    (IF t.cond e.body) = (IF t.cond <Simplify e.body>);
36    (INT t.var e.expr) = (INT t.var <Simplify-Arithm (e.expr)>);
37    (e1) = (<Simplify e1>);
38    s1   = s1;
39  } :: e.first =
40    e.first <Simplify e.rest>;;
41};
42
43$box Blocks;
44$table Breaks;
45$box Last-Breaks;
46
47$func? GetR s.box = t.right-term;
48GetR s.box =
49  <? s.box> : e1 t2,
50  <Store s.box e1>,
51  t2;
52
53Remove-Unreachable {
54  t1 e2, t1 : \{
55    (FUNC t.name t.in t.out e.body) =
56      <Put &Blocks (FUNC t.name t.in t.out)>,
57      <Clear-Table &Breaks>,
58      e.body;
59    (FUNC? t.name t.in t.out e.body) =
60      <Put &Blocks (FUNC? t.name t.in t.out)>,
61      <Clear-Table &Breaks>,
62      e.body;
63    (FOR (e.cont) (e.break) (e.cond) (e.step) e.body) =
64      <Put &Blocks (FOR (e.cont) (e.break) (e.cond) (e.step))>, e.body;
65    (LABEL (t.label) e.body) =
66      <Put &Blocks (LABEL (t.label))>, e.body;
67    (IF t.cond e.body) =
68      <Put &Blocks (IF t.cond)>, e.body;
69    (IF-INT-CMP s.op t.arg1 t.arg2 e.body) =
70      <Put &Blocks (IF-INT-CMP s.op t.arg1 t.arg2)>, e.body;
71    (TRY e.body) =
72      <Put &Blocks (TRY)>, e.body;
73    (CATCH-ERROR e.body) =
74      <Put &Blocks (CATCH-ERROR)>, e.body;
75  } :: e.body =
76    <Put &Last-Breaks ()>,
77    <Remove-Unreachable e.body> :: e.body,
78    <GetR &Blocks> : {
79      (LABEL (t.label)) = {
80        <In-Table? &Breaks t.label> = (LABEL (t.label) e.body) (e2);
81        {
82          <? &Blocks> : e (LABEL (t.other-label)),
83            <Lookup &Breaks t.other-label> : /*empty*/ =
84            <Unbind &Breaks t.other-label>;;
85        } =
86          /*empty*/ (e.body e2);
87      };
88      (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step)) = {
89        <In-Table? &Breaks e.break> =
90          (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step) e.body) (e2);
91        (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step) e.body) ();
92      };
93      (TRY) = {
94        <? &Last-Breaks> : e (e Normal-Exit) =
95          (TRY e.body) (e2);
96        e2 : (CATCH-ERROR e.catch-body) e3,
97          (TRY e.body) ((CATCH-ERROR e.catch-body e3));
98      };
99      (e.item) = (e.item e.body) (e2);
100    } :: e.t1 (e2),
101    <GetR &Last-Breaks> :: t.breaks,
102    {
103      e.t1 : v,
104        t.breaks : (e t.l e),
105        <Bind &Breaks (t.l) (Persistent)>,
106        $fail;;
107    },
108    e.t1 <Remove-Unreachable e2>;
109  t1 e2, t1 : \{
110    (BREAK t.label) =
111      <GetR &Last-Breaks> : (e.breaks),
112      <Put &Last-Breaks (e.breaks t.label)>,
113      {
114        <? &Blocks> : e (LABEL (t.label));
115        <Bind &Breaks (t.label) ()>, t1;
116      };
117    (CONTINUE t.label) = {
118      <? &Blocks> : e (FOR (t.label) (e.break) (e.cond) (e.step));
119      t1;
120    };
121    RETFAIL = t1;
122    (ERROR e) = t1;
123    FATAL = t1;
124  };
125  t1 e2 = t1 <Remove-Unreachable e2>;
126  /*empty*/ =
127    {
128      <GetR &Last-Breaks> : (e.breaks),
129        <Put &Last-Breaks (e.breaks Normal-Exit)>;;
130    };
131};
132
133
134Remove-Dupl-Decl (e.decls) (e.subst) e.items, e.items : {
135  t1 e.rest = {
136    t1 : (DECL s.type t.var) =
137      <Process-Var (e.decls) (e.subst) s.type t.var> :: e.d (e.decls) (e.subst),
138      e.d <Remove-Dupl-Decl (e.decls) (e.subst) e.rest>;
139    t1 : (EXPR t.var e.expr) =
140      <Process-Var (e.decls) (e.subst) Expr t.var> :: e.d (e.decls2) (e.subst2),
141      {
142        e.d : (DECL s t.new-var) =
143          (EXPR t.new-var <Remove-Dupl-Decl (e.decls) (e.subst) e.expr>)
144          <Remove-Dupl-Decl (e.decls2) (e.subst2) e.rest>;
145        (ASSIGN t.var <Remove-Dupl-Decl (e.decls) (e.subst) e.expr>)
146        <Remove-Dupl-Decl (e.decls2) (e.subst2) e.rest>;
147      };
148    t1 : (s.split expr (e.len) t.var1 t.var2), s.split : \{ LSPLIT; RSPLIT; } =
149      <Remove-Dupl-Decl (e.decls) (e.subst) expr (e.len)> :: expr,
150      <Process-Var (e.decls) (e.subst) Split t.var1> :: e.decl1 (e.decls) (e.subst),
151      {
152        e.decl1 : (DECL s.type t.new-var) = t.new-var;
153        t.var1;
154      } :: t.var1,
155      <Process-Var (e.decls) (e.subst) Split t.var2> :: e.decl2 (e.decls) (e.subst),
156      {
157        e.decl2 : (DECL s.type t.new-var) = t.new-var;
158        t.var2;
159      } :: t.var2,
160      (s.split expr t.var1 t.var2) <Remove-Dupl-Decl (e.decls) (e.subst) e.rest>;
161    e.subst : e (t1 t.new-var) e =
162      <Remove-Dupl-Decl (e.decls) (e.subst) t.new-var e.rest>;
163    t1 : (e2) =
164      (<Remove-Dupl-Decl (e.decls) (e.subst) e2>) <Remove-Dupl-Decl (e.decls) (e.subst) e.rest>;
165    t1 <Remove-Dupl-Decl (e.decls) (e.subst) e.rest>;
166  };
167  /*empty*/ = /*empty*/;
168};
169
170Process-Var (e.decls) (e.subst) s.type t.var, {
171  e.decls : $r e (DECL s.type-old t.var) e = {
172    s.type : s.type-old = /*empty*/ (e.decls) (e.subst);
173    t.var : (s.tag e (e.name)),
174      (s.tag 'dd' (e.name <Free-Idx>)) :: t.new-var,
175      (DECL s.type t.new-var) :: t.decl,
176      t.decl (e.decls t.decl) (e.subst (t.var t.new-var));
177  };
178  (DECL s.type t.var) (e.decls (DECL s.type t.var)) (e.subst);
179};
180
181
182$func "Eval *" e = e;
183$func "Eval /" e = e;
184$func "Eval %" e = e;
185$func "Eval +" e = e;
186$func "Eval -" e = e;
187
188Simplify-Infix /*txxx = <WriteLN SSS txxx>, txxx :*/ {
189  (INFIX s.op e.args), s.op : {
190    "*" = <Foldr1 &"Eval *" (<Map &Simplify-Arithm (e.args)>)>;
191    "/" = <Foldr1 &"Eval /" (<Map &Simplify-Arithm (e.args)>)>;
192    "%" = <Foldr1 &"Eval %" (<Map &Simplify-Arithm (e.args)>)>;
193    "+" = <Foldr1 &"Eval +" (<Map &Simplify-Arithm (e.args)>)>;
194    "-" = <Foldr1 &"Eval -" (<Map &Simplify-Arithm (e.args)>)>;
195    s   = <Map &Simplify-Arithm (e.args)>;
196  } : {
197    t1 = t1;
198    e1   = (INFIX s.op <Paren e1>);
199  };
200  (e1) = (<Map &Simplify-Infix (e1)>);
201  s1   = s1;
202};
203
204Simplify-Arithm (e.args) =
205  <Foldr1 &"Eval +" (<Map &Simplify-Infix (e.args)>)> : {
206    t1 = t1;
207    e1 = (INFIX "+" <Paren e1>);
208  };
209
210"Eval *" {
211  0  e     = 0;
212  e  0     = 0;
213  1  e2    = e2;
214  e1 1     = e1;
215  s1 e2 s3 = e2 <"*" s1 s3>;
216  s1 e2    = e2 s1;
217  e2       = e2;
218};
219
220"Eval +" {
221  0  e2    = e2;
222  e1 0     = e1;
223  s1 e2 s3 = e2 <"+" s1 s3>;
224  s1 e2    = e2 s1;
225  e2       = e2;
226};
227
228"Eval /" {
229  e1 1 = e1;
230  e1   = e1;
231};
232
233"Eval %" {
234  e1 1 = 0;
235  e1   = e1;
236};
237
238"Eval -" {
239  e1 0 = e1;
240  e1   = e1;
241};
242
243$func? Cmp s.fn (expr1) (expr2) = e;
244
245Simplify-Cmp s.op (expr1) (expr2) =
246  s.op : { "!=" = &"/="; ">" = &">"; "<" = &"<"; } :: s.op,
247  <Cmp s.op (expr1) (expr2)>;
248
249Cmp {
250  s.fn (e11 tx e12) (e21 tx e22) =
251    <Cmp s.fn (e11 e12) (e21 e22)>;
252  s.fn (e1) (e2), <All &Int? (e1)>, <All &Int? (e2)> =
253    <Apply s.fn (<Foldr1 &"+" (e1)>) (<Foldr1 &"+" (e2)>)>;
254  s.fn (e1) (e2) = (e1) (e2);
255};
256 
257
258Free-Idx =
259  {
260    <? &Idx> : s1 = <"+" s1 1>;
261    1;
262  } :: s1,
263  <Store &Idx s1>,
264  s1;
265
Note: See TracBrowser for help on using the repository browser.