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

Last change on this file since 2034 was 2034, checked in by orlov, 14 years ago
  • Proper generation of debug info for use with Debug library (-dbg option).
  • Result expressions can contain blocks.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.7 KB
Line 
1// $Source$
2// $Revision: 2034 $
3// $Date: 2006-07-27 04:40:44 +0000 (Thu, 27 Jul 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) = <Check-Vars (e.vars) e.Re>, e.vars;
168        (PAREN e.Re) = <Check-Vars (e.vars) e.Re>, e.vars;
169        (CALL t t e.Re) = <Check-Vars (e.vars) e.Re>, e.vars;
170        (s.type t.Pragma e.name), s.type : \{ EVAR; SVAR; TVAR; VVAR; } =
171          {
172            e.vars : e (s.t t.p e.name) e,
173              {
174                s.t : s.type;
175                <Print-Error Error! Var-Type (s.t t.p e.name) s.type t.Pragma>;
176              };
177            <Print-Error Error! Var-Re (s.type t.Pragma e.name) t.Pragma>;
178          },
179          e.vars;
180        (FORMAT t e.He) =
181          <Vars e.He> : e.He-vars,
182          {
183            \? e.He-vars : e (s1 t.p1 e3) e (s2 t.p2 e3) e4,
184              {
185                s1 : s2;
186                <Print-Error Error! Var-Type (s1 t.p1 e3) s2 t.p2>;
187              },
188              <Print-Error Error! Var-Hard (s1 t.p1 e3) t.p2>,
189              e4 : /*empty*/ \! $fail;
190            <Update-Vars Format (e.vars) <Reverse e.He-vars>>;
191          };
192        (LEFT  t e.Pe) = <Update-Vars Pattern (e.vars) <Vars e.Pe>>;
193        (RIGHT t e.Pe) = <Update-Vars Pattern (e.vars) <Vars e.Pe>>;
194        (s.block t e.Branches), s.block : \{ BLOCK; BLOCK?; } =
195          {
196            e.Branches : e t.branch e,
197              <Check-Vars (e.vars) t.branch>,
198              $fail;
199            e.vars;
200          };
201        (BRANCH t e.Snt1) =
202          <Check-Vars (e.vars) e.Snt1>,
203          e.vars;
204        (ITER t.IterBody t.IterVars t.IterCondition) =
205          <Check-Vars (e.vars) t.IterVars t.IterBody>,
206          t.IterVars : (FORMAT t e.He),
207          <Update-Vars Format (e.vars) <Vars e.He>> :: e.vars,
208          <Check-Vars (e.vars) t.IterCondition>,
209          e.vars;
210        (TRY t.TryBranch e.NOFAIL t.CatchBlock) =
211          <Check-Vars (e.vars) t.TryBranch>,
212          <Check-Vars (e.vars) t.CatchBlock>,
213          e.vars;
214        t.any-other = e.vars;
215      } :: e.vars,
216      (e.vars) e.Snt;
217  } :: (e.vars) e.Sentence,
218  e.Sentence : /*empty*/;
219
220/*
221 * For each new var verifies that it is realy new (then adds it to the var
222 * list) or that it has right type. Returns updated list of variables.
223 */
224Update-Vars s.format? (e.vars) e.new-vars =
225  (e.vars) e.new-vars $iter {
226    e.new-vars : (s.type t.p2 e.name) e.rest,
227      e.vars : {
228        e (s.type t e.name) e = (e.vars) e.rest;
229        e1 (s.t t.p1 e.name) e2, {
230          s.format? : Format =
231            (e1 e2 (s.type t.p2 e.name)) e.rest;
232          <Print-Error Error! Var-Type (s.t t.p1 e.name) s.type t.p2>,
233            (e.vars) e.rest;
234        };
235        e = (e.vars (s.type t.p2 e.name)) e.rest;
236      };
237  } :: (e.vars) e.new-vars,
238  e.new-vars : /*empty*/,
239  e.vars;
240
241/*
242 * Returns the maximum (by length) sequence of cuts contained in t.arg.
243 * Cuts are represented by their pragmas.
244 * Fails and prints error message if there are unbalanced cuts after '=' or
245 * after $error. Prints error message, but not fails if there are unbalanced
246 * cuts in negation or trap-sentence.
247 */
248Get-Cuts t.arg, t.arg : {
249  (BRANCH t e.Sentence) = () e.Sentence;
250  t.Block = () t.Block;
251} $iter {
252  e.Sentence : e.Snt t.Statement, {
253    t.Statement : \{ (CUTALL t); (ERROR t); } =
254      {
255        <Print-Error Error! Cut <R 0 e.cuts>> = $fail;
256        () e.Snt;
257      };
258    t.Statement : {
259      (CUT t.Pragma) = e.cuts t.Pragma;
260      (STAKE t) = { <Middle 0 1 e.cuts>;; };
261      (NOT t.Branch) =
262        { <Print-Error Error! Cut <R 0 <Get-Cuts t.Branch>>>;; },
263        e.cuts;
264      (s.block t e.Branches), s.block : \{ BLOCK; BLOCK?; } =
265        () e.Branches $iter {
266          e.Branches : t.Branch e.rest =
267            { <Get-Cuts t.Branch>;; } :: e.branch-cuts,
268            {
269              <">" (<Length e.branch-cuts>) (<Length e.longest-cuts>)> =
270                (e.branch-cuts) e.rest;
271              (e.longest-cuts) e.rest;
272            };
273        } :: (e.longest-cuts) e.Branches,
274        e.Branches : /*empty*/ =
275        {
276          <">" (<Length e.cuts>) (<Length e.longest-cuts>)> =
277            e.cuts;
278          e.longest-cuts;
279        };
280      (ITER t.IterBody t.IterVars t.IterCond) =
281        <Get-Cuts t.IterCond> :: e.cuts,
282        <Get-Cuts t.IterBody> :: e.body-cuts,
283        {
284          <">" (<Length e.cuts>) (<Length e.body-cuts>)> =
285            e.cuts;
286          e.body-cuts;
287        };
288      (TRY t.TryBranch e.NOFAIL t.CatchBlock) =
289        { <Print-Error Error! Cut <R 0 <Get-Cuts t.TryBranch>>>;; },
290        <Get-Cuts t.CatchBlock>;
291//              <Get-Cuts e.CatchSnt> :: e.catch-cuts,
292//              {
293//                <">" (<Length e.cuts>) (<Length e.catch-cuts>)> =
294//                  e.cuts;
295//                e.catch-cuts;
296//              };
297      t.any-other = e.cuts;
298    } :: e.cuts,
299      (e.cuts) e.Snt;
300  };
301} :: (e.cuts) e.Sentence,
302  e.Sentence : /*empty*/,
303  e.cuts;
304
305
306
307Print-Error s.WE e.Descrip t.Pragma =
308  <? &Error-Counter> : s.n,
309  <Store &Error-Counter <"+" s.n 1>>,
310  <Print-Pragma &StdErr t.Pragma>,
311  <Print! &StdErr " " s.WE " ">,
312  s.WE e.Descrip : {
313    Error! Re = <PrintLN! &StdErr "Wrong format of result expression">;
314    Error! Call = <PrintLN! &StdErr "Wrong argument format in function call">;
315    Error! Pattern = <PrintLN! &StdErr "Wrong format of pattern expression">;
316    Warning! Pattern = <PrintLN! &StdErr "Clash can't be solved">;
317    Error! Var-Re t.var =
318      <PrintLN! &StdErr "Unknown variable '"
319                <AS-To-Ref t.var> "' in result expression">;
320    Error! Var-Hard t.var =
321      <PrintLN! &StdErr "Repeated occurence of the variable '"
322                <AS-To-Ref t.var> "' in hard expression">;
323    Error! Var-Type t.var s.type =
324      <PrintLN! &StdErr "Incorrect type '" <AS-To-Ref s.type>
325                "' of the variable '" <AS-To-Ref t.var> "'">;
326    Error! Cut = <PrintLN! &StdErr "'\\!' without corresponding '\\?'">;
327  };
328
329Print-Pragma s.channel (PRAGMA e.pragmas),
330  e.pragmas : {
331    e (FILE e.file-name) e, <Print! s.channel e.file-name>, $fail;
332    e (LINE s.line s.col) e, <Print! s.channel (s.line ", " s.col)>, $fail;
333    e = <Print! s.channel ":">;
334  };
335
336AS-To-Ref {
337  SVAR = 's';
338  TVAR = 't';
339  VVAR = 'v';
340  EVAR = 'e';
341  (s.tag t (e.name)) = <AS-To-Ref s.tag> '.' <To-Chars e.name>;
342};
343
Note: See TracBrowser for help on using the repository browser.