source: to-imperative/trunk/compiler/rfp_check.rf @ 1920

Last change on this file since 1920 was 1920, checked in by orlov, 15 years ago
  • Code formatting + small TFUNC fix.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.6 KB
Line 
1// $Source$
2// $Revision: 1920 $
3// $Date: 2006-04-10 18:21:09 +0000 (Mon, 10 Apr 2006) $
4
5$use Access Arithm Box Compare Convert List StdIO Table;
6
7$use "rfpc";
8$use "rfp_err";
9$use "rfp_compile";
10$use "rfp_format";
11$use "rfp_helper";
12$use "rfp_vars";
13
14// verifies that all constructions in e.Sentence have right formats
15$func? Satisfies-Format? (e.InFormat) (e.OutFormat) e.Sentence = ;
16
17// verifies that all function calls found in e.expr have appropriate input
18// formats
19$func Check-Inputs e.Sentence = ;
20
21// verifies that all vars in e.Sentence are defined for the moment of use and
22// that there aren't repeated indexes in hard expressions
23$func Check-Vars (e.vars) e.Sentence = ;
24
25// for each new var verifies that it is realy new (then adds it to the var
26// list) or that it has right type
27$func Update-Vars s.format (e.vars) e.new-vars = e.updated-vars;
28
29// returns the maximum (by length) sequence of cuts contained in the argument
30$func? Get-Cuts t.Branch-or-Block = e.cuts-sequence;
31
32// Print error or warning message
33$func Print-Error s.warning-or-error? e.description t.pragma = ;
34
35$func Print-Pragma s.channel t.Pragma = ;
36
37$func AS-To-Ref e.AS-Expr = e.Refal-Expr;
38
39
40RFP-Check e.Items, {
41  e.Items : e t.item e,
42    {
43      <Lookup &RFP-Options ITEMS> : v.targets =
44        v.targets : e t.name e,
45        t.item : (t t t t.name e);;
46    },
47    t.item : (s.linkage s.tag t.pragma t.name (e.in) (e.out) t.branch),
48    s.tag : \{ FUNC; FUNC?; TFUNC; },
49    { <Satisfies-Format? (<Format-Exp e.in>) (<Format-Exp e.out>) t.branch>;; },
50    <Check-Vars (<Vars e.in>) t.branch>,
51    { <Print-Error Error! Cut <R 0 <Get-Cuts t.branch>>>;; },
52    $fail;;
53};
54
55/*
56 *  Verifies that:
57 * 1) Result of e.Sentence computing has format not wider than e.OutFormat.
58 * 2) All constructions in e.Sentence returns expressions of right formats.
59 * 3) e.Sentence deals with expressions with format under e.InFormat only.
60 * 4) All function calls are performed with expressions of right formats.
61 */
62Satisfies-Format? (e.InFormat) (e.OutFormat) e.Sentence =
63  e.Sentence (e.OutFormat) $iter {
64    e.Sentence : $r e.Snt (ERROR t) e.queue =
65      <Satisfies-Format? () ((EVAR)) e.queue>,
66      e.Snt ();
67    e.Sentence : e.Snt t.Statement,
68      t.Statement : {
69        (RESULT t.Pragma e.ResultExpression) =
70          {
71            <Subformat? (e.OutFormat) (<Format-Exp e.ResultExpression>)> =
72              <Check-Inputs e.ResultExpression>,
73              e.Snt ();
74            <Print-Error Error! Re t.Pragma> = $fail;
75              /*
76               * So in the case of an error we can only return
77               * coordinates of the whole result expression, but
78               * not the concrete position of the error in a
79               * block if the later has place.
80               */
81          };
82        (FORMAT t.Pragma e.HardExpression) =
83//          \{
84//            <Subformat? (e.OutFormat) ()> =
85              e.Snt (<Format-Exp e.HardExpression>);
86//            <Print-Error Error! Re t.Statement>, $fail;
87//          };
88        (s.block t e.Branches), s.block : \{ BLOCK; BLOCK?; } =
89          {
90            e.Snt : /*empty*/ = /*empty*/;
91            (Comp Branch);
92          } :: e.pref,
93          {
94            e.Branches : e (BRANCH t e.Snt1) e,
95              <Satisfies-Format? (e.InFormat) (e.OutFormat) e.pref e.Snt1>,
96              $fail;
97            e.Snt ((EVAR));
98          };
99        (NOT (BRANCH t e.Snt1)) =
100          \{
101            <Subformat? (e.OutFormat) ()>,
102              e.Snt e.Snt1 ();
103            <Print-Error Error! Re t.Statement>, $fail;
104          };
105        (ITER (BRANCH t e.Snt1) (FORMAT t.Pragma e.HardExp) (BRANCH t e.Snt2)) =
106          <Format-Exp e.HardExp> :: e.HardFormat,
107          <Satisfies-Format? () (e.HardFormat) e.Snt1>,
108          e.Snt (FORMAT t.Pragma e.HardExp) e.Snt2 (e.OutFormat);
109        (TRY (BRANCH t e.Snt1) e.NOFAIL t.CatchBlock) =
110          <Satisfies-Format? () (e.OutFormat) e.Snt1>,
111          <Satisfies-Format? ((EVAR)) (e.OutFormat) t.CatchBlock>,
112          e.Snt ();
113        (s.tag t.Pragma e.PatternExpression), s.tag : \{ LEFT; RIGHT; } =
114//          {
115//            <Subformat? (e.OutFormat) ()>,
116              {
117                e.Snt : /*empty*/ =
118                  <Format-Exp e.PatternExpression> :: e.PatternFormat,
119                  {
120                    <Subformat? (e.InFormat) (e.PatternFormat)> =
121                      /*empty*/ ();
122                    <Print-Error Error! Pattern t.Pragma> = $fail;
123                  };
124                e.Snt ((EVAR));
125              };
126//            <Print-Error Error! Re t.Statement> \! $fail;
127//          };
128        NOFAIL = e.Snt ();
129        (FAIL t) = e.Snt ();
130        (CUTALL t) = e.Snt ();
131        (CUT t) = e.Snt ();
132        (STAKE t) = e.Snt ();
133        (BRANCH t e.Snt1) = e.Snt1 (e.OutFormat);
134        (Comp Branch) = /*empty*/ ();
135      };
136  } :: e.Sentence (e.OutFormat),
137  e.Sentence : /*empty*/;
138
139/*
140 * Verifies that all function calls found in e.expr have appropriate input
141 * formats.
142 */
143Check-Inputs {
144  t.first e.rest, t.first : {
145    (CALL t.Pragma t.Fname e.ResultExpression), {
146      <L 3 <Lookup-Func t.Fname>> : (e.Fin),
147        # <Subformat? (e.Fin) (<Format-Exp e.ResultExpression>)> =
148        <Print-Error Error! Call t.Pragma>;;
149    },
150      <Check-Inputs e.ResultExpression>;
151    (PAREN e.paren-expr) = <Check-Inputs e.paren-expr>;
152    t.var-or-symbol = /*empty*/;
153  },
154    <Check-Inputs e.rest>;
155  /*empty*/ = /*empty*/;
156};
157
158/*
159 * Verifies that all vars in e.Sentence are defined for the moment of use and
160 * that there are not repeated indexes in hard expressions.
161 * e.vars are known variables for the moment we have e.Sentence to dial with.
162 */
163Check-Vars (e.vars) e.Sentence =
164  (e.vars) e.Sentence $iter \{
165    e.Sentence : t.Statement e.Snt,
166      t.Statement : {
167        (RESULT t e.Re) =
168          {
169            <Vars e.Re> : e (s.type t.Pragma e.name) e,
170              {
171                e.vars : e (s.t t.p e.name) e,
172                  {
173                    s.t : s.type;
174                    <Print-Error Error!
175                      Var-Type (s.t t.p e.name) s.type t.Pragma>;
176                  };
177                <Print-Error Error!
178                  Var-Re (s.type t.Pragma e.name) t.Pragma>;
179              },
180              $fail;
181            e.vars;
182          };
183        (FORMAT t e.He) =
184          <Vars e.He> : e.He-vars,
185          {
186            \? e.He-vars : e (s1 t.p1 e3) e (s2 t.p2 e3) e4,
187              {
188                s1 : s2;
189                <Print-Error Error! Var-Type (s1 t.p1 e3) s2 t.p2>;
190              },
191              <Print-Error Error! Var-Hard (s1 t.p1 e3) t.p2>,
192              e4 : /*empty*/ \! $fail;
193            <Update-Vars Format (e.vars) <Reverse e.He-vars>>;
194          };
195        (LEFT  t e.Pe) = <Update-Vars Pattern (e.vars) <Vars e.Pe>>;
196        (RIGHT t e.Pe) = <Update-Vars Pattern (e.vars) <Vars e.Pe>>;
197        (s.block t e.Branches), s.block : \{ BLOCK; BLOCK?; } =
198          {
199            e.Branches : e t.branch e,
200              <Check-Vars (e.vars) t.branch>,
201              $fail;
202            e.vars;
203          };
204        (BRANCH t e.Snt1) =
205          <Check-Vars (e.vars) e.Snt1>,
206          e.vars;
207        (ITER t.IterBody t.IterVars t.IterCondition) =
208          <Check-Vars (e.vars) t.IterVars t.IterBody>,
209          t.IterVars : (FORMAT t e.He),
210          <Update-Vars Format (e.vars) <Vars e.He>> :: e.vars,
211          <Check-Vars (e.vars) t.IterCondition>,
212          e.vars;
213        (TRY t.TryBranch e.NOFAIL t.CatchBlock) =
214          <Check-Vars (e.vars) t.TryBranch>,
215          <Check-Vars (e.vars) t.CatchBlock>,
216          e.vars;
217        t.any-other = e.vars;
218      } :: e.vars,
219      (e.vars) e.Snt;
220  } :: (e.vars) e.Sentence,
221  e.Sentence : /*empty*/;
222
223/*
224 * For each new var verifies that it is realy new (then adds it to the var
225 * list) or that it has right type. Returns updated list of variables.
226 */
227Update-Vars s.format? (e.vars) e.new-vars =
228  (e.vars) e.new-vars $iter {
229    e.new-vars : (s.type t.p2 e.name) e.rest,
230      e.vars : {
231        e (s.type t e.name) e = (e.vars) e.rest;
232        e1 (s.t t.p1 e.name) e2, {
233          s.format? : Format =
234            (e1 e2 (s.type t.p2 e.name)) e.rest;
235          <Print-Error Error! Var-Type (s.t t.p1 e.name) s.type t.p2>,
236            (e.vars) e.rest;
237        };
238        e = (e.vars (s.type t.p2 e.name)) e.rest;
239      };
240  } :: (e.vars) e.new-vars,
241  e.new-vars : /*empty*/,
242  e.vars;
243
244/*
245 * Returns the maximum (by length) sequence of cuts contained in t.arg.
246 * Cuts are represented by their pragmas.
247 * Fails and prints error message if there are unbalanced cuts after '=' or
248 * after $error. Prints error message, but not fails if there are unbalanced
249 * cuts in negation or trap-sentence.
250 */
251Get-Cuts t.arg, t.arg : {
252  (BRANCH t e.Sentence) = () e.Sentence;
253  t.Block = () t.Block;
254} $iter {
255  e.Sentence : e.Snt t.Statement, {
256    t.Statement : \{ (CUTALL t); (ERROR t); } =
257      {
258        <Print-Error Error! Cut <R 0 e.cuts>> = $fail;
259        () e.Snt;
260      };
261    t.Statement : {
262      (CUT t.Pragma) = e.cuts t.Pragma;
263      (STAKE t) = { <Middle 0 1 e.cuts>;; };
264      (NOT t.Branch) =
265        { <Print-Error Error! Cut <R 0 <Get-Cuts t.Branch>>>;; },
266        e.cuts;
267      (s.block t e.Branches), s.block : \{ BLOCK; BLOCK?; } =
268        () e.Branches $iter {
269          e.Branches : t.Branch e.rest =
270            { <Get-Cuts t.Branch>;; } :: e.branch-cuts,
271            {
272              <">" (<Length e.branch-cuts>) (<Length e.longest-cuts>)> =
273                (e.branch-cuts) e.rest;
274              (e.longest-cuts) e.rest;
275            };
276        } :: (e.longest-cuts) e.Branches,
277        e.Branches : /*empty*/ =
278        {
279          <">" (<Length e.cuts>) (<Length e.longest-cuts>)> =
280            e.cuts;
281          e.longest-cuts;
282        };
283      (ITER t.IterBody t.IterVars t.IterCond) =
284        <Get-Cuts t.IterCond> :: e.cuts,
285        <Get-Cuts t.IterBody> :: e.body-cuts,
286        {
287          <">" (<Length e.cuts>) (<Length e.body-cuts>)> =
288            e.cuts;
289          e.body-cuts;
290        };
291      (TRY t.TryBranch e.NOFAIL t.CatchBlock) =
292        { <Print-Error Error! Cut <R 0 <Get-Cuts t.TryBranch>>>;; },
293        <Get-Cuts t.CatchBlock>;
294//              <Get-Cuts e.CatchSnt> :: e.catch-cuts,
295//              {
296//                <">" (<Length e.cuts>) (<Length e.catch-cuts>)> =
297//                  e.cuts;
298//                e.catch-cuts;
299//              };
300      t.any-other = e.cuts;
301    } :: e.cuts,
302      (e.cuts) e.Snt;
303  };
304} :: (e.cuts) e.Sentence,
305  e.Sentence : /*empty*/,
306  e.cuts;
307
308
309
310Print-Error s.WE e.Descrip t.Pragma =
311  <? &Error-Counter> : s.n,
312  <Store &Error-Counter <"+" s.n 1>>,
313  <Print-Pragma &StdErr t.Pragma>,
314  <Print! &StdErr " " s.WE " ">,
315  s.WE e.Descrip : {
316    Error! Re = <PrintLN! &StdErr "Wrong format of result expression">;
317    Error! Call = <PrintLN! &StdErr "Wrong argument format in function call">;
318    Error! Pattern = <PrintLN! &StdErr "Wrong format of pattern expression">;
319    Warning! Pattern = <PrintLN! &StdErr "Clash can't be solved">;
320    Error! Var-Re t.var =
321      <PrintLN! &StdErr "Unknown variable '"
322                <AS-To-Ref t.var> "' in result expression">;
323    Error! Var-Hard t.var =
324      <PrintLN! &StdErr "Repeated occurence of the variable '"
325                <AS-To-Ref t.var> "' in hard expression">;
326    Error! Var-Type t.var s.type =
327      <PrintLN! &StdErr "Incorrect type '" <AS-To-Ref s.type>
328                "' of the variable '" <AS-To-Ref t.var> "'">;
329    Error! Cut = <PrintLN! &StdErr "'\\!' without corresponding '\\?'">;
330  };
331
332Print-Pragma s.channel (PRAGMA e.pragmas),
333  e.pragmas : {
334    e (FILE e.file-name) e, <Print! s.channel e.file-name>, $fail;
335    e (LINE s.line s.col) e, <Print! s.channel (s.line ", " s.col)>, $fail;
336    e = <Print! s.channel ":">;
337  };
338
339AS-To-Ref {
340  SVAR = 's';
341  TVAR = 't';
342  VVAR = 'v';
343  EVAR = 'e';
344  (s.tag t (e.name)) = <AS-To-Ref s.tag> '.' <To-Chars e.name>;
345};
346
Note: See TracBrowser for help on using the repository browser.