|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT SYSTEM UTILITIES --
|
|
|
4 -- --
|
|
|
5 -- C S I N F O --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 -- Check consistency of sinfo.ads and sinfo.adb. Checks that field name usage
|
|
|
27 -- is consistent and that assertion cross-reference lists are correct, as well
|
|
|
28 -- as making sure that all the comments on field name usage are consistent.
|
|
|
29
|
|
|
30 -- Note that this is used both as a standalone program, and as a procedure
|
|
|
31 -- called by XSinfo. This raises an unhandled exception if it finds any
|
|
|
32 -- errors; we don't attempt any sophisticated error recovery.
|
|
|
33
|
|
|
34 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
|
|
35 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
|
|
|
36 with Ada.Strings.Maps; use Ada.Strings.Maps;
|
|
|
37 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
|
|
|
38 with Ada.Text_IO; use Ada.Text_IO;
|
|
|
39
|
|
|
40 with GNAT.Spitbol; use GNAT.Spitbol;
|
|
|
41 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
|
|
42 with GNAT.Spitbol.Table_Boolean;
|
|
|
43 with GNAT.Spitbol.Table_VString;
|
|
|
44
|
|
|
45 procedure CSinfo is
|
|
|
46
|
|
|
47 package TB renames GNAT.Spitbol.Table_Boolean;
|
|
|
48 package TV renames GNAT.Spitbol.Table_VString;
|
|
|
49 use TB, TV;
|
|
|
50
|
|
|
51 Infil : File_Type;
|
|
|
52 Lineno : Natural := 0;
|
|
|
53
|
|
|
54 Err : exception;
|
|
|
55 -- Raised on fatal error
|
|
|
56
|
|
|
57 Done : exception;
|
|
|
58 -- Raised after error is found to terminate run
|
|
|
59
|
|
|
60 WSP : constant Pattern := Span (' ' & ASCII.HT);
|
|
|
61
|
|
|
62 Fields : TV.Table (300);
|
|
|
63 Fields1 : TV.Table (300);
|
|
|
64 Refs : TV.Table (300);
|
|
|
65 Refscopy : TV.Table (300);
|
|
|
66 Special : TB.Table (50);
|
|
|
67 Inlines : TV.Table (100);
|
|
|
68
|
|
|
69 -- The following define the standard fields used for binary operator,
|
|
|
70 -- unary operator, and other expression nodes. Numbers in the range 1-5
|
|
|
71 -- refer to the Fieldn fields. Letters D-R refer to flags:
|
|
|
72
|
|
|
73 -- D = Flag4
|
|
|
74 -- E = Flag5
|
|
|
75 -- F = Flag6
|
|
|
76 -- G = Flag7
|
|
|
77 -- H = Flag8
|
|
|
78 -- I = Flag9
|
|
|
79 -- J = Flag10
|
|
|
80 -- K = Flag11
|
|
|
81 -- L = Flag12
|
|
|
82 -- M = Flag13
|
|
|
83 -- N = Flag14
|
|
|
84 -- O = Flag15
|
|
|
85 -- P = Flag16
|
|
|
86 -- Q = Flag17
|
|
|
87 -- R = Flag18
|
|
|
88
|
|
|
89 Flags : TV.Table (20);
|
|
|
90 -- Maps flag numbers to letters
|
|
|
91
|
|
|
92 N_Fields : constant Pattern := BreakX ("JL");
|
|
|
93 E_Fields : constant Pattern := BreakX ("5EFGHIJLOP");
|
|
|
94 U_Fields : constant Pattern := BreakX ("1345EFGHIJKLOPQ");
|
|
|
95 B_Fields : constant Pattern := BreakX ("12345EFGHIJKLOPQ");
|
|
|
96
|
|
|
97 Line : VString;
|
|
|
98 Bad : Boolean;
|
|
|
99
|
|
|
100 Field : constant VString := Nul;
|
|
|
101 Fields_Used : VString := Nul;
|
|
|
102 Name : constant VString := Nul;
|
|
|
103 Next : constant VString := Nul;
|
|
|
104 Node : VString := Nul;
|
|
|
105 Ref : VString := Nul;
|
|
|
106 Synonym : constant VString := Nul;
|
|
|
107 Nxtref : constant VString := Nul;
|
|
|
108
|
|
|
109 Which_Field : aliased VString := Nul;
|
|
|
110
|
|
|
111 Node_Search : constant Pattern := WSP & "-- N_" & Rest * Node;
|
|
|
112 Break_Punc : constant Pattern := Break (" .,");
|
|
|
113 Plus_Binary : constant Pattern := WSP
|
|
|
114 & "-- plus fields for binary operator";
|
|
|
115 Plus_Unary : constant Pattern := WSP
|
|
|
116 & "-- plus fields for unary operator";
|
|
|
117 Plus_Expr : constant Pattern := WSP
|
|
|
118 & "-- plus fields for expression";
|
|
|
119 Break_Syn : constant Pattern := WSP & "-- "
|
|
|
120 & Break (' ') * Synonym
|
|
|
121 & " (" & Break (')') * Field;
|
|
|
122 Break_Field : constant Pattern := BreakX ('-') * Field;
|
|
|
123 Get_Field : constant Pattern := BreakX (Decimal_Digit_Set)
|
|
|
124 & Span (Decimal_Digit_Set) * Which_Field;
|
|
|
125 Break_WFld : constant Pattern := Break (Which_Field'Access);
|
|
|
126 Get_Funcsyn : constant Pattern := WSP & "function " & Rest * Synonym;
|
|
|
127 Extr_Field : constant Pattern := BreakX ('-') & "-- " & Rest * Field;
|
|
|
128 Get_Procsyn : constant Pattern := WSP & "procedure Set_" & Rest * Synonym;
|
|
|
129 Get_Inline : constant Pattern := WSP & "pragma Inline ("
|
|
|
130 & Break (')') * Name;
|
|
|
131 Set_Name : constant Pattern := "Set_" & Rest * Name;
|
|
|
132 Func_Rest : constant Pattern := " function " & Rest * Synonym;
|
|
|
133 Get_Nxtref : constant Pattern := Break (',') * Nxtref & ',';
|
|
|
134 Test_Syn : constant Pattern := Break ('=') & "= N_"
|
|
|
135 & (Break (" ,)") or Rest) * Next;
|
|
|
136 Chop_Comma : constant Pattern := BreakX (',') * Next;
|
|
|
137 Return_Fld : constant Pattern := WSP & "return " & Break (' ') * Field;
|
|
|
138 Set_Syn : constant Pattern := " procedure Set_" & Rest * Synonym;
|
|
|
139 Set_Fld : constant Pattern := WSP & "Set_" & Break (' ') * Field
|
|
|
140 & " (N, Val)";
|
|
|
141 Break_With : constant Pattern := Break ('_') ** Field & "_With_Parent";
|
|
|
142
|
|
|
143 type VStringA is array (Natural range <>) of VString;
|
|
|
144
|
|
|
145 procedure Next_Line;
|
|
|
146 -- Read next line trimmed from Infil into Line and bump Lineno
|
|
|
147
|
|
|
148 procedure Sort (A : in out VStringA);
|
|
|
149 -- Sort a (small) array of VString's
|
|
|
150
|
|
|
151 procedure Next_Line is
|
|
|
152 begin
|
|
|
153 Line := Get_Line (Infil);
|
|
|
154 Trim (Line);
|
|
|
155 Lineno := Lineno + 1;
|
|
|
156 end Next_Line;
|
|
|
157
|
|
|
158 procedure Sort (A : in out VStringA) is
|
|
|
159 Temp : VString;
|
|
|
160 begin
|
|
|
161 <<Sort>>
|
|
|
162 for J in 1 .. A'Length - 1 loop
|
|
|
163 if A (J) > A (J + 1) then
|
|
|
164 Temp := A (J);
|
|
|
165 A (J) := A (J + 1);
|
|
|
166 A (J + 1) := Temp;
|
|
|
167 goto Sort;
|
|
|
168 end if;
|
|
|
169 end loop;
|
|
|
170 end Sort;
|
|
|
171
|
|
|
172 -- Start of processing for CSinfo
|
|
|
173
|
|
|
174 begin
|
|
|
175 Anchored_Mode := True;
|
|
|
176 New_Line;
|
|
|
177 Open (Infil, In_File, "sinfo.ads");
|
|
|
178 Put_Line ("Check for field name consistency");
|
|
|
179
|
|
|
180 -- Setup table for mapping flag numbers to letters
|
|
|
181
|
|
|
182 Set (Flags, "4", V ("D"));
|
|
|
183 Set (Flags, "5", V ("E"));
|
|
|
184 Set (Flags, "6", V ("F"));
|
|
|
185 Set (Flags, "7", V ("G"));
|
|
|
186 Set (Flags, "8", V ("H"));
|
|
|
187 Set (Flags, "9", V ("I"));
|
|
|
188 Set (Flags, "10", V ("J"));
|
|
|
189 Set (Flags, "11", V ("K"));
|
|
|
190 Set (Flags, "12", V ("L"));
|
|
|
191 Set (Flags, "13", V ("M"));
|
|
|
192 Set (Flags, "14", V ("N"));
|
|
|
193 Set (Flags, "15", V ("O"));
|
|
|
194 Set (Flags, "16", V ("P"));
|
|
|
195 Set (Flags, "17", V ("Q"));
|
|
|
196 Set (Flags, "18", V ("R"));
|
|
|
197
|
|
|
198 -- Special fields table. The following names are not recorded or checked
|
|
|
199 -- by Csinfo, since they are specially handled. This means that any field
|
|
|
200 -- definition or subprogram with a matching name is ignored.
|
|
|
201
|
|
|
202 Set (Special, "Analyzed", True);
|
|
|
203 Set (Special, "Assignment_OK", True);
|
|
|
204 Set (Special, "Associated_Node", True);
|
|
|
205 Set (Special, "Cannot_Be_Constant", True);
|
|
|
206 Set (Special, "Chars", True);
|
|
|
207 Set (Special, "Comes_From_Source", True);
|
|
|
208 Set (Special, "Do_Overflow_Check", True);
|
|
|
209 Set (Special, "Do_Range_Check", True);
|
|
|
210 Set (Special, "Entity", True);
|
|
|
211 Set (Special, "Entity_Or_Associated_Node", True);
|
|
|
212 Set (Special, "Error_Posted", True);
|
|
|
213 Set (Special, "Etype", True);
|
|
|
214 Set (Special, "Evaluate_Once", True);
|
|
|
215 Set (Special, "First_Itype", True);
|
|
|
216 Set (Special, "Has_Aspect_Specifications", True);
|
|
|
217 Set (Special, "Has_Dynamic_Itype", True);
|
|
|
218 Set (Special, "Has_Dynamic_Range_Check", True);
|
|
|
219 Set (Special, "Has_Dynamic_Length_Check", True);
|
|
|
220 Set (Special, "Has_Private_View", True);
|
|
|
221 Set (Special, "Is_Controlling_Actual", True);
|
|
|
222 Set (Special, "Is_Overloaded", True);
|
|
|
223 Set (Special, "Is_Static_Expression", True);
|
|
|
224 Set (Special, "Left_Opnd", True);
|
|
|
225 Set (Special, "Must_Not_Freeze", True);
|
|
|
226 Set (Special, "Nkind_In", True);
|
|
|
227 Set (Special, "Parens", True);
|
|
|
228 Set (Special, "Pragma_Name", True);
|
|
|
229 Set (Special, "Raises_Constraint_Error", True);
|
|
|
230 Set (Special, "Right_Opnd", True);
|
|
|
231
|
|
|
232 -- Loop to acquire information from node definitions in sinfo.ads,
|
|
|
233 -- checking for consistency in Op/Flag assignments to each synonym
|
|
|
234
|
|
|
235 loop
|
|
|
236 Bad := False;
|
|
|
237 Next_Line;
|
|
|
238 exit when Match (Line, " -- Node Access Functions");
|
|
|
239
|
|
|
240 if Match (Line, Node_Search)
|
|
|
241 and then not Match (Node, Break_Punc)
|
|
|
242 then
|
|
|
243 Fields_Used := Nul;
|
|
|
244
|
|
|
245 elsif Node = "" then
|
|
|
246 null;
|
|
|
247
|
|
|
248 elsif Line = "" then
|
|
|
249 Node := Nul;
|
|
|
250
|
|
|
251 elsif Match (Line, Plus_Binary) then
|
|
|
252 Bad := Match (Fields_Used, B_Fields);
|
|
|
253
|
|
|
254 elsif Match (Line, Plus_Unary) then
|
|
|
255 Bad := Match (Fields_Used, U_Fields);
|
|
|
256
|
|
|
257 elsif Match (Line, Plus_Expr) then
|
|
|
258 Bad := Match (Fields_Used, E_Fields);
|
|
|
259
|
|
|
260 elsif not Match (Line, Break_Syn) then
|
|
|
261 null;
|
|
|
262
|
|
|
263 elsif Match (Synonym, "plus") then
|
|
|
264 null;
|
|
|
265
|
|
|
266 else
|
|
|
267 Match (Field, Break_Field);
|
|
|
268
|
|
|
269 if not Present (Special, Synonym) then
|
|
|
270 if Present (Fields, Synonym) then
|
|
|
271 if Field /= Get (Fields, Synonym) then
|
|
|
272 Put_Line
|
|
|
273 ("Inconsistent field reference at line" &
|
|
|
274 Lineno'Img & " for " & Synonym);
|
|
|
275 raise Done;
|
|
|
276 end if;
|
|
|
277
|
|
|
278 else
|
|
|
279 Set (Fields, Synonym, Field);
|
|
|
280 end if;
|
|
|
281
|
|
|
282 Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym));
|
|
|
283 Match (Field, Get_Field);
|
|
|
284
|
|
|
285 if Match (Field, "Flag") then
|
|
|
286 Which_Field := Get (Flags, Which_Field);
|
|
|
287 end if;
|
|
|
288
|
|
|
289 if Match (Fields_Used, Break_WFld) then
|
|
|
290 Put_Line
|
|
|
291 ("Overlapping field at line " & Lineno'Img &
|
|
|
292 " for " & Synonym);
|
|
|
293 raise Done;
|
|
|
294 end if;
|
|
|
295
|
|
|
296 Append (Fields_Used, Which_Field);
|
|
|
297 Bad := Bad or Match (Fields_Used, N_Fields);
|
|
|
298 end if;
|
|
|
299 end if;
|
|
|
300
|
|
|
301 if Bad then
|
|
|
302 Put_Line ("fields conflict with standard fields for node " & Node);
|
|
|
303 raise Done;
|
|
|
304 end if;
|
|
|
305 end loop;
|
|
|
306
|
|
|
307 Put_Line (" OK");
|
|
|
308 New_Line;
|
|
|
309 Put_Line ("Check for function consistency");
|
|
|
310
|
|
|
311 -- Loop through field function definitions to make sure they are OK
|
|
|
312
|
|
|
313 Fields1 := Fields;
|
|
|
314 loop
|
|
|
315 Next_Line;
|
|
|
316 exit when Match (Line, " -- Node Update");
|
|
|
317
|
|
|
318 if Match (Line, Get_Funcsyn)
|
|
|
319 and then not Present (Special, Synonym)
|
|
|
320 then
|
|
|
321 if not Present (Fields1, Synonym) then
|
|
|
322 Put_Line
|
|
|
323 ("function on line " & Lineno &
|
|
|
324 " is for unused synonym");
|
|
|
325 raise Done;
|
|
|
326 end if;
|
|
|
327
|
|
|
328 Next_Line;
|
|
|
329
|
|
|
330 if not Match (Line, Extr_Field) then
|
|
|
331 raise Err;
|
|
|
332 end if;
|
|
|
333
|
|
|
334 if Field /= Get (Fields1, Synonym) then
|
|
|
335 Put_Line ("Wrong field in function " & Synonym);
|
|
|
336 raise Done;
|
|
|
337
|
|
|
338 else
|
|
|
339 Delete (Fields1, Synonym);
|
|
|
340 end if;
|
|
|
341 end if;
|
|
|
342 end loop;
|
|
|
343
|
|
|
344 Put_Line (" OK");
|
|
|
345 New_Line;
|
|
|
346 Put_Line ("Check for missing functions");
|
|
|
347
|
|
|
348 declare
|
|
|
349 List : constant TV.Table_Array := Convert_To_Array (Fields1);
|
|
|
350
|
|
|
351 begin
|
|
|
352 if List'Length > 0 then
|
|
|
353 Put_Line ("No function for field synonym " & List (1).Name);
|
|
|
354 raise Done;
|
|
|
355 end if;
|
|
|
356 end;
|
|
|
357
|
|
|
358 -- Check field set procedures
|
|
|
359
|
|
|
360 Put_Line (" OK");
|
|
|
361 New_Line;
|
|
|
362 Put_Line ("Check for set procedure consistency");
|
|
|
363
|
|
|
364 Fields1 := Fields;
|
|
|
365 loop
|
|
|
366 Next_Line;
|
|
|
367 exit when Match (Line, " -- Inline Pragmas");
|
|
|
368 exit when Match (Line, " -- Iterator Procedures");
|
|
|
369
|
|
|
370 if Match (Line, Get_Procsyn)
|
|
|
371 and then not Present (Special, Synonym)
|
|
|
372 then
|
|
|
373 if not Present (Fields1, Synonym) then
|
|
|
374 Put_Line
|
|
|
375 ("procedure on line " & Lineno & " is for unused synonym");
|
|
|
376 raise Done;
|
|
|
377 end if;
|
|
|
378
|
|
|
379 Next_Line;
|
|
|
380
|
|
|
381 if not Match (Line, Extr_Field) then
|
|
|
382 raise Err;
|
|
|
383 end if;
|
|
|
384
|
|
|
385 if Field /= Get (Fields1, Synonym) then
|
|
|
386 Put_Line ("Wrong field in procedure Set_" & Synonym);
|
|
|
387 raise Done;
|
|
|
388
|
|
|
389 else
|
|
|
390 Delete (Fields1, Synonym);
|
|
|
391 end if;
|
|
|
392 end if;
|
|
|
393 end loop;
|
|
|
394
|
|
|
395 Put_Line (" OK");
|
|
|
396 New_Line;
|
|
|
397 Put_Line ("Check for missing set procedures");
|
|
|
398
|
|
|
399 declare
|
|
|
400 List : constant TV.Table_Array := Convert_To_Array (Fields1);
|
|
|
401
|
|
|
402 begin
|
|
|
403 if List'Length > 0 then
|
|
|
404 Put_Line ("No procedure for field synonym Set_" & List (1).Name);
|
|
|
405 raise Done;
|
|
|
406 end if;
|
|
|
407 end;
|
|
|
408
|
|
|
409 Put_Line (" OK");
|
|
|
410 New_Line;
|
|
|
411 Put_Line ("Check pragma Inlines are all for existing subprograms");
|
|
|
412
|
|
|
413 Clear (Fields1);
|
|
|
414 while not End_Of_File (Infil) loop
|
|
|
415 Next_Line;
|
|
|
416
|
|
|
417 if Match (Line, Get_Inline)
|
|
|
418 and then not Present (Special, Name)
|
|
|
419 then
|
|
|
420 exit when Match (Name, Set_Name);
|
|
|
421
|
|
|
422 if not Present (Fields, Name) then
|
|
|
423 Put_Line
|
|
|
424 ("Pragma Inline on line " & Lineno &
|
|
|
425 " does not correspond to synonym");
|
|
|
426 raise Done;
|
|
|
427
|
|
|
428 else
|
|
|
429 Set (Inlines, Name, Get (Inlines, Name) & 'r');
|
|
|
430 end if;
|
|
|
431 end if;
|
|
|
432 end loop;
|
|
|
433
|
|
|
434 Put_Line (" OK");
|
|
|
435 New_Line;
|
|
|
436 Put_Line ("Check no pragma Inlines were omitted");
|
|
|
437
|
|
|
438 declare
|
|
|
439 List : constant TV.Table_Array := Convert_To_Array (Fields);
|
|
|
440 Nxt : VString := Nul;
|
|
|
441
|
|
|
442 begin
|
|
|
443 for M in List'Range loop
|
|
|
444 Nxt := List (M).Name;
|
|
|
445
|
|
|
446 if Get (Inlines, Nxt) /= "r" then
|
|
|
447 Put_Line ("Incorrect pragma Inlines for " & Nxt);
|
|
|
448 raise Done;
|
|
|
449 end if;
|
|
|
450 end loop;
|
|
|
451 end;
|
|
|
452
|
|
|
453 Put_Line (" OK");
|
|
|
454 New_Line;
|
|
|
455 Clear (Inlines);
|
|
|
456
|
|
|
457 Close (Infil);
|
|
|
458 Open (Infil, In_File, "sinfo.adb");
|
|
|
459 Lineno := 0;
|
|
|
460 Put_Line ("Check references in functions in body");
|
|
|
461
|
|
|
462 Refscopy := Refs;
|
|
|
463 loop
|
|
|
464 Next_Line;
|
|
|
465 exit when Match (Line, " -- Field Access Functions --");
|
|
|
466 end loop;
|
|
|
467
|
|
|
468 loop
|
|
|
469 Next_Line;
|
|
|
470 exit when Match (Line, " -- Field Set Procedures --");
|
|
|
471
|
|
|
472 if Match (Line, Func_Rest)
|
|
|
473 and then not Present (Special, Synonym)
|
|
|
474 then
|
|
|
475 Ref := Get (Refs, Synonym);
|
|
|
476 Delete (Refs, Synonym);
|
|
|
477
|
|
|
478 if Ref = "" then
|
|
|
479 Put_Line
|
|
|
480 ("Function on line " & Lineno & " is for unknown synonym");
|
|
|
481 raise Err;
|
|
|
482 end if;
|
|
|
483
|
|
|
484 -- Alpha sort of references for this entry
|
|
|
485
|
|
|
486 declare
|
|
|
487 Refa : VStringA (1 .. 100);
|
|
|
488 N : Natural := 0;
|
|
|
489
|
|
|
490 begin
|
|
|
491 loop
|
|
|
492 exit when not Match (Ref, Get_Nxtref, Nul);
|
|
|
493 N := N + 1;
|
|
|
494 Refa (N) := Nxtref;
|
|
|
495 end loop;
|
|
|
496
|
|
|
497 Sort (Refa (1 .. N));
|
|
|
498 Next_Line;
|
|
|
499 Next_Line;
|
|
|
500 Next_Line;
|
|
|
501
|
|
|
502 -- Checking references for one entry
|
|
|
503
|
|
|
504 for M in 1 .. N loop
|
|
|
505 Next_Line;
|
|
|
506
|
|
|
507 if not Match (Line, Test_Syn) then
|
|
|
508 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
|
|
|
509 raise Done;
|
|
|
510 end if;
|
|
|
511
|
|
|
512 Match (Next, Chop_Comma);
|
|
|
513
|
|
|
514 if Next /= Refa (M) then
|
|
|
515 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
|
|
|
516 raise Done;
|
|
|
517 end if;
|
|
|
518 end loop;
|
|
|
519
|
|
|
520 Next_Line;
|
|
|
521 Match (Line, Return_Fld);
|
|
|
522
|
|
|
523 if Field /= Get (Fields, Synonym) then
|
|
|
524 Put_Line
|
|
|
525 ("Wrong field for function " & Synonym & " at line " &
|
|
|
526 Lineno & " should be " & Get (Fields, Synonym));
|
|
|
527 raise Done;
|
|
|
528 end if;
|
|
|
529 end;
|
|
|
530 end if;
|
|
|
531 end loop;
|
|
|
532
|
|
|
533 Put_Line (" OK");
|
|
|
534 New_Line;
|
|
|
535 Put_Line ("Check for missing functions in body");
|
|
|
536
|
|
|
537 declare
|
|
|
538 List : constant TV.Table_Array := Convert_To_Array (Refs);
|
|
|
539
|
|
|
540 begin
|
|
|
541 if List'Length /= 0 then
|
|
|
542 Put_Line ("Missing function " & List (1).Name & " in body");
|
|
|
543 raise Done;
|
|
|
544 end if;
|
|
|
545 end;
|
|
|
546
|
|
|
547 Put_Line (" OK");
|
|
|
548 New_Line;
|
|
|
549 Put_Line ("Check Set procedures in body");
|
|
|
550 Refs := Refscopy;
|
|
|
551
|
|
|
552 loop
|
|
|
553 Next_Line;
|
|
|
554 exit when Match (Line, "end");
|
|
|
555 exit when Match (Line, " -- Iterator Procedures");
|
|
|
556
|
|
|
557 if Match (Line, Set_Syn)
|
|
|
558 and then not Present (Special, Synonym)
|
|
|
559 then
|
|
|
560 Ref := Get (Refs, Synonym);
|
|
|
561 Delete (Refs, Synonym);
|
|
|
562
|
|
|
563 if Ref = "" then
|
|
|
564 Put_Line
|
|
|
565 ("Function on line " & Lineno & " is for unknown synonym");
|
|
|
566 raise Err;
|
|
|
567 end if;
|
|
|
568
|
|
|
569 -- Alpha sort of references for this entry
|
|
|
570
|
|
|
571 declare
|
|
|
572 Refa : VStringA (1 .. 100);
|
|
|
573 N : Natural;
|
|
|
574
|
|
|
575 begin
|
|
|
576 N := 0;
|
|
|
577
|
|
|
578 loop
|
|
|
579 exit when not Match (Ref, Get_Nxtref, Nul);
|
|
|
580 N := N + 1;
|
|
|
581 Refa (N) := Nxtref;
|
|
|
582 end loop;
|
|
|
583
|
|
|
584 Sort (Refa (1 .. N));
|
|
|
585
|
|
|
586 Next_Line;
|
|
|
587 Next_Line;
|
|
|
588 Next_Line;
|
|
|
589
|
|
|
590 -- Checking references for one entry
|
|
|
591
|
|
|
592 for M in 1 .. N loop
|
|
|
593 Next_Line;
|
|
|
594
|
|
|
595 if not Match (Line, Test_Syn)
|
|
|
596 or else Next /= Refa (M)
|
|
|
597 then
|
|
|
598 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
|
|
|
599 raise Err;
|
|
|
600 end if;
|
|
|
601 end loop;
|
|
|
602
|
|
|
603 loop
|
|
|
604 Next_Line;
|
|
|
605 exit when Match (Line, Set_Fld);
|
|
|
606 end loop;
|
|
|
607
|
|
|
608 Match (Field, Break_With);
|
|
|
609
|
|
|
610 if Field /= Get (Fields, Synonym) then
|
|
|
611 Put_Line
|
|
|
612 ("Wrong field for procedure Set_" & Synonym &
|
|
|
613 " at line " & Lineno & " should be " &
|
|
|
614 Get (Fields, Synonym));
|
|
|
615 raise Done;
|
|
|
616 end if;
|
|
|
617
|
|
|
618 Delete (Fields1, Synonym);
|
|
|
619 end;
|
|
|
620 end if;
|
|
|
621 end loop;
|
|
|
622
|
|
|
623 Put_Line (" OK");
|
|
|
624 New_Line;
|
|
|
625 Put_Line ("Check for missing set procedures in body");
|
|
|
626
|
|
|
627 declare
|
|
|
628 List : constant TV.Table_Array := Convert_To_Array (Fields1);
|
|
|
629 begin
|
|
|
630 if List'Length /= 0 then
|
|
|
631 Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
|
|
|
632 raise Done;
|
|
|
633 end if;
|
|
|
634 end;
|
|
|
635
|
|
|
636 Put_Line (" OK");
|
|
|
637 New_Line;
|
|
|
638 Put_Line ("All tests completed successfully, no errors detected");
|
|
|
639
|
|
|
640 end CSinfo;
|
