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

Last change on this file since 1950 was 1950, checked in by orlov, 15 years ago
  • A lot of changes for the compilation to Java. Self-translates to compilable Java-code!
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.0 KB
Line 
1// $Id: rfp_asail2asail.rf 1950 2006-05-07 01:17:28Z 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
13Simplify-ASAIL e.asail =
14  <Remove-Unreachable <Simplify e.asail>>;
15
16Simplify {
17  t.first e.rest, t.first : {
18    (IF (e.cond) e.body) =
19      <Map &Simplify-Infix (e.cond)> : {
20        0 = /*empty*/;
21        1 = <Simplify e.body>;
22        e.c = (IF (e.c) <Simplify e.body>);
23      };
24    (INT t.var e.expr) = (INT t.var <Simplify-Arithm (e.expr)>);
25    (e1) = (<Simplify e1>);
26    s1   = s1;
27  } :: e.first =
28    e.first <Simplify e.rest>;;
29};
30
31$box Blocks;
32$table Breaks;
33$box Last-Breaks;
34
35$func GetR s.box = t.right-term;
36GetR s.box =
37  <? s.box> : e1 t2,
38  <Store s.box e1>,
39  t2;
40
41Remove-Unreachable {
42  t1 e2, t1 : \{
43    (FUNC t.name t.in t.out e.body) =
44      <Put &Blocks (FUNC t.name t.in t.out)>,
45      <RFP-Clear-Table &Breaks>,
46      e.body;
47    (FUNC? t.name t.in t.out e.body) =
48      <Put &Blocks (FUNC? t.name t.in t.out)>,
49      <RFP-Clear-Table &Breaks>,
50      e.body;
51    (FOR (e.cont) (e.break) (e.cond) (e.step) e.body) =
52      <Put &Blocks (FOR (e.cont) (e.break) (e.cond) (e.step))>, e.body;
53    (LABEL (t.label) e.body) =
54      <Put &Blocks (LABEL (t.label))>, e.body;
55    (IF (e.cond) e.body) =
56      <Put &Blocks (IF (e.cond))>, e.body;
57    (TRY e.body) =
58      <Put &Blocks (TRY)>, e.body;
59    (CATCH-ERROR e.body) =
60      <Put &Blocks (CATCH-ERROR)>, e.body;
61  } :: e.body =
62    <Put &Last-Breaks ()>,
63    <Remove-Unreachable e.body> :: e.body,
64    <GetR &Blocks> : {
65      (LABEL (t.label)) = {
66        <In-Table? &Breaks t.label> = (LABEL (t.label) e.body) (e2);
67        {
68          <? &Blocks> : e (LABEL (t.other-label)),
69            <Lookup &Breaks t.other-label> : /*empty*/ =
70            <Unbind &Breaks t.other-label>;;
71        } =
72          /*empty*/ (e.body e2);
73      };
74      (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step)) = {
75        <In-Table? &Breaks e.break> =
76          (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step) e.body) (e2);
77        (FOR (e.cont) (e.break) (/*empty-cond*/) (e.step) e.body) ();
78      };
79      (CATCH-ERROR) = (CATCH-ERROR e.body) ();
80      (e.item) = (e.item e.body) (e2);
81    } :: e.t1 (e2),
82    <GetR &Last-Breaks> :: t.breaks,
83    {
84      e.t1 : v,
85        t.breaks : (e t.l e),
86        <Bind &Breaks (t.l) (Persistent)>,
87        $fail;;
88    },
89    e.t1 <Remove-Unreachable e2>;
90  t1 e2, t1 : \{
91    (BREAK t.label) =
92      <GetR &Last-Breaks> : (e.breaks),
93      <Put &Last-Breaks (e.breaks t.label)>,
94      {
95        <? &Blocks> : e (LABEL (t.label));
96        <Bind &Breaks (t.label) ()>, t1;
97      };
98    (CONTINUE t.label) = {
99      <? &Blocks> : e (FOR (t.label) (e.break) (e.cond) (e.step));
100      t1;
101    };
102    RETFAIL = t1;
103    (ERROR e) = t1;
104    FATAL = t1;
105  };
106  t1 e2 = t1 <Remove-Unreachable e2>;
107  /*empty*/ = /*empty*/;
108};
109
110
111$func "Eval *" e = e;
112$func "Eval /" e = e;
113$func "Eval %" e = e;
114$func "Eval +" e = e;
115$func "Eval -" e = e;
116
117Simplify-Infix /*txxx = <WriteLN SSS txxx>, txxx :*/ {
118  (INFIX s.op e.args), s.op : {
119    "*" = <Foldr1 &"Eval *" (<Map &Simplify-Arithm (e.args)>)>;
120    "/" = <Foldr1 &"Eval /" (<Map &Simplify-Arithm (e.args)>)>;
121    "%" = <Foldr1 &"Eval %" (<Map &Simplify-Arithm (e.args)>)>;
122    "+" = <Foldr1 &"Eval +" (<Map &Simplify-Arithm (e.args)>)>;
123    "-" = <Foldr1 &"Eval -" (<Map &Simplify-Arithm (e.args)>)>;
124    s   = <Map &Simplify-Arithm (e.args)>;
125  } : {
126    t1 = t1;
127    e1   = (INFIX s.op <Paren e1>);
128  };
129  (e1) = (<Map &Simplify-Infix (e1)>);
130  s1   = s1;
131};
132
133Simplify-Arithm (e.args) =
134  <Foldr1 &"Eval +" (<Map &Simplify-Infix (e.args)>)> : {
135    t1 = t1;
136    e1 = (INFIX "+" <Paren e1>);
137  };
138
139"Eval *" {
140  0  e     = 0;
141  e  0     = 0;
142  1  e2    = e2;
143  e1 1     = e1;
144  s1 e2 s3 = e2 <"*" s1 s3>;
145  s1 e2    = e2 s1;
146  e2       = e2;
147};
148
149"Eval +" {
150  0  e2    = e2;
151  e1 0     = e1;
152  s1 e2 s3 = e2 <"+" s1 s3>;
153  s1 e2    = e2 s1;
154  e2       = e2;
155};
156
157"Eval /" {
158  e1 1 = e1;
159  e1   = e1;
160};
161
162"Eval %" {
163  e1 1 = 0;
164  e1   = e1;
165};
166
167"Eval -" {
168  e1 0 = e1;
169  e1   = e1;
170};
171
Note: See TracBrowser for help on using the repository browser.