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

Last change on this file since 2043 was 2043, checked in by orlov, 14 years ago
  • Improved block extraction from result expressions.
  • Use asail2asail when converting to C++.
  • Remove duplicate declarations after cleanup of blocks

(rfp_asail2asail.Remove-Dupl-Decl).

  • Proper generation of debug info for $iter.
  • Fixed pragma-generation when comments are used.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.0 KB
Line 
1// $Id: rfp_asail2asail.rf 2043 2006-08-01 17:25:13Z orlov $
2
3$use Arithm Box List StdIO Table;
4$use "rfp_helper";
5
6$func Simplify-Infix t.asail-term = t.asail-term;
7$func Simplify-Arithm e = e;
8
9$func Simplify e.asail = e.asail;
10
11$func Remove-Unreachable e.asail = e.asail;
12
13$func Remove-Dupl-Decl (e.decls) (e.subst) e.asail = e.asail;
14
15$func Free-Idx = s.idx;
16
17
18Simplify-ASAIL e.asail =
19  <Remove-Dupl-Decl () () <Remove-Unreachable <Simplify e.asail>>>;
20
21Simplify {
22  t.first e.rest, t.first : {
23    (IF (e.cond) e.body) =
24      <Map &Simplify-Infix (e.cond)> : {
25        0 = /*empty*/;
26        1 = <Simplify e.body>;
27        e.c = (IF (e.c) <Simplify e.body>);
28      };
29    (INT t.var e.expr) = (INT t.var <Simplify-Arithm (e.expr)>);
30    (e1) = (<Simplify e1>);
31    s1   = s1;
32  } :: e.first =
33    e.first <Simplify e.rest>;;
34};
35
36$box Blocks;
37$table Breaks;
38$box Last-Breaks;
39
40$func? GetR s.box = t.right-term;
41GetR s.box =
42  <? s.box> : e1 t2,
43  <Store s.box e1>,
44  t2;
45
46Remove-Unreachable {
47  t1 e2, t1 : \{
48    (FUNC t.name t.in t.out e.body) =
49      <Put &Blocks (FUNC t.name t.in t.out)>,
50      <RFP-Clear-Table &Breaks>,
51      e.body;
52    (FUNC? t.name t.in t.out e.body) =
53      <Put &Blocks (FUNC? t.name t.in t.out)>,
54      <RFP-Clear-Table &Breaks>,
55      e.body;
56    (FOR (e.cont) (e.break) (e.cond) (e.step) e.body) =
57      <Put &Blocks (FOR (e.cont) (e.break) (e.cond) (e.step))>, e.body;
58    (LABEL (t.label) e.body) =
59      <Put &Blocks (LABEL (t.label))>, e.body;
60    (IF (e.cond) e.body) =
61      <Put &Blocks (IF (e.cond))>, e.body;
62    (TRY e.body) =
63      <Put &Blocks (TRY)>, e.body;
64    (CATCH-ERROR e.body) =
65      <Put &Blocks (CATCH-ERROR)>, e.body;
66  } :: e.body =
67    <Put &Last-Breaks ()>,
68    <Remove-Unreachable e.body> :: e.body,
69    <GetR &Blocks> : {
70      (LABEL (t.label)) = {
71        <In-Table? &Breaks t.label> = (LABEL (t.label) e.body) (e2);
72        {
73          <? &Blocks> : e (LABEL (t.other-label)),
74            <Lookup &Breaks t.other-label> : /*empty*/ =
75            <Unbind &Breaks t.other-label>;;
76        } =
77          /*empty*/ (e.body e2);
78      };
79      (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step)) = {
80        <In-Table? &Breaks e.break> =
81          (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step) e.body) (e2);
82        (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step) e.body) ();
83      };
84      (TRY) = {
85        <? &Last-Breaks> : e (e Normal-Exit) =
86          (TRY e.body) (e2);
87        e2 : (CATCH-ERROR e.catch-body) e3,
88          (TRY e.body) ((CATCH-ERROR e.catch-body e3));
89      };
90      (e.item) = (e.item e.body) (e2);
91    } :: e.t1 (e2),
92    <GetR &Last-Breaks> :: t.breaks,
93    {
94      e.t1 : v,
95        t.breaks : (e t.l e),
96        <Bind &Breaks (t.l) (Persistent)>,
97        $fail;;
98    },
99    e.t1 <Remove-Unreachable e2>;
100  t1 e2, t1 : \{
101    (BREAK t.label) =
102      <GetR &Last-Breaks> : (e.breaks),
103      <Put &Last-Breaks (e.breaks t.label)>,
104      {
105        <? &Blocks> : e (LABEL (t.label));
106        <Bind &Breaks (t.label) ()>, t1;
107      };
108    (CONTINUE t.label) = {
109      <? &Blocks> : e (FOR (t.label) (e.break) (e.cond) (e.step));
110      t1;
111    };
112    RETFAIL = t1;
113    (ERROR e) = t1;
114    FATAL = t1;
115  };
116  t1 e2 = t1 <Remove-Unreachable e2>;
117  /*empty*/ =
118    {
119      <GetR &Last-Breaks> : (e.breaks),
120        <Put &Last-Breaks (e.breaks Normal-Exit)>;;
121    };
122};
123
124
125Remove-Dupl-Decl (e.decls) (e.subst) e.items, e.items : {
126  t1 e.rest = {
127    t1 : (DECL s.type t.var) = {
128      e.decls : $r e (DECL s.type-old t.var) e = {
129        s.type : s.type-old = <Remove-Dupl-Decl (e.decls) (e.subst) e.rest>;
130        t.var : (s.tag e (e.name)),
131          (s.tag 'dd' (e.name <Free-Idx>)) :: t.new-var,
132          (DECL s.type t.new-var) :: t.new-decl,
133          t.new-decl <Remove-Dupl-Decl (e.decls t.new-decl) (e.subst (t.var t.new-var)) e.rest>;
134      };
135      t1 <Remove-Dupl-Decl (e.decls t1) (e.subst) e.rest>;
136    };
137    t1 : (EXPR t.var e.expr) = {
138      e.decls : $r e (DECL s.type-old t.var) e = {
139        s.type-old : Expr =
140          (ASSIGN t.var <Remove-Dupl-Decl (e.decls) (e.subst) e.expr>)
141          <Remove-Dupl-Decl (e.decls) (e.subst) e.rest>;
142        t.var : (s.tag e (e.name)),
143          (s.tag 'dd' (e.name <Free-Idx>)) :: t.new-var,
144          (EXPR t.new-var <Remove-Dupl-Decl (e.decls) (e.subst) e.expr>)
145          <Remove-Dupl-Decl (e.decls (DECL Expr t.new-var)) (e.subst (t.var t.new-var)) e.rest>;
146      };
147      (EXPR t.var <Remove-Dupl-Decl (e.decls) (e.subst) e.expr>)
148      <Remove-Dupl-Decl (e.decls (DECL Expr t.var)) (e.subst) e.rest>;
149    };
150    e.subst : e (t1 t.new-var) e =
151      <Remove-Dupl-Decl (e.decls) (e.subst) t.new-var e.rest>;
152    t1 : (e2) =
153      (<Remove-Dupl-Decl (e.decls) (e.subst) e2>) <Remove-Dupl-Decl (e.decls) (e.subst) e.rest>;
154    t1 <Remove-Dupl-Decl (e.decls) (e.subst) e.rest>;
155  };
156  /*empty*/ = /*empty*/;
157};
158
159
160$func "Eval *" e = e;
161$func "Eval /" e = e;
162$func "Eval %" e = e;
163$func "Eval +" e = e;
164$func "Eval -" e = e;
165
166Simplify-Infix /*txxx = <WriteLN SSS txxx>, txxx :*/ {
167  (INFIX s.op e.args), s.op : {
168    "*" = <Foldr1 &"Eval *" (<Map &Simplify-Arithm (e.args)>)>;
169    "/" = <Foldr1 &"Eval /" (<Map &Simplify-Arithm (e.args)>)>;
170    "%" = <Foldr1 &"Eval %" (<Map &Simplify-Arithm (e.args)>)>;
171    "+" = <Foldr1 &"Eval +" (<Map &Simplify-Arithm (e.args)>)>;
172    "-" = <Foldr1 &"Eval -" (<Map &Simplify-Arithm (e.args)>)>;
173    s   = <Map &Simplify-Arithm (e.args)>;
174  } : {
175    t1 = t1;
176    e1   = (INFIX s.op <Paren e1>);
177  };
178  (e1) = (<Map &Simplify-Infix (e1)>);
179  s1   = s1;
180};
181
182Simplify-Arithm (e.args) =
183  <Foldr1 &"Eval +" (<Map &Simplify-Infix (e.args)>)> : {
184    t1 = t1;
185    e1 = (INFIX "+" <Paren e1>);
186  };
187
188"Eval *" {
189  0  e     = 0;
190  e  0     = 0;
191  1  e2    = e2;
192  e1 1     = e1;
193  s1 e2 s3 = e2 <"*" s1 s3>;
194  s1 e2    = e2 s1;
195  e2       = e2;
196};
197
198"Eval +" {
199  0  e2    = e2;
200  e1 0     = e1;
201  s1 e2 s3 = e2 <"+" s1 s3>;
202  s1 e2    = e2 s1;
203  e2       = e2;
204};
205
206"Eval /" {
207  e1 1 = e1;
208  e1   = e1;
209};
210
211"Eval %" {
212  e1 1 = 0;
213  e1   = e1;
214};
215
216"Eval -" {
217  e1 0 = e1;
218  e1   = e1;
219};
220
221
222$box Idx;
223
224Free-Idx =
225  {
226    <? &Idx> : s1 = <"+" s1 1>;
227    1;
228  } :: s1,
229  <Store &Idx s1>,
230  s1;
231
Note: See TracBrowser for help on using the repository browser.