|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- E R R O U T --
|
|
|
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 -- Warning: Error messages can be generated during Gigi processing by direct
|
|
|
27 -- calls to error message routines, so it is essential that the processing
|
|
|
28 -- in this body be consistent with the requirements for the Gigi processing
|
|
|
29 -- environment, and that in particular, no disallowed table expansion is
|
|
|
30 -- allowed to occur.
|
|
|
31
|
|
|
32 with Atree; use Atree;
|
|
|
33 with Casing; use Casing;
|
|
|
34 with Csets; use Csets;
|
|
|
35 with Debug; use Debug;
|
|
|
36 with Einfo; use Einfo;
|
|
|
37 with Erroutc; use Erroutc;
|
|
|
38 with Gnatvsn; use Gnatvsn;
|
|
|
39 with Lib; use Lib;
|
|
|
40 with Opt; use Opt;
|
|
|
41 with Nlists; use Nlists;
|
|
|
42 with Output; use Output;
|
|
|
43 with Scans; use Scans;
|
|
|
44 with Sem_Aux; use Sem_Aux;
|
|
|
45 with Sinput; use Sinput;
|
|
|
46 with Sinfo; use Sinfo;
|
|
|
47 with Snames; use Snames;
|
|
|
48 with Stand; use Stand;
|
|
|
49 with Stylesw; use Stylesw;
|
|
|
50 with Uname; use Uname;
|
|
|
51
|
|
|
52 package body Errout is
|
|
|
53
|
|
|
54 Errors_Must_Be_Ignored : Boolean := False;
|
|
|
55 -- Set to True by procedure Set_Ignore_Errors (True), when calls to error
|
|
|
56 -- message procedures should be ignored (when parsing irrelevant text in
|
|
|
57 -- sources being preprocessed).
|
|
|
58
|
|
|
59 Finalize_Called : Boolean := False;
|
|
|
60 -- Set True if the Finalize routine has been called
|
|
|
61
|
|
|
62 Record_Compilation_Errors : Boolean := False;
|
|
|
63 -- Record that a compilation error was witnessed during a given phase of
|
|
|
64 -- analysis for gnat2why. This is needed as Warning_Mode is modified twice
|
|
|
65 -- in gnat2why, hence Erroutc.Compilation_Errors can only return a suitable
|
|
|
66 -- value for each phase of analysis separately. This is updated at each
|
|
|
67 -- call to Compilation_Errors.
|
|
|
68
|
|
|
69 Warn_On_Instance : Boolean;
|
|
|
70 -- Flag set true for warning message to be posted on instance
|
|
|
71
|
|
|
72 ------------------------------------
|
|
|
73 -- Table of Non-Instance Messages --
|
|
|
74 ------------------------------------
|
|
|
75
|
|
|
76 -- This table contains an entry for every error message processed by the
|
|
|
77 -- Error_Msg routine that is not posted on generic (or inlined) instance.
|
|
|
78 -- As explained in further detail in the Error_Msg procedure body, this
|
|
|
79 -- table is used to avoid posting redundant messages on instances.
|
|
|
80
|
|
|
81 type NIM_Record is record
|
|
|
82 Msg : String_Ptr;
|
|
|
83 Loc : Source_Ptr;
|
|
|
84 end record;
|
|
|
85 -- Type used to store text and location of one message
|
|
|
86
|
|
|
87 package Non_Instance_Msgs is new Table.Table (
|
|
|
88 Table_Component_Type => NIM_Record,
|
|
|
89 Table_Index_Type => Int,
|
|
|
90 Table_Low_Bound => 1,
|
|
|
91 Table_Initial => 100,
|
|
|
92 Table_Increment => 100,
|
|
|
93 Table_Name => "Non_Instance_Msgs");
|
|
|
94
|
|
|
95 -----------------------
|
|
|
96 -- Local Subprograms --
|
|
|
97 -----------------------
|
|
|
98
|
|
|
99 procedure Error_Msg_Internal
|
|
|
100 (Msg : String;
|
|
|
101 Sptr : Source_Ptr;
|
|
|
102 Optr : Source_Ptr;
|
|
|
103 Msg_Cont : Boolean;
|
|
|
104 Node : Node_Id);
|
|
|
105 -- This is the low level routine used to post messages after dealing with
|
|
|
106 -- the issue of messages placed on instantiations (which get broken up
|
|
|
107 -- into separate calls in Error_Msg). Sptr is the location on which the
|
|
|
108 -- flag will be placed in the output. In the case where the flag is on
|
|
|
109 -- the template, this points directly to the template, not to one of the
|
|
|
110 -- instantiation copies of the template. Optr is the original location
|
|
|
111 -- used to flag the error, and this may indeed point to an instantiation
|
|
|
112 -- copy. So typically we can see Optr pointing to the template location
|
|
|
113 -- in an instantiation copy when Sptr points to the source location of
|
|
|
114 -- the actual instantiation (i.e the line with the new). Msg_Cont is
|
|
|
115 -- set true if this is a continuation message. Node is the relevant
|
|
|
116 -- Node_Id for this message, to be used to compute the enclosing entity if
|
|
|
117 -- Opt.Include_Subprogram_In_Messages is set.
|
|
|
118
|
|
|
119 function No_Warnings (N : Node_Or_Entity_Id) return Boolean;
|
|
|
120 -- Determines if warnings should be suppressed for the given node
|
|
|
121
|
|
|
122 function OK_Node (N : Node_Id) return Boolean;
|
|
|
123 -- Determines if a node is an OK node to place an error message on (return
|
|
|
124 -- True) or if the error message should be suppressed (return False). A
|
|
|
125 -- message is suppressed if the node already has an error posted on it,
|
|
|
126 -- or if it refers to an Etype that has an error posted on it, or if
|
|
|
127 -- it references an Entity that has an error posted on it.
|
|
|
128
|
|
|
129 procedure Output_Source_Line
|
|
|
130 (L : Physical_Line_Number;
|
|
|
131 Sfile : Source_File_Index;
|
|
|
132 Errs : Boolean);
|
|
|
133 -- Outputs text of source line L, in file S, together with preceding line
|
|
|
134 -- number, as described above for Output_Line_Number. The Errs parameter
|
|
|
135 -- indicates if there are errors attached to the line, which forces
|
|
|
136 -- listing on, even in the presence of pragma List (Off).
|
|
|
137
|
|
|
138 procedure Set_Msg_Insertion_Column;
|
|
|
139 -- Handle column number insertion (@ insertion character)
|
|
|
140
|
|
|
141 procedure Set_Msg_Insertion_Node;
|
|
|
142 -- Handle node (name from node) insertion (& insertion character)
|
|
|
143
|
|
|
144 procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr);
|
|
|
145 -- Handle type reference (right brace insertion character). Flag is the
|
|
|
146 -- location of the flag, which is provided for the internal call to
|
|
|
147 -- Set_Msg_Insertion_Line_Number,
|
|
|
148
|
|
|
149 procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True);
|
|
|
150 -- Handle unit name insertion ($ insertion character). Depending on Boolean
|
|
|
151 -- parameter Suffix, (spec) or (body) is appended after the unit name.
|
|
|
152
|
|
|
153 procedure Set_Msg_Node (Node : Node_Id);
|
|
|
154 -- Add the sequence of characters for the name associated with the given
|
|
|
155 -- node to the current message. For N_Designator, N_Selected_Component,
|
|
|
156 -- N_Defining_Program_Unit_Name, and N_Expanded_Name, the Prefix is
|
|
|
157 -- included as well.
|
|
|
158
|
|
|
159 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);
|
|
|
160 -- Add a sequence of characters to the current message. The characters may
|
|
|
161 -- be one of the special insertion characters (see documentation in spec).
|
|
|
162 -- Flag is the location at which the error is to be posted, which is used
|
|
|
163 -- to determine whether or not the # insertion needs a file name. The
|
|
|
164 -- variables Msg_Buffer are set on return Msglen.
|
|
|
165
|
|
|
166 procedure Set_Posted (N : Node_Id);
|
|
|
167 -- Sets the Error_Posted flag on the given node, and all its parents that
|
|
|
168 -- are subexpressions and then on the parent non-subexpression construct
|
|
|
169 -- that contains the original expression. If that parent is a named
|
|
|
170 -- association, the flag is further propagated to its parent. This is done
|
|
|
171 -- in order to guard against cascaded errors. Note that this call has an
|
|
|
172 -- effect for a serious error only.
|
|
|
173
|
|
|
174 procedure Set_Qualification (N : Nat; E : Entity_Id);
|
|
|
175 -- Outputs up to N levels of qualification for the given entity. For
|
|
|
176 -- example, the entity A.B.C.D will output B.C. if N = 2.
|
|
|
177
|
|
|
178 function Special_Msg_Delete
|
|
|
179 (Msg : String;
|
|
|
180 N : Node_Or_Entity_Id;
|
|
|
181 E : Node_Or_Entity_Id) return Boolean;
|
|
|
182 -- This function is called from Error_Msg_NEL, passing the message Msg,
|
|
|
183 -- node N on which the error is to be posted, and the entity or node E
|
|
|
184 -- to be used for an & insertion in the message if any. The job of this
|
|
|
185 -- procedure is to test for certain cascaded messages that we would like
|
|
|
186 -- to suppress. If the message is to be suppressed then we return True.
|
|
|
187 -- If the message should be generated (the normal case) False is returned.
|
|
|
188
|
|
|
189 procedure Unwind_Internal_Type (Ent : in out Entity_Id);
|
|
|
190 -- This procedure is given an entity id for an internal type, i.e. a type
|
|
|
191 -- with an internal name. It unwinds the type to try to get to something
|
|
|
192 -- reasonably printable, generating prefixes like "subtype of", "access
|
|
|
193 -- to", etc along the way in the buffer. The value in Ent on return is the
|
|
|
194 -- final name to be printed. Hopefully this is not an internal name, but in
|
|
|
195 -- some internal name cases, it is an internal name, and has to be printed
|
|
|
196 -- anyway (although in this case the message has been killed if possible).
|
|
|
197 -- The global variable Class_Flag is set to True if the resulting entity
|
|
|
198 -- should have 'Class appended to its name (see Add_Class procedure), and
|
|
|
199 -- is otherwise unchanged.
|
|
|
200
|
|
|
201 function Warn_Insertion return String;
|
|
|
202 -- This is called for warning messages only (so Warning_Msg_Char is set)
|
|
|
203 -- and returns a corresponding string to use at the beginning of generated
|
|
|
204 -- auxiliary messages, such as "in instantiation at ...".
|
|
|
205 -- 'a' .. 'z' returns "?x?"
|
|
|
206 -- 'A' .. 'Z' returns "?X?"
|
|
|
207 -- '*' returns "?*?"
|
|
|
208 -- '$' returns "?$?info: "
|
|
|
209 -- ' ' returns " "
|
|
|
210 -- No other settings are valid
|
|
|
211
|
|
|
212 -----------------------
|
|
|
213 -- Change_Error_Text --
|
|
|
214 -----------------------
|
|
|
215
|
|
|
216 procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String) is
|
|
|
217 Save_Next : Error_Msg_Id;
|
|
|
218 Err_Id : Error_Msg_Id := Error_Id;
|
|
|
219
|
|
|
220 begin
|
|
|
221 Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr);
|
|
|
222 Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen));
|
|
|
223
|
|
|
224 -- If in immediate error message mode, output modified error message now
|
|
|
225 -- This is just a bit tricky, because we want to output just a single
|
|
|
226 -- message, and the messages we modified is already linked in. We solve
|
|
|
227 -- this by temporarily resetting its forward pointer to empty.
|
|
|
228
|
|
|
229 if Debug_Flag_OO then
|
|
|
230 Save_Next := Errors.Table (Error_Id).Next;
|
|
|
231 Errors.Table (Error_Id).Next := No_Error_Msg;
|
|
|
232 Write_Eol;
|
|
|
233 Output_Source_Line
|
|
|
234 (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True);
|
|
|
235 Output_Error_Msgs (Err_Id);
|
|
|
236 Errors.Table (Error_Id).Next := Save_Next;
|
|
|
237 end if;
|
|
|
238 end Change_Error_Text;
|
|
|
239
|
|
|
240 ------------------------
|
|
|
241 -- Compilation_Errors --
|
|
|
242 ------------------------
|
|
|
243
|
|
|
244 function Compilation_Errors return Boolean is
|
|
|
245 begin
|
|
|
246 if not Finalize_Called then
|
|
|
247 raise Program_Error;
|
|
|
248
|
|
|
249 -- Record that a compilation error was witnessed during a given phase of
|
|
|
250 -- analysis for gnat2why. This is needed as Warning_Mode is modified
|
|
|
251 -- twice in gnat2why, hence Erroutc.Compilation_Errors can only return a
|
|
|
252 -- suitable value for each phase of analysis separately.
|
|
|
253
|
|
|
254 else
|
|
|
255 Record_Compilation_Errors :=
|
|
|
256 Record_Compilation_Errors or else Erroutc.Compilation_Errors;
|
|
|
257
|
|
|
258 return Record_Compilation_Errors;
|
|
|
259 end if;
|
|
|
260 end Compilation_Errors;
|
|
|
261
|
|
|
262 --------------------------------------
|
|
|
263 -- Delete_Warning_And_Continuations --
|
|
|
264 --------------------------------------
|
|
|
265
|
|
|
266 procedure Delete_Warning_And_Continuations (Msg : Error_Msg_Id) is
|
|
|
267 Id : Error_Msg_Id;
|
|
|
268
|
|
|
269 begin
|
|
|
270 pragma Assert (not Errors.Table (Msg).Msg_Cont);
|
|
|
271
|
|
|
272 Id := Msg;
|
|
|
273 loop
|
|
|
274 declare
|
|
|
275 M : Error_Msg_Object renames Errors.Table (Id);
|
|
|
276
|
|
|
277 begin
|
|
|
278 if not M.Deleted then
|
|
|
279 M.Deleted := True;
|
|
|
280 Warnings_Detected := Warnings_Detected - 1;
|
|
|
281
|
|
|
282 if M.Info then
|
|
|
283 Warning_Info_Messages := Warning_Info_Messages - 1;
|
|
|
284 end if;
|
|
|
285
|
|
|
286 if M.Warn_Err then
|
|
|
287 Warnings_Treated_As_Errors := Warnings_Treated_As_Errors - 1;
|
|
|
288 end if;
|
|
|
289 end if;
|
|
|
290
|
|
|
291 Id := M.Next;
|
|
|
292 exit when Id = No_Error_Msg;
|
|
|
293 exit when not Errors.Table (Id).Msg_Cont;
|
|
|
294 end;
|
|
|
295 end loop;
|
|
|
296 end Delete_Warning_And_Continuations;
|
|
|
297
|
|
|
298 ---------------
|
|
|
299 -- Error_Msg --
|
|
|
300 ---------------
|
|
|
301
|
|
|
302 -- Error_Msg posts a flag at the given location, except that if the
|
|
|
303 -- Flag_Location points within a generic template and corresponds to an
|
|
|
304 -- instantiation of this generic template, then the actual message will be
|
|
|
305 -- posted on the generic instantiation, along with additional messages
|
|
|
306 -- referencing the generic declaration.
|
|
|
307
|
|
|
308 procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
|
|
|
309 begin
|
|
131
|
310 Error_Msg (Msg, Flag_Location, Current_Node);
|
|
111
|
311 end Error_Msg;
|
|
|
312
|
|
|
313 procedure Error_Msg
|
|
|
314 (Msg : String;
|
|
|
315 Flag_Location : Source_Ptr;
|
|
|
316 N : Node_Id)
|
|
|
317 is
|
|
|
318 Sindex : Source_File_Index;
|
|
|
319 -- Source index for flag location
|
|
|
320
|
|
|
321 Orig_Loc : Source_Ptr;
|
|
|
322 -- Original location of Flag_Location (i.e. location in original
|
|
|
323 -- template in instantiation case, otherwise unchanged).
|
|
|
324
|
|
|
325 begin
|
|
|
326 -- Return if all errors are to be ignored
|
|
|
327
|
|
|
328 if Errors_Must_Be_Ignored then
|
|
|
329 return;
|
|
|
330 end if;
|
|
|
331
|
|
|
332 -- If we already have messages, and we are trying to place a message at
|
|
|
333 -- No_Location, then just ignore the attempt since we assume that what
|
|
|
334 -- is happening is some cascaded junk. Note that this is safe in the
|
|
|
335 -- sense that proceeding will surely bomb. We will also bomb if the flag
|
|
|
336 -- location is No_Location and we don't have any messages so far, but
|
|
|
337 -- that is a real bug and a legitimate bomb, so we go ahead.
|
|
|
338
|
|
|
339 if Flag_Location = No_Location
|
|
|
340 and then Total_Errors_Detected > 0
|
|
|
341 then
|
|
|
342 return;
|
|
|
343 end if;
|
|
|
344
|
|
|
345 -- Start of processing for new message
|
|
|
346
|
|
|
347 Sindex := Get_Source_File_Index (Flag_Location);
|
|
|
348 Prescan_Message (Msg);
|
|
|
349 Orig_Loc := Original_Location (Flag_Location);
|
|
|
350
|
|
|
351 -- If the current location is in an instantiation, the issue arises of
|
|
|
352 -- whether to post the message on the template or the instantiation.
|
|
|
353
|
|
|
354 -- The way we decide is to see if we have posted the same message on
|
|
|
355 -- the template when we compiled the template (the template is always
|
|
|
356 -- compiled before any instantiations). For this purpose, we use a
|
|
|
357 -- separate table of messages. The reason we do this is twofold:
|
|
|
358
|
|
|
359 -- First, the messages can get changed by various processing
|
|
|
360 -- including the insertion of tokens etc, making it hard to
|
|
|
361 -- do the comparison.
|
|
|
362
|
|
|
363 -- Second, we will suppress a warning on a template if it is not in
|
|
|
364 -- the current extended source unit. That's reasonable and means we
|
|
|
365 -- don't want the warning on the instantiation here either, but it
|
|
|
366 -- does mean that the main error table would not in any case include
|
|
|
367 -- the message.
|
|
|
368
|
|
|
369 if Flag_Location = Orig_Loc then
|
|
|
370 Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location));
|
|
|
371 Warn_On_Instance := False;
|
|
|
372
|
|
|
373 -- Here we have an instance message
|
|
|
374
|
|
|
375 else
|
|
|
376 -- Delete if debug flag off, and this message duplicates a message
|
|
|
377 -- already posted on the corresponding template
|
|
|
378
|
|
|
379 if not Debug_Flag_GG then
|
|
|
380 for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop
|
|
|
381 if Msg = Non_Instance_Msgs.Table (J).Msg.all
|
|
|
382 and then Non_Instance_Msgs.Table (J).Loc = Orig_Loc
|
|
|
383 then
|
|
|
384 return;
|
|
|
385 end if;
|
|
|
386 end loop;
|
|
|
387 end if;
|
|
|
388
|
|
|
389 -- No duplicate, so error/warning will be posted on instance
|
|
|
390
|
|
|
391 Warn_On_Instance := Is_Warning_Msg;
|
|
|
392 end if;
|
|
|
393
|
|
|
394 -- Ignore warning message that is suppressed for this location. Note
|
|
|
395 -- that style checks are not considered warning messages for this
|
|
|
396 -- purpose.
|
|
|
397
|
|
|
398 if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) /= No_String
|
|
|
399 then
|
|
|
400 return;
|
|
|
401
|
|
|
402 -- For style messages, check too many messages so far
|
|
|
403
|
|
|
404 elsif Is_Style_Msg
|
|
|
405 and then Maximum_Messages /= 0
|
|
|
406 and then Warnings_Detected >= Maximum_Messages
|
|
|
407 then
|
|
|
408 return;
|
|
|
409 end if;
|
|
|
410
|
|
|
411 -- The idea at this stage is that we have two kinds of messages
|
|
|
412
|
|
|
413 -- First, we have those messages that are to be placed as requested at
|
|
|
414 -- Flag_Location. This includes messages that have nothing to do with
|
|
|
415 -- generics, and also messages placed on generic templates that reflect
|
|
|
416 -- an error in the template itself. For such messages we simply call
|
|
|
417 -- Error_Msg_Internal to place the message in the requested location.
|
|
|
418
|
|
|
419 if Instantiation (Sindex) = No_Location then
|
|
|
420 Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False, N);
|
|
|
421 return;
|
|
|
422 end if;
|
|
|
423
|
|
|
424 -- If we are trying to flag an error in an instantiation, we may have
|
|
|
425 -- a generic contract violation. What we generate in this case is:
|
|
|
426
|
|
|
427 -- instantiation error at ...
|
|
|
428 -- original error message
|
|
|
429
|
|
|
430 -- or
|
|
|
431
|
|
|
432 -- warning: in instantiation at ...
|
|
|
433 -- warning: original warning message
|
|
|
434
|
|
|
435 -- or
|
|
|
436
|
|
|
437 -- info: in instantiation at ...
|
|
|
438 -- info: original info message
|
|
|
439
|
|
|
440 -- All these messages are posted at the location of the top level
|
|
|
441 -- instantiation. If there are nested instantiations, then the
|
|
|
442 -- instantiation error message can be repeated, pointing to each
|
|
|
443 -- of the relevant instantiations.
|
|
|
444
|
|
|
445 -- Note: the instantiation mechanism is also shared for inlining of
|
|
|
446 -- subprogram bodies when front end inlining is done. In this case the
|
|
|
447 -- messages have the form:
|
|
|
448
|
|
|
449 -- in inlined body at ...
|
|
|
450 -- original error message
|
|
|
451
|
|
|
452 -- or
|
|
|
453
|
|
|
454 -- warning: in inlined body at ...
|
|
|
455 -- warning: original warning message
|
|
|
456
|
|
|
457 -- or
|
|
|
458
|
|
|
459 -- info: in inlined body at ...
|
|
|
460 -- info: original info message
|
|
|
461
|
|
|
462 -- OK, here we have an instantiation error, and we need to generate the
|
|
|
463 -- error on the instantiation, rather than on the template.
|
|
|
464
|
|
|
465 declare
|
|
|
466 Actual_Error_Loc : Source_Ptr;
|
|
|
467 -- Location of outer level instantiation in instantiation case, or
|
|
|
468 -- just a copy of Flag_Location in the normal case. This is the
|
|
|
469 -- location where all error messages will actually be posted.
|
|
|
470
|
|
|
471 Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc;
|
|
|
472 -- Save possible location set for caller's message. We need to use
|
|
|
473 -- Error_Msg_Sloc for the location of the instantiation error but we
|
|
|
474 -- have to preserve a possible original value.
|
|
|
475
|
|
|
476 X : Source_File_Index;
|
|
|
477
|
|
|
478 Msg_Cont_Status : Boolean;
|
|
|
479 -- Used to label continuation lines in instantiation case with
|
|
|
480 -- proper Msg_Cont status.
|
|
|
481
|
|
|
482 begin
|
|
|
483 -- Loop to find highest level instantiation, where all error
|
|
|
484 -- messages will be placed.
|
|
|
485
|
|
|
486 X := Sindex;
|
|
|
487 loop
|
|
|
488 Actual_Error_Loc := Instantiation (X);
|
|
|
489 X := Get_Source_File_Index (Actual_Error_Loc);
|
|
|
490 exit when Instantiation (X) = No_Location;
|
|
|
491 end loop;
|
|
|
492
|
|
|
493 -- Since we are generating the messages at the instantiation point in
|
|
|
494 -- any case, we do not want the references to the bad lines in the
|
|
|
495 -- instance to be annotated with the location of the instantiation.
|
|
|
496
|
|
|
497 Suppress_Instance_Location := True;
|
|
|
498 Msg_Cont_Status := False;
|
|
|
499
|
|
|
500 -- Loop to generate instantiation messages
|
|
|
501
|
|
|
502 Error_Msg_Sloc := Flag_Location;
|
|
|
503 X := Get_Source_File_Index (Flag_Location);
|
|
|
504 while Instantiation (X) /= No_Location loop
|
|
|
505
|
|
|
506 -- Suppress instantiation message on continuation lines
|
|
|
507
|
|
|
508 if Msg (Msg'First) /= '\' then
|
|
|
509
|
|
|
510 -- Case of inlined body
|
|
|
511
|
|
|
512 if Inlined_Body (X) then
|
|
|
513 if Is_Info_Msg then
|
|
|
514 Error_Msg_Internal
|
|
|
515 (Msg => "info: in inlined body #",
|
|
|
516 Sptr => Actual_Error_Loc,
|
|
|
517 Optr => Flag_Location,
|
|
|
518 Msg_Cont => Msg_Cont_Status,
|
|
|
519 Node => N);
|
|
|
520
|
|
|
521 elsif Is_Warning_Msg then
|
|
|
522 Error_Msg_Internal
|
|
|
523 (Msg => Warn_Insertion & "in inlined body #",
|
|
|
524 Sptr => Actual_Error_Loc,
|
|
|
525 Optr => Flag_Location,
|
|
|
526 Msg_Cont => Msg_Cont_Status,
|
|
|
527 Node => N);
|
|
|
528
|
|
|
529 elsif Is_Style_Msg then
|
|
|
530 Error_Msg_Internal
|
|
|
531 (Msg => "style: in inlined body #",
|
|
|
532 Sptr => Actual_Error_Loc,
|
|
|
533 Optr => Flag_Location,
|
|
|
534 Msg_Cont => Msg_Cont_Status,
|
|
|
535 Node => N);
|
|
|
536
|
|
|
537 else
|
|
|
538 Error_Msg_Internal
|
|
|
539 (Msg => "error in inlined body #",
|
|
|
540 Sptr => Actual_Error_Loc,
|
|
|
541 Optr => Flag_Location,
|
|
|
542 Msg_Cont => Msg_Cont_Status,
|
|
|
543 Node => N);
|
|
|
544 end if;
|
|
|
545
|
|
|
546 -- Case of generic instantiation
|
|
|
547
|
|
|
548 else
|
|
|
549 if Is_Info_Msg then
|
|
|
550 Error_Msg_Internal
|
|
|
551 (Msg => "info: in instantiation #",
|
|
|
552 Sptr => Actual_Error_Loc,
|
|
|
553 Optr => Flag_Location,
|
|
|
554 Msg_Cont => Msg_Cont_Status,
|
|
|
555 Node => N);
|
|
|
556
|
|
|
557 elsif Is_Warning_Msg then
|
|
|
558 Error_Msg_Internal
|
|
|
559 (Msg => Warn_Insertion & "in instantiation #",
|
|
|
560 Sptr => Actual_Error_Loc,
|
|
|
561 Optr => Flag_Location,
|
|
|
562 Msg_Cont => Msg_Cont_Status,
|
|
|
563 Node => N);
|
|
|
564
|
|
|
565 elsif Is_Style_Msg then
|
|
|
566 Error_Msg_Internal
|
|
|
567 (Msg => "style: in instantiation #",
|
|
|
568 Sptr => Actual_Error_Loc,
|
|
|
569 Optr => Flag_Location,
|
|
|
570 Msg_Cont => Msg_Cont_Status,
|
|
|
571 Node => N);
|
|
|
572
|
|
|
573 else
|
|
|
574 Error_Msg_Internal
|
|
|
575 (Msg => "instantiation error #",
|
|
|
576 Sptr => Actual_Error_Loc,
|
|
|
577 Optr => Flag_Location,
|
|
|
578 Msg_Cont => Msg_Cont_Status,
|
|
|
579 Node => N);
|
|
|
580 end if;
|
|
|
581 end if;
|
|
|
582 end if;
|
|
|
583
|
|
|
584 Error_Msg_Sloc := Instantiation (X);
|
|
|
585 X := Get_Source_File_Index (Error_Msg_Sloc);
|
|
|
586 Msg_Cont_Status := True;
|
|
|
587 end loop;
|
|
|
588
|
|
|
589 Suppress_Instance_Location := False;
|
|
|
590 Error_Msg_Sloc := Save_Error_Msg_Sloc;
|
|
|
591
|
|
|
592 -- Here we output the original message on the outer instantiation
|
|
|
593
|
|
|
594 Error_Msg_Internal
|
|
|
595 (Msg => Msg,
|
|
|
596 Sptr => Actual_Error_Loc,
|
|
|
597 Optr => Flag_Location,
|
|
|
598 Msg_Cont => Msg_Cont_Status,
|
|
|
599 Node => N);
|
|
|
600 end;
|
|
|
601 end Error_Msg;
|
|
|
602
|
|
|
603 --------------------------------
|
|
|
604 -- Error_Msg_Ada_2012_Feature --
|
|
|
605 --------------------------------
|
|
|
606
|
|
|
607 procedure Error_Msg_Ada_2012_Feature (Feature : String; Loc : Source_Ptr) is
|
|
|
608 begin
|
|
|
609 if Ada_Version < Ada_2012 then
|
|
|
610 Error_Msg (Feature & " is an Ada 2012 feature", Loc);
|
|
|
611
|
|
|
612 if No (Ada_Version_Pragma) then
|
|
|
613 Error_Msg ("\unit must be compiled with -gnat2012 switch", Loc);
|
|
|
614 else
|
|
|
615 Error_Msg_Sloc := Sloc (Ada_Version_Pragma);
|
|
|
616 Error_Msg ("\incompatible with Ada version set#", Loc);
|
|
|
617 end if;
|
|
|
618 end if;
|
|
|
619 end Error_Msg_Ada_2012_Feature;
|
|
|
620
|
|
|
621 ------------------
|
|
|
622 -- Error_Msg_AP --
|
|
|
623 ------------------
|
|
|
624
|
|
|
625 procedure Error_Msg_AP (Msg : String) is
|
|
|
626 S1 : Source_Ptr;
|
|
|
627 C : Character;
|
|
|
628
|
|
|
629 begin
|
|
|
630 -- If we had saved the Scan_Ptr value after scanning the previous
|
|
|
631 -- token, then we would have exactly the right place for putting
|
|
|
632 -- the flag immediately at hand. However, that would add at least
|
|
|
633 -- two instructions to a Scan call *just* to service the possibility
|
|
|
634 -- of an Error_Msg_AP call. So instead we reconstruct that value.
|
|
|
635
|
|
|
636 -- We have two possibilities, start with Prev_Token_Ptr and skip over
|
|
|
637 -- the current token, which is made harder by the possibility that this
|
|
|
638 -- token may be in error, or start with Token_Ptr and work backwards.
|
|
|
639 -- We used to take the second approach, but it's hard because of
|
|
|
640 -- comments, and harder still because things that look like comments
|
|
|
641 -- can appear inside strings. So now we take the first approach.
|
|
|
642
|
|
|
643 -- Note: in the case where there is no previous token, Prev_Token_Ptr
|
|
|
644 -- is set to Source_First, which is a reasonable position for the
|
|
|
645 -- error flag in this situation.
|
|
|
646
|
|
|
647 S1 := Prev_Token_Ptr;
|
|
|
648 C := Source (S1);
|
|
|
649
|
|
|
650 -- If the previous token is a string literal, we need a special approach
|
|
|
651 -- since there may be white space inside the literal and we don't want
|
|
|
652 -- to stop on that white space.
|
|
|
653
|
|
|
654 -- Note: since this is an error recovery issue anyway, it is not worth
|
|
|
655 -- worrying about special UTF_32 line terminator characters here.
|
|
|
656
|
|
|
657 if Prev_Token = Tok_String_Literal then
|
|
|
658 loop
|
|
|
659 S1 := S1 + 1;
|
|
|
660
|
|
|
661 if Source (S1) = C then
|
|
|
662 S1 := S1 + 1;
|
|
|
663 exit when Source (S1) /= C;
|
|
|
664 elsif Source (S1) in Line_Terminator then
|
|
|
665 exit;
|
|
|
666 end if;
|
|
|
667 end loop;
|
|
|
668
|
|
|
669 -- Character literal also needs special handling
|
|
|
670
|
|
|
671 elsif Prev_Token = Tok_Char_Literal then
|
|
|
672 S1 := S1 + 3;
|
|
|
673
|
|
|
674 -- Otherwise we search forward for the end of the current token, marked
|
|
|
675 -- by a line terminator, white space, a comment symbol or if we bump
|
|
|
676 -- into the following token (i.e. the current token).
|
|
|
677
|
|
|
678 -- Again, it is not worth worrying about UTF_32 special line terminator
|
|
|
679 -- characters in this context, since this is only for error recovery.
|
|
|
680
|
|
|
681 else
|
|
|
682 while Source (S1) not in Line_Terminator
|
|
|
683 and then Source (S1) /= ' '
|
|
|
684 and then Source (S1) /= ASCII.HT
|
|
|
685 and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-')
|
|
|
686 and then S1 /= Token_Ptr
|
|
|
687 loop
|
|
|
688 S1 := S1 + 1;
|
|
|
689 end loop;
|
|
|
690 end if;
|
|
|
691
|
|
|
692 -- S1 is now set to the location for the flag
|
|
|
693
|
|
|
694 Error_Msg (Msg, S1);
|
|
|
695 end Error_Msg_AP;
|
|
|
696
|
|
|
697 ------------------
|
|
|
698 -- Error_Msg_BC --
|
|
|
699 ------------------
|
|
|
700
|
|
|
701 procedure Error_Msg_BC (Msg : String) is
|
|
|
702 begin
|
|
|
703 -- If we are at end of file, post the flag after the previous token
|
|
|
704
|
|
|
705 if Token = Tok_EOF then
|
|
|
706 Error_Msg_AP (Msg);
|
|
|
707
|
|
|
708 -- If we are at start of file, post the flag at the current token
|
|
|
709
|
|
|
710 elsif Token_Ptr = Source_First (Current_Source_File) then
|
|
|
711 Error_Msg_SC (Msg);
|
|
|
712
|
|
|
713 -- If the character before the current token is a space or a horizontal
|
|
|
714 -- tab, then we place the flag on this character (in the case of a tab
|
|
|
715 -- we would really like to place it in the "last" character of the tab
|
|
|
716 -- space, but that it too much trouble to worry about).
|
|
|
717
|
|
|
718 elsif Source (Token_Ptr - 1) = ' '
|
|
|
719 or else Source (Token_Ptr - 1) = ASCII.HT
|
|
|
720 then
|
|
|
721 Error_Msg (Msg, Token_Ptr - 1);
|
|
|
722
|
|
|
723 -- If there is no space or tab before the current token, then there is
|
|
|
724 -- no room to place the flag before the token, so we place it on the
|
|
|
725 -- token instead (this happens for example at the start of a line).
|
|
|
726
|
|
|
727 else
|
|
|
728 Error_Msg (Msg, Token_Ptr);
|
|
|
729 end if;
|
|
|
730 end Error_Msg_BC;
|
|
|
731
|
|
|
732 -------------------
|
|
|
733 -- Error_Msg_CRT --
|
|
|
734 -------------------
|
|
|
735
|
|
|
736 procedure Error_Msg_CRT (Feature : String; N : Node_Id) is
|
|
|
737 CNRT : constant String := " not allowed in no run time mode";
|
|
|
738 CCRT : constant String := " not supported by configuration>";
|
|
|
739
|
|
|
740 S : String (1 .. Feature'Length + 1 + CCRT'Length);
|
|
|
741 L : Natural;
|
|
|
742
|
|
|
743 begin
|
|
|
744 S (1) := '|';
|
|
|
745 S (2 .. Feature'Length + 1) := Feature;
|
|
|
746 L := Feature'Length + 2;
|
|
|
747
|
|
|
748 if No_Run_Time_Mode then
|
|
|
749 S (L .. L + CNRT'Length - 1) := CNRT;
|
|
|
750 L := L + CNRT'Length - 1;
|
|
|
751
|
|
|
752 else pragma Assert (Configurable_Run_Time_Mode);
|
|
|
753 S (L .. L + CCRT'Length - 1) := CCRT;
|
|
|
754 L := L + CCRT'Length - 1;
|
|
|
755 end if;
|
|
|
756
|
|
|
757 Error_Msg_N (S (1 .. L), N);
|
|
|
758 Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1;
|
|
|
759 end Error_Msg_CRT;
|
|
|
760
|
|
|
761 ------------------
|
|
|
762 -- Error_Msg_PT --
|
|
|
763 ------------------
|
|
|
764
|
|
|
765 procedure Error_Msg_PT (E : Entity_Id; Iface_Prim : Entity_Id) is
|
|
|
766 begin
|
|
|
767 Error_Msg_N
|
|
|
768 ("illegal overriding of subprogram inherited from interface", E);
|
|
|
769
|
|
|
770 Error_Msg_Sloc := Sloc (Iface_Prim);
|
|
|
771
|
|
|
772 if Ekind (E) = E_Function then
|
|
|
773 Error_Msg_N
|
|
|
774 ("\first formal of & declared # must be of mode `IN` "
|
|
|
775 & "or access-to-constant", E);
|
|
|
776 else
|
|
|
777 Error_Msg_N
|
|
|
778 ("\first formal of & declared # must be of mode `OUT`, `IN OUT` "
|
|
|
779 & "or access-to-variable", E);
|
|
|
780 end if;
|
|
|
781 end Error_Msg_PT;
|
|
|
782
|
|
|
783 -----------------
|
|
|
784 -- Error_Msg_F --
|
|
|
785 -----------------
|
|
|
786
|
|
|
787 procedure Error_Msg_F (Msg : String; N : Node_Id) is
|
|
|
788 begin
|
|
|
789 Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N)));
|
|
|
790 end Error_Msg_F;
|
|
|
791
|
|
|
792 ------------------
|
|
|
793 -- Error_Msg_FE --
|
|
|
794 ------------------
|
|
|
795
|
|
|
796 procedure Error_Msg_FE
|
|
|
797 (Msg : String;
|
|
|
798 N : Node_Id;
|
|
|
799 E : Node_Or_Entity_Id)
|
|
|
800 is
|
|
|
801 begin
|
|
|
802 Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N)));
|
|
|
803 end Error_Msg_FE;
|
|
|
804
|
|
|
805 ------------------------
|
|
|
806 -- Error_Msg_Internal --
|
|
|
807 ------------------------
|
|
|
808
|
|
|
809 procedure Error_Msg_Internal
|
|
|
810 (Msg : String;
|
|
|
811 Sptr : Source_Ptr;
|
|
|
812 Optr : Source_Ptr;
|
|
|
813 Msg_Cont : Boolean;
|
|
|
814 Node : Node_Id)
|
|
|
815 is
|
|
|
816 Next_Msg : Error_Msg_Id;
|
|
|
817 -- Pointer to next message at insertion point
|
|
|
818
|
|
|
819 Prev_Msg : Error_Msg_Id;
|
|
|
820 -- Pointer to previous message at insertion point
|
|
|
821
|
|
|
822 Temp_Msg : Error_Msg_Id;
|
|
|
823
|
|
|
824 Warn_Err : Boolean;
|
|
|
825 -- Set if warning to be treated as error
|
|
|
826
|
|
|
827 procedure Handle_Serious_Error;
|
|
|
828 -- Internal procedure to do all error message handling for a serious
|
|
|
829 -- error message, other than bumping the error counts and arranging
|
|
|
830 -- for the message to be output.
|
|
|
831
|
|
|
832 --------------------------
|
|
|
833 -- Handle_Serious_Error --
|
|
|
834 --------------------------
|
|
|
835
|
|
|
836 procedure Handle_Serious_Error is
|
|
|
837 begin
|
|
|
838 -- Turn off code generation if not done already
|
|
|
839
|
|
|
840 if Operating_Mode = Generate_Code then
|
|
|
841 Operating_Mode := Check_Semantics;
|
|
|
842 Expander_Active := False;
|
|
|
843 end if;
|
|
|
844
|
|
|
845 -- Set the fatal error flag in the unit table unless we are in
|
|
|
846 -- Try_Semantics mode (in which case we set ignored mode if not
|
|
|
847 -- currently set. This stops the semantics from being performed
|
|
|
848 -- if we find a serious error. This is skipped if we are currently
|
|
|
849 -- dealing with the configuration pragma file.
|
|
|
850
|
|
|
851 if Current_Source_Unit /= No_Unit then
|
|
|
852 declare
|
|
|
853 U : constant Unit_Number_Type := Get_Source_Unit (Sptr);
|
|
|
854 begin
|
|
|
855 if Try_Semantics then
|
|
|
856 if Fatal_Error (U) = None then
|
|
|
857 Set_Fatal_Error (U, Error_Ignored);
|
|
|
858 end if;
|
|
|
859 else
|
|
|
860 Set_Fatal_Error (U, Error_Detected);
|
|
|
861 end if;
|
|
|
862 end;
|
|
|
863 end if;
|
|
145
|
864
|
|
|
865 -- Disable warnings on unused use clauses and the like. Otherwise, an
|
|
|
866 -- error might hide a reference to an entity in a used package, so
|
|
|
867 -- after fixing the error, the use clause no longer looks like it was
|
|
|
868 -- unused.
|
|
|
869
|
|
|
870 Check_Unreferenced := False;
|
|
|
871 Check_Unreferenced_Formals := False;
|
|
111
|
872 end Handle_Serious_Error;
|
|
|
873
|
|
|
874 -- Start of processing for Error_Msg_Internal
|
|
|
875
|
|
|
876 begin
|
|
|
877 if Raise_Exception_On_Error /= 0 then
|
|
|
878 raise Error_Msg_Exception;
|
|
|
879 end if;
|
|
|
880
|
|
|
881 Continuation := Msg_Cont;
|
|
|
882 Continuation_New_Line := False;
|
|
|
883 Suppress_Message := False;
|
|
|
884 Kill_Message := False;
|
|
|
885 Set_Msg_Text (Msg, Sptr);
|
|
|
886
|
|
|
887 -- Kill continuation if parent message killed
|
|
|
888
|
|
|
889 if Continuation and Last_Killed then
|
|
|
890 return;
|
|
|
891 end if;
|
|
|
892
|
|
|
893 -- Return without doing anything if message is suppressed
|
|
|
894
|
|
|
895 if Suppress_Message
|
|
|
896 and then not All_Errors_Mode
|
|
|
897 and then not Is_Warning_Msg
|
|
|
898 and then not Is_Unconditional_Msg
|
|
|
899 then
|
|
|
900 if not Continuation then
|
|
|
901 Last_Killed := True;
|
|
|
902 end if;
|
|
|
903
|
|
|
904 return;
|
|
|
905 end if;
|
|
|
906
|
|
|
907 -- Return without doing anything if message is killed and this is not
|
|
|
908 -- the first error message. The philosophy is that if we get a weird
|
|
|
909 -- error message and we already have had a message, then we hope the
|
|
|
910 -- weird message is a junk cascaded message
|
|
|
911
|
|
|
912 if Kill_Message
|
|
|
913 and then not All_Errors_Mode
|
|
|
914 and then Total_Errors_Detected /= 0
|
|
|
915 then
|
|
|
916 if not Continuation then
|
|
|
917 Last_Killed := True;
|
|
|
918 end if;
|
|
|
919
|
|
|
920 return;
|
|
|
921 end if;
|
|
|
922
|
|
|
923 -- Special check for warning message to see if it should be output
|
|
|
924
|
|
|
925 if Is_Warning_Msg then
|
|
|
926
|
|
|
927 -- Immediate return if warning message and warnings are suppressed
|
|
|
928
|
|
|
929 if Warnings_Suppressed (Optr) /= No_String
|
|
|
930 or else
|
|
|
931 Warnings_Suppressed (Sptr) /= No_String
|
|
|
932 then
|
|
|
933 Cur_Msg := No_Error_Msg;
|
|
|
934 return;
|
|
|
935 end if;
|
|
|
936
|
|
|
937 -- If the flag location is in the main extended source unit then for
|
|
|
938 -- sure we want the warning since it definitely belongs
|
|
|
939
|
|
|
940 if In_Extended_Main_Source_Unit (Sptr) then
|
|
|
941 null;
|
|
|
942
|
|
|
943 -- If the main unit has not been read yet. the warning must be on
|
|
|
944 -- a configuration file: gnat.adc or user-defined. This means we
|
|
|
945 -- are not parsing the main unit yet, so skip following checks.
|
|
|
946
|
|
|
947 elsif No (Cunit (Main_Unit)) then
|
|
|
948 null;
|
|
|
949
|
|
|
950 -- If the flag location is not in the main extended source unit, then
|
|
|
951 -- we want to eliminate the warning, unless it is in the extended
|
|
|
952 -- main code unit and we want warnings on the instance.
|
|
|
953
|
|
|
954 elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then
|
|
|
955 null;
|
|
|
956
|
|
|
957 -- Keep warning if debug flag G set
|
|
|
958
|
|
|
959 elsif Debug_Flag_GG then
|
|
|
960 null;
|
|
|
961
|
|
|
962 -- Keep warning if message text contains !!
|
|
|
963
|
|
|
964 elsif Has_Double_Exclam then
|
|
|
965 null;
|
|
|
966
|
|
|
967 -- Here is where we delete a warning from a with'ed unit
|
|
|
968
|
|
|
969 else
|
|
|
970 Cur_Msg := No_Error_Msg;
|
|
|
971
|
|
|
972 if not Continuation then
|
|
|
973 Last_Killed := True;
|
|
|
974 end if;
|
|
|
975
|
|
|
976 return;
|
|
|
977 end if;
|
|
|
978 end if;
|
|
|
979
|
|
|
980 -- If message is to be ignored in special ignore message mode, this is
|
|
|
981 -- where we do this special processing, bypassing message output.
|
|
|
982
|
|
|
983 if Ignore_Errors_Enable > 0 then
|
|
|
984 if Is_Serious_Error then
|
|
|
985 Handle_Serious_Error;
|
|
|
986 end if;
|
|
|
987
|
|
|
988 return;
|
|
|
989 end if;
|
|
|
990
|
|
|
991 -- If error message line length set, and this is a continuation message
|
|
|
992 -- then all we do is to append the text to the text of the last message
|
|
|
993 -- with a comma space separator (eliminating a possible (style) or
|
|
|
994 -- info prefix).
|
|
|
995
|
|
|
996 if Error_Msg_Line_Length /= 0 and then Continuation then
|
|
|
997 Cur_Msg := Errors.Last;
|
|
|
998
|
|
|
999 declare
|
|
|
1000 Oldm : String_Ptr := Errors.Table (Cur_Msg).Text;
|
|
|
1001 Newm : String (1 .. Oldm'Last + 2 + Msglen);
|
|
|
1002 Newl : Natural;
|
|
|
1003 M : Natural;
|
|
|
1004
|
|
|
1005 begin
|
|
|
1006 -- First copy old message to new one and free it
|
|
|
1007
|
|
|
1008 Newm (Oldm'Range) := Oldm.all;
|
|
|
1009 Newl := Oldm'Length;
|
|
|
1010 Free (Oldm);
|
|
|
1011
|
|
|
1012 -- Remove (style) or info: at start of message
|
|
|
1013
|
|
|
1014 if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then
|
|
|
1015 M := 9;
|
|
|
1016
|
|
|
1017 elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then
|
|
|
1018 M := 7;
|
|
|
1019
|
|
|
1020 else
|
|
|
1021 M := 1;
|
|
|
1022 end if;
|
|
|
1023
|
|
|
1024 -- Now deal with separation between messages. Normally this is
|
|
|
1025 -- simply comma space, but there are some special cases.
|
|
|
1026
|
|
|
1027 -- If continuation new line, then put actual NL character in msg
|
|
|
1028
|
|
|
1029 if Continuation_New_Line then
|
|
|
1030 Newl := Newl + 1;
|
|
|
1031 Newm (Newl) := ASCII.LF;
|
|
|
1032
|
|
|
1033 -- If continuation message is enclosed in parentheses, then
|
|
|
1034 -- special treatment (don't need a comma, and we want to combine
|
|
|
1035 -- successive parenthetical remarks into a single one with
|
|
|
1036 -- separating commas).
|
|
|
1037
|
|
|
1038 elsif Msg_Buffer (M) = '(' and then Msg_Buffer (Msglen) = ')' then
|
|
|
1039
|
|
|
1040 -- Case where existing message ends in right paren, remove
|
|
|
1041 -- and separate parenthetical remarks with a comma.
|
|
|
1042
|
|
|
1043 if Newm (Newl) = ')' then
|
|
|
1044 Newm (Newl) := ',';
|
|
|
1045 Msg_Buffer (M) := ' ';
|
|
|
1046
|
|
|
1047 -- Case where we are adding new parenthetical comment
|
|
|
1048
|
|
|
1049 else
|
|
|
1050 Newl := Newl + 1;
|
|
|
1051 Newm (Newl) := ' ';
|
|
|
1052 end if;
|
|
|
1053
|
|
|
1054 -- Case where continuation not in parens and no new line
|
|
|
1055
|
|
|
1056 else
|
|
|
1057 Newm (Newl + 1 .. Newl + 2) := ", ";
|
|
|
1058 Newl := Newl + 2;
|
|
|
1059 end if;
|
|
|
1060
|
|
|
1061 -- Append new message
|
|
|
1062
|
|
|
1063 Newm (Newl + 1 .. Newl + Msglen - M + 1) :=
|
|
|
1064 Msg_Buffer (M .. Msglen);
|
|
|
1065 Newl := Newl + Msglen - M + 1;
|
|
|
1066 Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl));
|
|
|
1067
|
|
|
1068 -- Update warning msg flag and message doc char if needed
|
|
|
1069
|
|
|
1070 if Is_Warning_Msg then
|
|
|
1071 if not Errors.Table (Cur_Msg).Warn then
|
|
|
1072 Errors.Table (Cur_Msg).Warn := True;
|
|
|
1073 Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
|
|
|
1074
|
|
|
1075 elsif Warning_Msg_Char /= ' ' then
|
|
|
1076 Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
|
|
|
1077 end if;
|
|
|
1078 end if;
|
|
|
1079 end;
|
|
|
1080
|
|
|
1081 return;
|
|
|
1082 end if;
|
|
|
1083
|
|
|
1084 -- Here we build a new error object
|
|
|
1085
|
|
|
1086 Errors.Append
|
|
|
1087 ((Text => new String'(Msg_Buffer (1 .. Msglen)),
|
|
|
1088 Next => No_Error_Msg,
|
|
|
1089 Prev => No_Error_Msg,
|
|
|
1090 Sptr => Sptr,
|
|
|
1091 Optr => Optr,
|
|
|
1092 Sfile => Get_Source_File_Index (Sptr),
|
|
|
1093 Line => Get_Physical_Line_Number (Sptr),
|
|
|
1094 Col => Get_Column_Number (Sptr),
|
|
|
1095 Warn => Is_Warning_Msg,
|
|
|
1096 Info => Is_Info_Msg,
|
|
|
1097 Check => Is_Check_Msg,
|
|
|
1098 Warn_Err => False, -- reset below
|
|
|
1099 Warn_Chr => Warning_Msg_Char,
|
|
|
1100 Style => Is_Style_Msg,
|
|
|
1101 Serious => Is_Serious_Error,
|
|
|
1102 Uncond => Is_Unconditional_Msg,
|
|
|
1103 Msg_Cont => Continuation,
|
|
|
1104 Deleted => False,
|
|
|
1105 Node => Node));
|
|
|
1106 Cur_Msg := Errors.Last;
|
|
|
1107
|
|
|
1108 -- Test if warning to be treated as error
|
|
|
1109
|
|
|
1110 Warn_Err :=
|
|
145
|
1111 (Is_Warning_Msg or Is_Style_Msg)
|
|
111
|
1112 and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen))
|
|
|
1113 or else
|
|
|
1114 Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg)));
|
|
|
1115
|
|
|
1116 -- Propagate Warn_Err to this message and preceding continuations
|
|
|
1117
|
|
|
1118 for J in reverse 1 .. Errors.Last loop
|
|
|
1119 Errors.Table (J).Warn_Err := Warn_Err;
|
|
|
1120 exit when not Errors.Table (J).Msg_Cont;
|
|
|
1121 end loop;
|
|
|
1122
|
|
|
1123 -- If immediate errors mode set, output error message now. Also output
|
|
|
1124 -- now if the -d1 debug flag is set (so node number message comes out
|
|
|
1125 -- just before actual error message)
|
|
|
1126
|
|
|
1127 if Debug_Flag_OO or else Debug_Flag_1 then
|
|
|
1128 Write_Eol;
|
|
|
1129 Output_Source_Line
|
|
|
1130 (Errors.Table (Cur_Msg).Line, Errors.Table (Cur_Msg).Sfile, True);
|
|
|
1131 Temp_Msg := Cur_Msg;
|
|
|
1132 Output_Error_Msgs (Temp_Msg);
|
|
|
1133
|
|
|
1134 -- If not in immediate errors mode, then we insert the message in the
|
|
|
1135 -- error chain for later output by Finalize. The messages are sorted
|
|
|
1136 -- first by unit (main unit comes first), and within a unit by source
|
|
|
1137 -- location (earlier flag location first in the chain).
|
|
|
1138
|
|
|
1139 else
|
|
|
1140 -- First a quick check, does this belong at the very end of the chain
|
|
|
1141 -- of error messages. This saves a lot of time in the normal case if
|
|
|
1142 -- there are lots of messages.
|
|
|
1143
|
|
|
1144 if Last_Error_Msg /= No_Error_Msg
|
|
|
1145 and then Errors.Table (Cur_Msg).Sfile =
|
|
|
1146 Errors.Table (Last_Error_Msg).Sfile
|
|
|
1147 and then (Sptr > Errors.Table (Last_Error_Msg).Sptr
|
|
|
1148 or else
|
|
|
1149 (Sptr = Errors.Table (Last_Error_Msg).Sptr
|
|
|
1150 and then
|
|
|
1151 Optr > Errors.Table (Last_Error_Msg).Optr))
|
|
|
1152 then
|
|
|
1153 Prev_Msg := Last_Error_Msg;
|
|
|
1154 Next_Msg := No_Error_Msg;
|
|
|
1155
|
|
|
1156 -- Otherwise do a full sequential search for the insertion point
|
|
|
1157
|
|
|
1158 else
|
|
|
1159 Prev_Msg := No_Error_Msg;
|
|
|
1160 Next_Msg := First_Error_Msg;
|
|
|
1161 while Next_Msg /= No_Error_Msg loop
|
|
|
1162 exit when
|
|
|
1163 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
|
|
|
1164
|
|
|
1165 if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile
|
|
|
1166 then
|
|
|
1167 exit when Sptr < Errors.Table (Next_Msg).Sptr
|
|
|
1168 or else (Sptr = Errors.Table (Next_Msg).Sptr
|
|
|
1169 and then Optr < Errors.Table (Next_Msg).Optr);
|
|
|
1170 end if;
|
|
|
1171
|
|
|
1172 Prev_Msg := Next_Msg;
|
|
|
1173 Next_Msg := Errors.Table (Next_Msg).Next;
|
|
|
1174 end loop;
|
|
|
1175 end if;
|
|
|
1176
|
|
|
1177 -- Now we insert the new message in the error chain.
|
|
|
1178
|
|
|
1179 -- The possible insertion point for the new message is after Prev_Msg
|
|
|
1180 -- and before Next_Msg. However, this is where we do a special check
|
|
|
1181 -- for redundant parsing messages, defined as messages posted on the
|
|
|
1182 -- same line. The idea here is that probably such messages are junk
|
|
|
1183 -- from the parser recovering. In full errors mode, we don't do this
|
|
|
1184 -- deletion, but otherwise such messages are discarded at this stage.
|
|
|
1185
|
|
|
1186 if Prev_Msg /= No_Error_Msg
|
|
|
1187 and then Errors.Table (Prev_Msg).Line =
|
|
|
1188 Errors.Table (Cur_Msg).Line
|
|
|
1189 and then Errors.Table (Prev_Msg).Sfile =
|
|
|
1190 Errors.Table (Cur_Msg).Sfile
|
|
|
1191 and then Compiler_State = Parsing
|
|
|
1192 and then not All_Errors_Mode
|
|
|
1193 then
|
|
|
1194 -- Don't delete unconditional messages and at this stage, don't
|
|
|
1195 -- delete continuation lines; we attempted to delete those earlier
|
|
|
1196 -- if the parent message was deleted.
|
|
|
1197
|
|
|
1198 if not Errors.Table (Cur_Msg).Uncond
|
|
|
1199 and then not Continuation
|
|
|
1200 then
|
|
|
1201 -- Don't delete if prev msg is warning and new msg is an error.
|
|
|
1202 -- This is because we don't want a real error masked by a
|
|
|
1203 -- warning. In all other cases (that is parse errors for the
|
|
|
1204 -- same line that are not unconditional) we do delete the
|
|
|
1205 -- message. This helps to avoid junk extra messages from
|
|
|
1206 -- cascaded parsing errors
|
|
|
1207
|
|
|
1208 if not (Errors.Table (Prev_Msg).Warn
|
|
|
1209 or else
|
|
|
1210 Errors.Table (Prev_Msg).Style)
|
|
|
1211 or else
|
|
|
1212 (Errors.Table (Cur_Msg).Warn
|
|
|
1213 or else
|
|
|
1214 Errors.Table (Cur_Msg).Style)
|
|
|
1215 then
|
|
|
1216 -- All tests passed, delete the message by simply returning
|
|
|
1217 -- without any further processing.
|
|
|
1218
|
|
|
1219 pragma Assert (not Continuation);
|
|
|
1220
|
|
|
1221 Last_Killed := True;
|
|
|
1222 return;
|
|
|
1223 end if;
|
|
|
1224 end if;
|
|
|
1225 end if;
|
|
|
1226
|
|
|
1227 -- Come here if message is to be inserted in the error chain
|
|
|
1228
|
|
|
1229 if not Continuation then
|
|
|
1230 Last_Killed := False;
|
|
|
1231 end if;
|
|
|
1232
|
|
|
1233 if Prev_Msg = No_Error_Msg then
|
|
|
1234 First_Error_Msg := Cur_Msg;
|
|
|
1235 else
|
|
|
1236 Errors.Table (Prev_Msg).Next := Cur_Msg;
|
|
|
1237 end if;
|
|
|
1238
|
|
|
1239 Errors.Table (Cur_Msg).Next := Next_Msg;
|
|
|
1240
|
|
|
1241 if Next_Msg = No_Error_Msg then
|
|
|
1242 Last_Error_Msg := Cur_Msg;
|
|
|
1243 end if;
|
|
|
1244 end if;
|
|
|
1245
|
|
|
1246 -- Bump appropriate statistics counts
|
|
|
1247
|
|
|
1248 if Errors.Table (Cur_Msg).Info then
|
|
|
1249
|
|
|
1250 -- Could be (usually is) both "info" and "warning"
|
|
|
1251
|
|
|
1252 if Errors.Table (Cur_Msg).Warn then
|
|
|
1253 Warning_Info_Messages := Warning_Info_Messages + 1;
|
|
|
1254 Warnings_Detected := Warnings_Detected + 1;
|
|
|
1255 else
|
|
|
1256 Report_Info_Messages := Report_Info_Messages + 1;
|
|
|
1257 end if;
|
|
|
1258
|
|
|
1259 elsif Errors.Table (Cur_Msg).Warn
|
|
|
1260 or else Errors.Table (Cur_Msg).Style
|
|
|
1261 then
|
|
|
1262 Warnings_Detected := Warnings_Detected + 1;
|
|
|
1263
|
|
|
1264 elsif Errors.Table (Cur_Msg).Check then
|
|
|
1265 Check_Messages := Check_Messages + 1;
|
|
|
1266
|
|
|
1267 else
|
|
|
1268 Total_Errors_Detected := Total_Errors_Detected + 1;
|
|
|
1269
|
|
|
1270 if Errors.Table (Cur_Msg).Serious then
|
|
|
1271 Serious_Errors_Detected := Serious_Errors_Detected + 1;
|
|
|
1272 Handle_Serious_Error;
|
|
|
1273
|
|
|
1274 -- If not serious error, set Fatal_Error to indicate ignored error
|
|
|
1275
|
|
|
1276 else
|
|
|
1277 declare
|
|
|
1278 U : constant Unit_Number_Type := Get_Source_Unit (Sptr);
|
|
|
1279 begin
|
|
|
1280 if Fatal_Error (U) = None then
|
|
|
1281 Set_Fatal_Error (U, Error_Ignored);
|
|
|
1282 end if;
|
|
|
1283 end;
|
|
|
1284 end if;
|
|
|
1285 end if;
|
|
|
1286
|
|
|
1287 -- Record warning message issued
|
|
|
1288
|
|
|
1289 if Errors.Table (Cur_Msg).Warn
|
|
|
1290 and then not Errors.Table (Cur_Msg).Msg_Cont
|
|
|
1291 then
|
|
|
1292 Warning_Msg := Cur_Msg;
|
|
|
1293 end if;
|
|
|
1294
|
|
|
1295 -- If too many warnings turn off warnings
|
|
|
1296
|
|
|
1297 if Maximum_Messages /= 0 then
|
|
|
1298 if Warnings_Detected = Maximum_Messages then
|
|
|
1299 Warning_Mode := Suppress;
|
|
|
1300 end if;
|
|
|
1301
|
|
|
1302 -- If too many errors abandon compilation
|
|
|
1303
|
|
|
1304 if Total_Errors_Detected = Maximum_Messages then
|
|
|
1305 raise Unrecoverable_Error;
|
|
|
1306 end if;
|
|
|
1307 end if;
|
|
|
1308 end Error_Msg_Internal;
|
|
|
1309
|
|
|
1310 -----------------
|
|
|
1311 -- Error_Msg_N --
|
|
|
1312 -----------------
|
|
|
1313
|
|
|
1314 procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
|
|
|
1315 begin
|
|
|
1316 Error_Msg_NEL (Msg, N, N, Sloc (N));
|
|
|
1317 end Error_Msg_N;
|
|
|
1318
|
|
|
1319 ------------------
|
|
|
1320 -- Error_Msg_NE --
|
|
|
1321 ------------------
|
|
|
1322
|
|
|
1323 procedure Error_Msg_NE
|
|
|
1324 (Msg : String;
|
|
|
1325 N : Node_Or_Entity_Id;
|
|
|
1326 E : Node_Or_Entity_Id)
|
|
|
1327 is
|
|
|
1328 begin
|
|
|
1329 Error_Msg_NEL (Msg, N, E, Sloc (N));
|
|
|
1330 end Error_Msg_NE;
|
|
|
1331
|
|
|
1332 -------------------
|
|
|
1333 -- Error_Msg_NEL --
|
|
|
1334 -------------------
|
|
|
1335
|
|
|
1336 procedure Error_Msg_NEL
|
|
|
1337 (Msg : String;
|
|
|
1338 N : Node_Or_Entity_Id;
|
|
|
1339 E : Node_Or_Entity_Id;
|
|
|
1340 Flag_Location : Source_Ptr)
|
|
|
1341 is
|
|
|
1342 begin
|
|
|
1343 if Special_Msg_Delete (Msg, N, E) then
|
|
|
1344 return;
|
|
|
1345 end if;
|
|
|
1346
|
|
|
1347 Prescan_Message (Msg);
|
|
|
1348
|
|
|
1349 -- Special handling for warning messages
|
|
|
1350
|
|
|
1351 if Is_Warning_Msg then
|
|
|
1352
|
|
|
1353 -- Suppress if no warnings set for either entity or node
|
|
|
1354
|
|
|
1355 if No_Warnings (N) or else No_Warnings (E) then
|
|
|
1356
|
|
|
1357 -- Disable any continuation messages as well
|
|
|
1358
|
|
|
1359 Last_Killed := True;
|
|
|
1360 return;
|
|
|
1361 end if;
|
|
|
1362
|
|
|
1363 -- Suppress if inside loop that is known to be null or is probably
|
|
|
1364 -- null (case where loop executes only if invalid values present).
|
|
|
1365 -- In either case warnings in the loop are likely to be junk.
|
|
|
1366
|
|
|
1367 declare
|
|
|
1368 P : Node_Id;
|
|
|
1369
|
|
|
1370 begin
|
|
|
1371 P := Parent (N);
|
|
|
1372 while Present (P) loop
|
|
|
1373 if Nkind (P) = N_Loop_Statement
|
|
|
1374 and then Suppress_Loop_Warnings (P)
|
|
|
1375 then
|
|
|
1376 return;
|
|
|
1377 end if;
|
|
|
1378
|
|
|
1379 P := Parent (P);
|
|
|
1380 end loop;
|
|
|
1381 end;
|
|
|
1382 end if;
|
|
|
1383
|
|
|
1384 -- Test for message to be output
|
|
|
1385
|
|
|
1386 if All_Errors_Mode
|
|
|
1387 or else Is_Unconditional_Msg
|
|
|
1388 or else Is_Warning_Msg
|
|
|
1389 or else OK_Node (N)
|
|
|
1390 or else (Msg (Msg'First) = '\' and then not Last_Killed)
|
|
|
1391 then
|
|
|
1392 Debug_Output (N);
|
|
|
1393 Error_Msg_Node_1 := E;
|
|
|
1394 Error_Msg (Msg, Flag_Location, N);
|
|
|
1395
|
|
|
1396 else
|
|
|
1397 Last_Killed := True;
|
|
|
1398 end if;
|
|
|
1399
|
|
|
1400 Set_Posted (N);
|
|
|
1401 end Error_Msg_NEL;
|
|
|
1402
|
|
|
1403 ------------------
|
|
|
1404 -- Error_Msg_NW --
|
|
|
1405 ------------------
|
|
|
1406
|
|
|
1407 procedure Error_Msg_NW
|
|
|
1408 (Eflag : Boolean;
|
|
|
1409 Msg : String;
|
|
|
1410 N : Node_Or_Entity_Id)
|
|
|
1411 is
|
|
|
1412 begin
|
|
|
1413 if Eflag
|
|
|
1414 and then In_Extended_Main_Source_Unit (N)
|
|
|
1415 and then Comes_From_Source (N)
|
|
|
1416 then
|
|
|
1417 Error_Msg_NEL (Msg, N, N, Sloc (N));
|
|
|
1418 end if;
|
|
|
1419 end Error_Msg_NW;
|
|
|
1420
|
|
|
1421 -----------------
|
|
|
1422 -- Error_Msg_S --
|
|
|
1423 -----------------
|
|
|
1424
|
|
|
1425 procedure Error_Msg_S (Msg : String) is
|
|
|
1426 begin
|
|
|
1427 Error_Msg (Msg, Scan_Ptr);
|
|
|
1428 end Error_Msg_S;
|
|
|
1429
|
|
|
1430 ------------------
|
|
|
1431 -- Error_Msg_SC --
|
|
|
1432 ------------------
|
|
|
1433
|
|
|
1434 procedure Error_Msg_SC (Msg : String) is
|
|
|
1435 begin
|
|
|
1436 -- If we are at end of file, post the flag after the previous token
|
|
|
1437
|
|
|
1438 if Token = Tok_EOF then
|
|
|
1439 Error_Msg_AP (Msg);
|
|
|
1440
|
|
|
1441 -- For all other cases the message is posted at the current token
|
|
|
1442 -- pointer position
|
|
|
1443
|
|
|
1444 else
|
|
|
1445 Error_Msg (Msg, Token_Ptr);
|
|
|
1446 end if;
|
|
|
1447 end Error_Msg_SC;
|
|
|
1448
|
|
|
1449 ------------------
|
|
|
1450 -- Error_Msg_SP --
|
|
|
1451 ------------------
|
|
|
1452
|
|
|
1453 procedure Error_Msg_SP (Msg : String) is
|
|
|
1454 begin
|
|
|
1455 -- Note: in the case where there is no previous token, Prev_Token_Ptr
|
|
|
1456 -- is set to Source_First, which is a reasonable position for the
|
|
|
1457 -- error flag in this situation
|
|
|
1458
|
|
|
1459 Error_Msg (Msg, Prev_Token_Ptr);
|
|
|
1460 end Error_Msg_SP;
|
|
|
1461
|
|
|
1462 --------------
|
|
|
1463 -- Finalize --
|
|
|
1464 --------------
|
|
|
1465
|
|
|
1466 procedure Finalize (Last_Call : Boolean) is
|
|
|
1467 Cur : Error_Msg_Id;
|
|
|
1468 Nxt : Error_Msg_Id;
|
|
|
1469 F : Error_Msg_Id;
|
|
|
1470
|
|
|
1471 procedure Delete_Warning (E : Error_Msg_Id);
|
|
|
1472 -- Delete a warning msg if not already deleted and adjust warning count
|
|
|
1473
|
|
|
1474 --------------------
|
|
|
1475 -- Delete_Warning --
|
|
|
1476 --------------------
|
|
|
1477
|
|
|
1478 procedure Delete_Warning (E : Error_Msg_Id) is
|
|
|
1479 begin
|
|
|
1480 if not Errors.Table (E).Deleted then
|
|
|
1481 Errors.Table (E).Deleted := True;
|
|
|
1482 Warnings_Detected := Warnings_Detected - 1;
|
|
|
1483
|
|
|
1484 if Errors.Table (E).Info then
|
|
|
1485 Warning_Info_Messages := Warning_Info_Messages - 1;
|
|
|
1486 end if;
|
|
|
1487 end if;
|
|
|
1488 end Delete_Warning;
|
|
|
1489
|
|
|
1490 -- Start of processing for Finalize
|
|
|
1491
|
|
|
1492 begin
|
|
|
1493 -- Set Prev pointers
|
|
|
1494
|
|
|
1495 Cur := First_Error_Msg;
|
|
|
1496 while Cur /= No_Error_Msg loop
|
|
|
1497 Nxt := Errors.Table (Cur).Next;
|
|
|
1498 exit when Nxt = No_Error_Msg;
|
|
|
1499 Errors.Table (Nxt).Prev := Cur;
|
|
|
1500 Cur := Nxt;
|
|
|
1501 end loop;
|
|
|
1502
|
|
|
1503 -- Eliminate any duplicated error messages from the list. This is
|
|
|
1504 -- done after the fact to avoid problems with Change_Error_Text.
|
|
|
1505
|
|
|
1506 Cur := First_Error_Msg;
|
|
|
1507 while Cur /= No_Error_Msg loop
|
|
|
1508 Nxt := Errors.Table (Cur).Next;
|
|
|
1509
|
|
|
1510 F := Nxt;
|
|
|
1511 while F /= No_Error_Msg
|
|
|
1512 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
|
|
|
1513 loop
|
|
|
1514 Check_Duplicate_Message (Cur, F);
|
|
|
1515 F := Errors.Table (F).Next;
|
|
|
1516 end loop;
|
|
|
1517
|
|
|
1518 Cur := Nxt;
|
|
|
1519 end loop;
|
|
|
1520
|
|
|
1521 -- Mark any messages suppressed by specific warnings as Deleted
|
|
|
1522
|
|
|
1523 Cur := First_Error_Msg;
|
|
|
1524 while Cur /= No_Error_Msg loop
|
|
|
1525 declare
|
|
|
1526 CE : Error_Msg_Object renames Errors.Table (Cur);
|
|
|
1527 Tag : constant String := Get_Warning_Tag (Cur);
|
|
|
1528
|
|
|
1529 begin
|
|
|
1530 if (CE.Warn and not CE.Deleted)
|
|
|
1531 and then
|
|
|
1532 (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /=
|
|
|
1533 No_String
|
|
|
1534 or else
|
|
|
1535 Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /=
|
|
|
1536 No_String)
|
|
|
1537 then
|
|
|
1538 Delete_Warning (Cur);
|
|
|
1539
|
|
|
1540 -- If this is a continuation, delete previous parts of message
|
|
|
1541
|
|
|
1542 F := Cur;
|
|
|
1543 while Errors.Table (F).Msg_Cont loop
|
|
|
1544 F := Errors.Table (F).Prev;
|
|
|
1545 exit when F = No_Error_Msg;
|
|
|
1546 Delete_Warning (F);
|
|
|
1547 end loop;
|
|
|
1548
|
|
|
1549 -- Delete any following continuations
|
|
|
1550
|
|
|
1551 F := Cur;
|
|
|
1552 loop
|
|
|
1553 F := Errors.Table (F).Next;
|
|
|
1554 exit when F = No_Error_Msg;
|
|
|
1555 exit when not Errors.Table (F).Msg_Cont;
|
|
|
1556 Delete_Warning (F);
|
|
|
1557 end loop;
|
|
|
1558 end if;
|
|
|
1559 end;
|
|
|
1560
|
|
|
1561 Cur := Errors.Table (Cur).Next;
|
|
|
1562 end loop;
|
|
|
1563
|
|
|
1564 Finalize_Called := True;
|
|
|
1565
|
|
|
1566 -- Check consistency of specific warnings (may add warnings). We only
|
|
|
1567 -- do this on the last call, after all possible warnings are posted.
|
|
|
1568
|
|
|
1569 if Last_Call then
|
|
|
1570 Validate_Specific_Warnings (Error_Msg'Access);
|
|
|
1571 end if;
|
|
|
1572 end Finalize;
|
|
|
1573
|
|
|
1574 ----------------
|
|
|
1575 -- First_Node --
|
|
|
1576 ----------------
|
|
|
1577
|
|
|
1578 function First_Node (C : Node_Id) return Node_Id is
|
|
|
1579 Orig : constant Node_Id := Original_Node (C);
|
|
|
1580 Loc : constant Source_Ptr := Sloc (Orig);
|
|
|
1581 Sfile : constant Source_File_Index := Get_Source_File_Index (Loc);
|
|
|
1582 Earliest : Node_Id;
|
|
|
1583 Eloc : Source_Ptr;
|
|
|
1584
|
|
|
1585 function Test_Earlier (N : Node_Id) return Traverse_Result;
|
|
|
1586 -- Function applied to every node in the construct
|
|
|
1587
|
|
|
1588 procedure Search_Tree_First is new Traverse_Proc (Test_Earlier);
|
|
|
1589 -- Create traversal procedure
|
|
|
1590
|
|
|
1591 ------------------
|
|
|
1592 -- Test_Earlier --
|
|
|
1593 ------------------
|
|
|
1594
|
|
|
1595 function Test_Earlier (N : Node_Id) return Traverse_Result is
|
|
|
1596 Norig : constant Node_Id := Original_Node (N);
|
|
|
1597 Loc : constant Source_Ptr := Sloc (Norig);
|
|
|
1598
|
|
|
1599 begin
|
|
|
1600 -- Check for earlier
|
|
|
1601
|
|
|
1602 if Loc < Eloc
|
|
|
1603
|
|
|
1604 -- Ignore nodes with no useful location information
|
|
|
1605
|
|
|
1606 and then Loc /= Standard_Location
|
|
|
1607 and then Loc /= No_Location
|
|
|
1608
|
|
|
1609 -- Ignore nodes from a different file. This ensures against cases
|
|
|
1610 -- of strange foreign code somehow being present. We don't want
|
|
|
1611 -- wild placement of messages if that happens.
|
|
|
1612
|
|
|
1613 and then Get_Source_File_Index (Loc) = Sfile
|
|
|
1614 then
|
|
|
1615 Earliest := Norig;
|
|
|
1616 Eloc := Loc;
|
|
|
1617 end if;
|
|
|
1618
|
|
|
1619 return OK_Orig;
|
|
|
1620 end Test_Earlier;
|
|
|
1621
|
|
|
1622 -- Start of processing for First_Node
|
|
|
1623
|
|
|
1624 begin
|
|
|
1625 if Nkind (Orig) in N_Subexpr then
|
|
|
1626 Earliest := Orig;
|
|
|
1627 Eloc := Loc;
|
|
|
1628 Search_Tree_First (Orig);
|
|
|
1629 return Earliest;
|
|
|
1630
|
|
|
1631 else
|
|
|
1632 return Orig;
|
|
|
1633 end if;
|
|
|
1634 end First_Node;
|
|
|
1635
|
|
|
1636 ----------------
|
|
|
1637 -- First_Sloc --
|
|
|
1638 ----------------
|
|
|
1639
|
|
|
1640 function First_Sloc (N : Node_Id) return Source_Ptr is
|
|
|
1641 SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N));
|
|
|
1642 SF : constant Source_Ptr := Source_First (SI);
|
|
|
1643 F : Node_Id;
|
|
|
1644 S : Source_Ptr;
|
|
|
1645
|
|
|
1646 begin
|
|
|
1647 F := First_Node (N);
|
|
|
1648 S := Sloc (F);
|
|
|
1649
|
|
|
1650 -- The following circuit is a bit subtle. When we have parenthesized
|
|
|
1651 -- expressions, then the Sloc will not record the location of the paren,
|
|
|
1652 -- but we would like to post the flag on the paren. So what we do is to
|
|
|
1653 -- crawl up the tree from the First_Node, adjusting the Sloc value for
|
|
|
1654 -- any parentheses we know are present. Yes, we know this circuit is not
|
|
|
1655 -- 100% reliable (e.g. because we don't record all possible paren level
|
|
|
1656 -- values), but this is only for an error message so it is good enough.
|
|
|
1657
|
|
|
1658 Node_Loop : loop
|
|
|
1659 Paren_Loop : for J in 1 .. Paren_Count (F) loop
|
|
|
1660
|
|
|
1661 -- We don't look more than 12 characters behind the current
|
|
|
1662 -- location, and in any case not past the front of the source.
|
|
|
1663
|
|
|
1664 Search_Loop : for K in 1 .. 12 loop
|
|
|
1665 exit Search_Loop when S = SF;
|
|
|
1666
|
|
|
1667 if Source_Text (SI) (S - 1) = '(' then
|
|
|
1668 S := S - 1;
|
|
|
1669 exit Search_Loop;
|
|
|
1670
|
|
|
1671 elsif Source_Text (SI) (S - 1) <= ' ' then
|
|
|
1672 S := S - 1;
|
|
|
1673
|
|
|
1674 else
|
|
|
1675 exit Search_Loop;
|
|
|
1676 end if;
|
|
|
1677 end loop Search_Loop;
|
|
|
1678 end loop Paren_Loop;
|
|
|
1679
|
|
|
1680 exit Node_Loop when F = N;
|
|
|
1681 F := Parent (F);
|
|
|
1682 exit Node_Loop when Nkind (F) not in N_Subexpr;
|
|
|
1683 end loop Node_Loop;
|
|
|
1684
|
|
|
1685 return S;
|
|
|
1686 end First_Sloc;
|
|
|
1687
|
|
|
1688 -----------------------
|
|
|
1689 -- Get_Ignore_Errors --
|
|
|
1690 -----------------------
|
|
|
1691
|
|
|
1692 function Get_Ignore_Errors return Boolean is
|
|
|
1693 begin
|
|
|
1694 return Errors_Must_Be_Ignored;
|
|
|
1695 end Get_Ignore_Errors;
|
|
|
1696
|
|
|
1697 ----------------
|
|
|
1698 -- Initialize --
|
|
|
1699 ----------------
|
|
|
1700
|
|
|
1701 procedure Initialize is
|
|
|
1702 begin
|
|
|
1703 Errors.Init;
|
|
|
1704 First_Error_Msg := No_Error_Msg;
|
|
|
1705 Last_Error_Msg := No_Error_Msg;
|
|
|
1706 Serious_Errors_Detected := 0;
|
|
|
1707 Total_Errors_Detected := 0;
|
|
|
1708 Cur_Msg := No_Error_Msg;
|
|
|
1709 List_Pragmas.Init;
|
|
|
1710
|
|
|
1711 -- Reset counts for warnings
|
|
|
1712
|
|
|
1713 Reset_Warnings;
|
|
|
1714
|
|
|
1715 -- Initialize warnings tables
|
|
|
1716
|
|
|
1717 Warnings.Init;
|
|
|
1718 Specific_Warnings.Init;
|
|
|
1719 end Initialize;
|
|
|
1720
|
|
145
|
1721 -------------------------------
|
|
|
1722 -- Is_Size_Too_Small_Message --
|
|
|
1723 -------------------------------
|
|
|
1724
|
|
|
1725 function Is_Size_Too_Small_Message (S : String) return Boolean is
|
|
|
1726 Size_For : constant String := "size for";
|
|
|
1727 pragma Assert (Size_Too_Small_Message (1 .. Size_For'Last) = Size_For);
|
|
|
1728 -- Assert that Size_Too_Small_Message starts with Size_For
|
|
|
1729 begin
|
|
|
1730 return S'Length >= Size_For'Length
|
|
|
1731 and then S (S'First .. S'First + Size_For'Length - 1) = Size_For;
|
|
|
1732 -- True if S starts with Size_For
|
|
|
1733 end Is_Size_Too_Small_Message;
|
|
|
1734
|
|
111
|
1735 -----------------
|
|
|
1736 -- No_Warnings --
|
|
|
1737 -----------------
|
|
|
1738
|
|
|
1739 function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
|
|
|
1740 begin
|
|
|
1741 if Error_Posted (N) then
|
|
|
1742 return True;
|
|
|
1743
|
|
|
1744 elsif Nkind (N) in N_Entity and then Has_Warnings_Off (N) then
|
|
|
1745 return True;
|
|
|
1746
|
|
|
1747 elsif Is_Entity_Name (N)
|
|
|
1748 and then Present (Entity (N))
|
|
|
1749 and then Has_Warnings_Off (Entity (N))
|
|
|
1750 then
|
|
|
1751 return True;
|
|
|
1752
|
|
|
1753 else
|
|
|
1754 return False;
|
|
|
1755 end if;
|
|
|
1756 end No_Warnings;
|
|
|
1757
|
|
|
1758 -------------
|
|
|
1759 -- OK_Node --
|
|
|
1760 -------------
|
|
|
1761
|
|
|
1762 function OK_Node (N : Node_Id) return Boolean is
|
|
|
1763 K : constant Node_Kind := Nkind (N);
|
|
|
1764
|
|
|
1765 begin
|
|
|
1766 if Error_Posted (N) then
|
|
|
1767 return False;
|
|
|
1768
|
|
|
1769 elsif K in N_Has_Etype
|
|
|
1770 and then Present (Etype (N))
|
|
|
1771 and then Error_Posted (Etype (N))
|
|
|
1772 then
|
|
|
1773 return False;
|
|
|
1774
|
|
|
1775 elsif (K in N_Op
|
|
|
1776 or else K = N_Attribute_Reference
|
|
|
1777 or else K = N_Character_Literal
|
|
|
1778 or else K = N_Expanded_Name
|
|
|
1779 or else K = N_Identifier
|
|
|
1780 or else K = N_Operator_Symbol)
|
|
|
1781 and then Present (Entity (N))
|
|
|
1782 and then Error_Posted (Entity (N))
|
|
|
1783 then
|
|
|
1784 return False;
|
|
|
1785 else
|
|
|
1786 return True;
|
|
|
1787 end if;
|
|
|
1788 end OK_Node;
|
|
|
1789
|
|
|
1790 ---------------------
|
|
|
1791 -- Output_Messages --
|
|
|
1792 ---------------------
|
|
|
1793
|
|
|
1794 procedure Output_Messages is
|
|
|
1795 E : Error_Msg_Id;
|
|
|
1796 Err_Flag : Boolean;
|
|
|
1797
|
|
|
1798 procedure Write_Error_Summary;
|
|
|
1799 -- Write error summary
|
|
|
1800
|
|
|
1801 procedure Write_Header (Sfile : Source_File_Index);
|
|
|
1802 -- Write header line (compiling or checking given file)
|
|
|
1803
|
|
|
1804 procedure Write_Max_Errors;
|
|
|
1805 -- Write message if max errors reached
|
|
|
1806
|
|
|
1807 -------------------------
|
|
|
1808 -- Write_Error_Summary --
|
|
|
1809 -------------------------
|
|
|
1810
|
|
|
1811 procedure Write_Error_Summary is
|
|
|
1812 begin
|
|
|
1813 -- Extra blank line if error messages or source listing were output
|
|
|
1814
|
|
|
1815 if Total_Errors_Detected + Warnings_Detected > 0 or else Full_List
|
|
|
1816 then
|
|
|
1817 Write_Eol;
|
|
|
1818 end if;
|
|
|
1819
|
|
|
1820 -- Message giving number of lines read and number of errors detected.
|
|
|
1821 -- This normally goes to Standard_Output. The exception is when brief
|
|
|
1822 -- mode is not set, verbose mode (or full list mode) is set, and
|
|
|
1823 -- there are errors. In this case we send the message to standard
|
|
|
1824 -- error to make sure that *something* appears on standard error
|
|
|
1825 -- in an error situation.
|
|
|
1826
|
|
|
1827 if Total_Errors_Detected + Warnings_Detected /= 0
|
|
|
1828 and then not Brief_Output
|
|
|
1829 and then (Verbose_Mode or Full_List)
|
|
|
1830 then
|
|
|
1831 Set_Standard_Error;
|
|
|
1832 end if;
|
|
|
1833
|
|
|
1834 -- Message giving total number of lines. Don't give this message if
|
|
|
1835 -- the Main_Source line is unknown (this happens in error situations,
|
|
|
1836 -- e.g. when integrated preprocessing fails).
|
|
|
1837
|
|
|
1838 if Main_Source_File > No_Source_File then
|
|
|
1839 Write_Str (" ");
|
|
|
1840 Write_Int (Num_Source_Lines (Main_Source_File));
|
|
|
1841
|
|
|
1842 if Num_Source_Lines (Main_Source_File) = 1 then
|
|
|
1843 Write_Str (" line: ");
|
|
|
1844 else
|
|
|
1845 Write_Str (" lines: ");
|
|
|
1846 end if;
|
|
|
1847 end if;
|
|
|
1848
|
|
|
1849 if Total_Errors_Detected = 0 then
|
|
|
1850 Write_Str ("No errors");
|
|
|
1851
|
|
|
1852 elsif Total_Errors_Detected = 1 then
|
|
|
1853 Write_Str ("1 error");
|
|
|
1854
|
|
|
1855 else
|
|
|
1856 Write_Int (Total_Errors_Detected);
|
|
|
1857 Write_Str (" errors");
|
|
|
1858 end if;
|
|
|
1859
|
|
|
1860 if Warnings_Detected - Warning_Info_Messages /= 0 then
|
|
|
1861 Write_Str (", ");
|
|
|
1862 Write_Int (Warnings_Detected);
|
|
|
1863 Write_Str (" warning");
|
|
|
1864
|
|
|
1865 if Warnings_Detected - Warning_Info_Messages /= 1 then
|
|
|
1866 Write_Char ('s');
|
|
|
1867 end if;
|
|
|
1868
|
|
|
1869 if Warning_Mode = Treat_As_Error then
|
|
|
1870 Write_Str (" (treated as error");
|
|
|
1871
|
|
|
1872 if Warnings_Detected /= 1 then
|
|
|
1873 Write_Char ('s');
|
|
|
1874 end if;
|
|
|
1875
|
|
|
1876 Write_Char (')');
|
|
|
1877
|
|
|
1878 elsif Warnings_Treated_As_Errors /= 0 then
|
|
|
1879 Write_Str (" (");
|
|
|
1880 Write_Int (Warnings_Treated_As_Errors);
|
|
|
1881 Write_Str (" treated as errors)");
|
|
|
1882 end if;
|
|
|
1883 end if;
|
|
|
1884
|
|
|
1885 if Warning_Info_Messages + Report_Info_Messages /= 0 then
|
|
|
1886 Write_Str (", ");
|
|
|
1887 Write_Int (Warning_Info_Messages + Report_Info_Messages);
|
|
|
1888 Write_Str (" info message");
|
|
|
1889
|
|
|
1890 if Warning_Info_Messages + Report_Info_Messages > 1 then
|
|
|
1891 Write_Char ('s');
|
|
|
1892 end if;
|
|
|
1893 end if;
|
|
|
1894
|
|
|
1895 Write_Eol;
|
|
|
1896 Set_Standard_Output;
|
|
|
1897 end Write_Error_Summary;
|
|
|
1898
|
|
|
1899 ------------------
|
|
|
1900 -- Write_Header --
|
|
|
1901 ------------------
|
|
|
1902
|
|
|
1903 procedure Write_Header (Sfile : Source_File_Index) is
|
|
|
1904 begin
|
|
|
1905 if Verbose_Mode or Full_List then
|
|
|
1906 if Original_Operating_Mode = Generate_Code then
|
|
|
1907 Write_Str ("Compiling: ");
|
|
|
1908 else
|
|
|
1909 Write_Str ("Checking: ");
|
|
|
1910 end if;
|
|
|
1911
|
|
|
1912 Write_Name (Full_File_Name (Sfile));
|
|
|
1913
|
|
|
1914 if not Debug_Flag_7 then
|
|
|
1915 Write_Eol;
|
|
|
1916 Write_Str ("Source file time stamp: ");
|
|
|
1917 Write_Time_Stamp (Sfile);
|
|
|
1918 Write_Eol;
|
|
|
1919 Write_Str ("Compiled at: " & Compilation_Time);
|
|
|
1920 end if;
|
|
|
1921
|
|
|
1922 Write_Eol;
|
|
|
1923 end if;
|
|
|
1924 end Write_Header;
|
|
|
1925
|
|
|
1926 ----------------------
|
|
|
1927 -- Write_Max_Errors --
|
|
|
1928 ----------------------
|
|
|
1929
|
|
|
1930 procedure Write_Max_Errors is
|
|
|
1931 begin
|
|
|
1932 if Maximum_Messages /= 0 then
|
|
|
1933 if Warnings_Detected >= Maximum_Messages then
|
|
|
1934 Set_Standard_Error;
|
|
|
1935 Write_Line ("maximum number of warnings output");
|
|
|
1936 Write_Line ("any further warnings suppressed");
|
|
|
1937 Set_Standard_Output;
|
|
|
1938 end if;
|
|
|
1939
|
|
|
1940 -- If too many errors print message
|
|
|
1941
|
|
|
1942 if Total_Errors_Detected >= Maximum_Messages then
|
|
|
1943 Set_Standard_Error;
|
|
|
1944 Write_Line ("fatal error: maximum number of errors detected");
|
|
|
1945 Set_Standard_Output;
|
|
|
1946 end if;
|
|
|
1947 end if;
|
|
|
1948 end Write_Max_Errors;
|
|
|
1949
|
|
|
1950 -- Start of processing for Output_Messages
|
|
|
1951
|
|
|
1952 begin
|
|
|
1953 -- Error if Finalize has not been called
|
|
|
1954
|
|
|
1955 if not Finalize_Called then
|
|
|
1956 raise Program_Error;
|
|
|
1957 end if;
|
|
|
1958
|
|
|
1959 -- Reset current error source file if the main unit has a pragma
|
|
|
1960 -- Source_Reference. This ensures outputting the proper name of
|
|
|
1961 -- the source file in this situation.
|
|
|
1962
|
|
|
1963 if Main_Source_File <= No_Source_File
|
|
|
1964 or else Num_SRef_Pragmas (Main_Source_File) /= 0
|
|
|
1965 then
|
|
|
1966 Current_Error_Source_File := No_Source_File;
|
|
|
1967 end if;
|
|
|
1968
|
|
|
1969 -- Brief Error mode
|
|
|
1970
|
|
|
1971 if Brief_Output or (not Full_List and not Verbose_Mode) then
|
|
|
1972 Set_Standard_Error;
|
|
|
1973
|
|
|
1974 E := First_Error_Msg;
|
|
|
1975 while E /= No_Error_Msg loop
|
|
|
1976 if not Errors.Table (E).Deleted and then not Debug_Flag_KK then
|
|
|
1977 if Full_Path_Name_For_Brief_Errors then
|
|
|
1978 Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
|
|
|
1979 else
|
|
|
1980 Write_Name (Reference_Name (Errors.Table (E).Sfile));
|
|
|
1981 end if;
|
|
|
1982
|
|
|
1983 Write_Char (':');
|
|
|
1984 Write_Int (Int (Physical_To_Logical
|
|
|
1985 (Errors.Table (E).Line,
|
|
|
1986 Errors.Table (E).Sfile)));
|
|
|
1987 Write_Char (':');
|
|
|
1988
|
|
|
1989 if Errors.Table (E).Col < 10 then
|
|
|
1990 Write_Char ('0');
|
|
|
1991 end if;
|
|
|
1992
|
|
|
1993 Write_Int (Int (Errors.Table (E).Col));
|
|
|
1994 Write_Str (": ");
|
|
|
1995 Output_Msg_Text (E);
|
|
|
1996 Write_Eol;
|
|
|
1997 end if;
|
|
|
1998
|
|
|
1999 E := Errors.Table (E).Next;
|
|
|
2000 end loop;
|
|
|
2001
|
|
|
2002 Set_Standard_Output;
|
|
|
2003 end if;
|
|
|
2004
|
|
|
2005 -- Full source listing case
|
|
|
2006
|
|
|
2007 if Full_List then
|
|
|
2008 List_Pragmas_Index := 1;
|
|
|
2009 List_Pragmas_Mode := True;
|
|
|
2010 E := First_Error_Msg;
|
|
|
2011
|
|
|
2012 -- Normal case, to stdout (copyright notice already output)
|
|
|
2013
|
|
|
2014 if Full_List_File_Name = null then
|
|
|
2015 if not Debug_Flag_7 then
|
|
|
2016 Write_Eol;
|
|
|
2017 end if;
|
|
|
2018
|
|
|
2019 -- Output to file
|
|
|
2020
|
|
|
2021 else
|
|
|
2022 Create_List_File_Access.all (Full_List_File_Name.all);
|
|
|
2023 Set_Special_Output (Write_List_Info_Access.all'Access);
|
|
|
2024
|
|
|
2025 -- Write copyright notice to file
|
|
|
2026
|
|
|
2027 if not Debug_Flag_7 then
|
|
|
2028 Write_Str ("GNAT ");
|
|
|
2029 Write_Str (Gnat_Version_String);
|
|
|
2030 Write_Eol;
|
|
|
2031 Write_Str ("Copyright 1992-" &
|
|
|
2032 Current_Year &
|
|
|
2033 ", Free Software Foundation, Inc.");
|
|
|
2034 Write_Eol;
|
|
|
2035 end if;
|
|
|
2036 end if;
|
|
|
2037
|
|
|
2038 -- First list extended main source file units with errors
|
|
|
2039
|
|
|
2040 for U in Main_Unit .. Last_Unit loop
|
|
|
2041 if In_Extended_Main_Source_Unit (Cunit_Entity (U))
|
|
|
2042
|
|
|
2043 -- If debug flag d.m is set, only the main source is listed
|
|
|
2044
|
|
|
2045 and then (U = Main_Unit or else not Debug_Flag_Dot_M)
|
|
|
2046
|
|
|
2047 -- If the unit of the entity does not come from source, it is
|
|
|
2048 -- an implicit subprogram declaration for a child subprogram.
|
|
|
2049 -- Do not emit errors for it, they are listed with the body.
|
|
|
2050
|
|
|
2051 and then
|
|
|
2052 (No (Cunit_Entity (U))
|
|
|
2053 or else Comes_From_Source (Cunit_Entity (U))
|
|
|
2054 or else not Is_Subprogram (Cunit_Entity (U)))
|
|
|
2055
|
|
|
2056 -- If the compilation unit associated with this unit does not
|
|
|
2057 -- come from source, it means it is an instantiation that should
|
|
|
2058 -- not be included in the source listing.
|
|
|
2059
|
|
|
2060 and then Comes_From_Source (Cunit (U))
|
|
|
2061 then
|
|
|
2062 declare
|
|
|
2063 Sfile : constant Source_File_Index := Source_Index (U);
|
|
|
2064
|
|
|
2065 begin
|
|
|
2066 Write_Eol;
|
|
|
2067
|
|
|
2068 -- Only write the header if Sfile is known
|
|
|
2069
|
|
|
2070 if Sfile > No_Source_File then
|
|
|
2071 Write_Header (Sfile);
|
|
|
2072 Write_Eol;
|
|
|
2073 end if;
|
|
|
2074
|
|
|
2075 -- Normally, we don't want an "error messages from file"
|
|
|
2076 -- message when listing the entire file, so we set the
|
|
|
2077 -- current source file as the current error source file.
|
|
|
2078 -- However, the old style of doing things was to list this
|
|
|
2079 -- message if pragma Source_Reference is present, even for
|
|
|
2080 -- the main unit. Since the purpose of the -gnatd.m switch
|
|
|
2081 -- is to duplicate the old behavior, we skip the reset if
|
|
|
2082 -- this debug flag is set.
|
|
|
2083
|
|
|
2084 if not Debug_Flag_Dot_M then
|
|
|
2085 Current_Error_Source_File := Sfile;
|
|
|
2086 end if;
|
|
|
2087
|
|
|
2088 -- Only output the listing if Sfile is known, to avoid
|
|
|
2089 -- crashing the compiler.
|
|
|
2090
|
|
|
2091 if Sfile > No_Source_File then
|
|
|
2092 for N in 1 .. Last_Source_Line (Sfile) loop
|
|
|
2093 while E /= No_Error_Msg
|
|
|
2094 and then Errors.Table (E).Deleted
|
|
|
2095 loop
|
|
|
2096 E := Errors.Table (E).Next;
|
|
|
2097 end loop;
|
|
|
2098
|
|
|
2099 Err_Flag :=
|
|
|
2100 E /= No_Error_Msg
|
|
|
2101 and then Errors.Table (E).Line = N
|
|
|
2102 and then Errors.Table (E).Sfile = Sfile;
|
|
|
2103
|
|
|
2104 Output_Source_Line (N, Sfile, Err_Flag);
|
|
|
2105
|
|
|
2106 if Err_Flag then
|
|
|
2107 Output_Error_Msgs (E);
|
|
|
2108
|
|
|
2109 if not Debug_Flag_2 then
|
|
|
2110 Write_Eol;
|
|
|
2111 end if;
|
|
|
2112 end if;
|
|
|
2113 end loop;
|
|
|
2114 end if;
|
|
|
2115 end;
|
|
|
2116 end if;
|
|
|
2117 end loop;
|
|
|
2118
|
|
|
2119 -- Then output errors, if any, for subsidiary units not in the
|
|
|
2120 -- main extended unit.
|
|
|
2121
|
|
|
2122 -- Note: if debug flag d.m set, include errors for any units other
|
|
|
2123 -- than the main unit in the extended source unit (e.g. spec and
|
|
|
2124 -- subunits for a body).
|
|
|
2125
|
|
|
2126 while E /= No_Error_Msg
|
|
|
2127 and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr)
|
|
|
2128 or else
|
|
|
2129 (Debug_Flag_Dot_M
|
|
|
2130 and then Get_Source_Unit
|
|
|
2131 (Errors.Table (E).Sptr) /= Main_Unit))
|
|
|
2132 loop
|
|
|
2133 if Errors.Table (E).Deleted then
|
|
|
2134 E := Errors.Table (E).Next;
|
|
|
2135
|
|
|
2136 else
|
|
|
2137 Write_Eol;
|
|
|
2138 Output_Source_Line
|
|
|
2139 (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
|
|
|
2140 Output_Error_Msgs (E);
|
|
|
2141 end if;
|
|
|
2142 end loop;
|
|
|
2143
|
|
|
2144 -- If output to file, write extra copy of error summary to the
|
|
|
2145 -- output file, and then close it.
|
|
|
2146
|
|
|
2147 if Full_List_File_Name /= null then
|
|
|
2148 Write_Error_Summary;
|
|
|
2149 Write_Max_Errors;
|
|
|
2150 Close_List_File_Access.all;
|
|
|
2151 Cancel_Special_Output;
|
|
|
2152 end if;
|
|
|
2153 end if;
|
|
|
2154
|
|
|
2155 -- Verbose mode (error lines only with error flags). Normally this is
|
|
|
2156 -- ignored in full list mode, unless we are listing to a file, in which
|
|
|
2157 -- case we still generate -gnatv output to standard output.
|
|
|
2158
|
|
|
2159 if Verbose_Mode
|
|
|
2160 and then (not Full_List or else Full_List_File_Name /= null)
|
|
|
2161 then
|
|
|
2162 Write_Eol;
|
|
|
2163
|
|
|
2164 -- Output the header only when Main_Source_File is known
|
|
|
2165
|
|
|
2166 if Main_Source_File > No_Source_File then
|
|
|
2167 Write_Header (Main_Source_File);
|
|
|
2168 end if;
|
|
|
2169
|
|
|
2170 E := First_Error_Msg;
|
|
|
2171
|
|
|
2172 -- Loop through error lines
|
|
|
2173
|
|
|
2174 while E /= No_Error_Msg loop
|
|
|
2175 if Errors.Table (E).Deleted then
|
|
|
2176 E := Errors.Table (E).Next;
|
|
|
2177 else
|
|
|
2178 Write_Eol;
|
|
|
2179 Output_Source_Line
|
|
|
2180 (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
|
|
|
2181 Output_Error_Msgs (E);
|
|
|
2182 end if;
|
|
|
2183 end loop;
|
|
|
2184 end if;
|
|
|
2185
|
|
|
2186 -- Output error summary if verbose or full list mode
|
|
|
2187
|
|
|
2188 if Verbose_Mode or else Full_List then
|
|
|
2189 Write_Error_Summary;
|
|
|
2190 end if;
|
|
|
2191
|
|
|
2192 Write_Max_Errors;
|
|
|
2193
|
|
|
2194 -- Even though Warning_Info_Messages are a subclass of warnings, they
|
|
|
2195 -- must not be treated as errors when -gnatwe is in effect.
|
|
|
2196
|
|
|
2197 if Warning_Mode = Treat_As_Error then
|
|
|
2198 Total_Errors_Detected :=
|
|
|
2199 Total_Errors_Detected + Warnings_Detected - Warning_Info_Messages;
|
|
|
2200 Warnings_Detected := Warning_Info_Messages;
|
|
|
2201 end if;
|
|
|
2202 end Output_Messages;
|
|
|
2203
|
|
|
2204 ------------------------
|
|
|
2205 -- Output_Source_Line --
|
|
|
2206 ------------------------
|
|
|
2207
|
|
|
2208 procedure Output_Source_Line
|
|
|
2209 (L : Physical_Line_Number;
|
|
|
2210 Sfile : Source_File_Index;
|
|
|
2211 Errs : Boolean)
|
|
|
2212 is
|
|
|
2213 S : Source_Ptr;
|
|
|
2214 C : Character;
|
|
|
2215
|
|
|
2216 Line_Number_Output : Boolean := False;
|
|
|
2217 -- Set True once line number is output
|
|
|
2218
|
|
|
2219 Empty_Line : Boolean := True;
|
|
|
2220 -- Set False if line includes at least one character
|
|
|
2221
|
|
|
2222 begin
|
|
|
2223 if Sfile /= Current_Error_Source_File then
|
|
|
2224 Write_Str ("==============Error messages for ");
|
|
|
2225
|
|
|
2226 case Sinput.File_Type (Sfile) is
|
|
|
2227 when Sinput.Src =>
|
|
|
2228 Write_Str ("source");
|
|
|
2229
|
|
|
2230 when Sinput.Config =>
|
|
|
2231 Write_Str ("configuration pragmas");
|
|
|
2232
|
|
|
2233 when Sinput.Def =>
|
|
|
2234 Write_Str ("symbol definition");
|
|
|
2235
|
|
|
2236 when Sinput.Preproc =>
|
|
|
2237 Write_Str ("preprocessing data");
|
|
|
2238 end case;
|
|
|
2239
|
|
|
2240 Write_Str (" file: ");
|
|
|
2241 Write_Name (Full_File_Name (Sfile));
|
|
|
2242 Write_Eol;
|
|
|
2243
|
|
|
2244 if Num_SRef_Pragmas (Sfile) > 0 then
|
|
|
2245 Write_Str ("--------------Line numbers from file: ");
|
|
|
2246 Write_Name (Full_Ref_Name (Sfile));
|
|
|
2247 Write_Str (" (starting at line ");
|
|
|
2248 Write_Int (Int (First_Mapped_Line (Sfile)));
|
|
|
2249 Write_Char (')');
|
|
|
2250 Write_Eol;
|
|
|
2251 end if;
|
|
|
2252
|
|
|
2253 Current_Error_Source_File := Sfile;
|
|
|
2254 end if;
|
|
|
2255
|
|
|
2256 if Errs or List_Pragmas_Mode then
|
|
|
2257 Output_Line_Number (Physical_To_Logical (L, Sfile));
|
|
|
2258 Line_Number_Output := True;
|
|
|
2259 end if;
|
|
|
2260
|
|
|
2261 S := Line_Start (L, Sfile);
|
|
|
2262
|
|
|
2263 loop
|
|
|
2264 C := Source_Text (Sfile) (S);
|
|
|
2265 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
|
|
|
2266
|
|
|
2267 -- Deal with matching entry in List_Pragmas table
|
|
|
2268
|
|
|
2269 if Full_List
|
|
|
2270 and then List_Pragmas_Index <= List_Pragmas.Last
|
|
|
2271 and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc
|
|
|
2272 then
|
|
|
2273 case List_Pragmas.Table (List_Pragmas_Index).Ptyp is
|
|
|
2274 when Page =>
|
|
|
2275 Write_Char (C);
|
|
|
2276
|
|
|
2277 -- Ignore if on line with errors so that error flags
|
|
|
2278 -- get properly listed with the error line .
|
|
|
2279
|
|
|
2280 if not Errs then
|
|
|
2281 Write_Char (ASCII.FF);
|
|
|
2282 end if;
|
|
|
2283
|
|
|
2284 when List_On =>
|
|
|
2285 List_Pragmas_Mode := True;
|
|
|
2286
|
|
|
2287 if not Line_Number_Output then
|
|
|
2288 Output_Line_Number (Physical_To_Logical (L, Sfile));
|
|
|
2289 Line_Number_Output := True;
|
|
|
2290 end if;
|
|
|
2291
|
|
|
2292 Write_Char (C);
|
|
|
2293
|
|
|
2294 when List_Off =>
|
|
|
2295 Write_Char (C);
|
|
|
2296 List_Pragmas_Mode := False;
|
|
|
2297 end case;
|
|
|
2298
|
|
|
2299 List_Pragmas_Index := List_Pragmas_Index + 1;
|
|
|
2300
|
|
|
2301 -- Normal case (no matching entry in List_Pragmas table)
|
|
|
2302
|
|
|
2303 else
|
|
|
2304 if Errs or List_Pragmas_Mode then
|
|
|
2305 Write_Char (C);
|
|
|
2306 end if;
|
|
|
2307 end if;
|
|
|
2308
|
|
|
2309 Empty_Line := False;
|
|
|
2310 S := S + 1;
|
|
|
2311 end loop;
|
|
|
2312
|
|
|
2313 -- If we have output a source line, then add the line terminator, with
|
|
|
2314 -- training spaces preserved (so we output the line exactly as input).
|
|
|
2315
|
|
|
2316 if Line_Number_Output then
|
|
|
2317 if Empty_Line then
|
|
|
2318 Write_Eol;
|
|
|
2319 else
|
|
|
2320 Write_Eol_Keep_Blanks;
|
|
|
2321 end if;
|
|
|
2322 end if;
|
|
|
2323 end Output_Source_Line;
|
|
|
2324
|
|
|
2325 -----------------------------
|
|
|
2326 -- Remove_Warning_Messages --
|
|
|
2327 -----------------------------
|
|
|
2328
|
|
|
2329 procedure Remove_Warning_Messages (N : Node_Id) is
|
|
|
2330
|
|
|
2331 function Check_For_Warning (N : Node_Id) return Traverse_Result;
|
|
|
2332 -- This function checks one node for a possible warning message
|
|
|
2333
|
|
|
2334 function Check_All_Warnings is new Traverse_Func (Check_For_Warning);
|
|
|
2335 -- This defines the traversal operation
|
|
|
2336
|
|
|
2337 -----------------------
|
|
|
2338 -- Check_For_Warning --
|
|
|
2339 -----------------------
|
|
|
2340
|
|
|
2341 function Check_For_Warning (N : Node_Id) return Traverse_Result is
|
|
|
2342 Loc : constant Source_Ptr := Sloc (N);
|
|
|
2343 E : Error_Msg_Id;
|
|
|
2344
|
|
|
2345 function To_Be_Removed (E : Error_Msg_Id) return Boolean;
|
|
|
2346 -- Returns True for a message that is to be removed. Also adjusts
|
|
|
2347 -- warning count appropriately.
|
|
|
2348
|
|
|
2349 -------------------
|
|
|
2350 -- To_Be_Removed --
|
|
|
2351 -------------------
|
|
|
2352
|
|
|
2353 function To_Be_Removed (E : Error_Msg_Id) return Boolean is
|
|
|
2354 begin
|
|
|
2355 if E /= No_Error_Msg
|
|
|
2356
|
|
|
2357 -- Don't remove if location does not match
|
|
|
2358
|
|
|
2359 and then Errors.Table (E).Optr = Loc
|
|
|
2360
|
|
|
2361 -- Don't remove if not warning/info message. Note that we do
|
|
|
2362 -- not remove style messages here. They are warning messages
|
|
|
2363 -- but not ones we want removed in this context.
|
|
|
2364
|
|
|
2365 and then Errors.Table (E).Warn
|
|
|
2366
|
|
|
2367 -- Don't remove unconditional messages
|
|
|
2368
|
|
|
2369 and then not Errors.Table (E).Uncond
|
|
|
2370 then
|
|
|
2371 Warnings_Detected := Warnings_Detected - 1;
|
|
|
2372
|
|
|
2373 if Errors.Table (E).Info then
|
|
|
2374 Warning_Info_Messages := Warning_Info_Messages - 1;
|
|
|
2375 end if;
|
|
|
2376
|
|
|
2377 return True;
|
|
|
2378
|
|
|
2379 -- No removal required
|
|
|
2380
|
|
|
2381 else
|
|
|
2382 return False;
|
|
|
2383 end if;
|
|
|
2384 end To_Be_Removed;
|
|
|
2385
|
|
|
2386 -- Start of processing for Check_For_Warnings
|
|
|
2387
|
|
|
2388 begin
|
|
|
2389 while To_Be_Removed (First_Error_Msg) loop
|
|
|
2390 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
|
|
|
2391 end loop;
|
|
|
2392
|
|
|
2393 if First_Error_Msg = No_Error_Msg then
|
|
|
2394 Last_Error_Msg := No_Error_Msg;
|
|
|
2395 end if;
|
|
|
2396
|
|
|
2397 E := First_Error_Msg;
|
|
|
2398 while E /= No_Error_Msg loop
|
|
|
2399 while To_Be_Removed (Errors.Table (E).Next) loop
|
|
|
2400 Errors.Table (E).Next :=
|
|
|
2401 Errors.Table (Errors.Table (E).Next).Next;
|
|
|
2402
|
|
|
2403 if Errors.Table (E).Next = No_Error_Msg then
|
|
|
2404 Last_Error_Msg := E;
|
|
|
2405 end if;
|
|
|
2406 end loop;
|
|
|
2407
|
|
|
2408 E := Errors.Table (E).Next;
|
|
|
2409 end loop;
|
|
|
2410
|
|
|
2411 if Nkind (N) = N_Raise_Constraint_Error
|
|
131
|
2412 and then Is_Rewrite_Substitution (N)
|
|
111
|
2413 and then No (Condition (N))
|
|
|
2414 then
|
|
|
2415 -- Warnings may have been posted on subexpressions of the original
|
|
|
2416 -- tree. We place the original node back on the tree to remove
|
|
|
2417 -- those warnings, whose sloc do not match those of any node in
|
|
|
2418 -- the current tree. Given that we are in unreachable code, this
|
|
|
2419 -- modification to the tree is harmless.
|
|
|
2420
|
|
|
2421 declare
|
|
|
2422 Status : Traverse_Final_Result;
|
|
|
2423
|
|
|
2424 begin
|
|
|
2425 if Is_List_Member (N) then
|
|
|
2426 Set_Condition (N, Original_Node (N));
|
|
|
2427 Status := Check_All_Warnings (Condition (N));
|
|
|
2428 else
|
|
|
2429 Rewrite (N, Original_Node (N));
|
|
|
2430 Status := Check_All_Warnings (N);
|
|
|
2431 end if;
|
|
|
2432
|
|
|
2433 return Status;
|
|
|
2434 end;
|
|
|
2435
|
|
|
2436 else
|
|
|
2437 return OK;
|
|
|
2438 end if;
|
|
|
2439 end Check_For_Warning;
|
|
|
2440
|
|
|
2441 -- Start of processing for Remove_Warning_Messages
|
|
|
2442
|
|
|
2443 begin
|
|
|
2444 if Warnings_Detected /= 0 then
|
|
|
2445 declare
|
|
|
2446 Discard : Traverse_Final_Result;
|
|
|
2447 pragma Warnings (Off, Discard);
|
|
|
2448
|
|
|
2449 begin
|
|
|
2450 Discard := Check_All_Warnings (N);
|
|
|
2451 end;
|
|
|
2452 end if;
|
|
|
2453 end Remove_Warning_Messages;
|
|
|
2454
|
|
|
2455 procedure Remove_Warning_Messages (L : List_Id) is
|
|
|
2456 Stat : Node_Id;
|
|
|
2457 begin
|
|
|
2458 if Is_Non_Empty_List (L) then
|
|
|
2459 Stat := First (L);
|
|
|
2460 while Present (Stat) loop
|
|
|
2461 Remove_Warning_Messages (Stat);
|
|
|
2462 Next (Stat);
|
|
|
2463 end loop;
|
|
|
2464 end if;
|
|
|
2465 end Remove_Warning_Messages;
|
|
|
2466
|
|
|
2467 --------------------
|
|
|
2468 -- Reset_Warnings --
|
|
|
2469 --------------------
|
|
|
2470
|
|
|
2471 procedure Reset_Warnings is
|
|
|
2472 begin
|
|
|
2473 Warnings_Treated_As_Errors := 0;
|
|
|
2474 Warnings_Detected := 0;
|
|
|
2475 Warning_Info_Messages := 0;
|
|
|
2476 Warnings_As_Errors_Count := 0;
|
|
|
2477 end Reset_Warnings;
|
|
|
2478
|
|
|
2479 ----------------------
|
|
|
2480 -- Adjust_Name_Case --
|
|
|
2481 ----------------------
|
|
|
2482
|
|
|
2483 procedure Adjust_Name_Case
|
|
|
2484 (Buf : in out Bounded_String;
|
|
|
2485 Loc : Source_Ptr)
|
|
|
2486 is
|
|
|
2487 begin
|
|
|
2488 -- We have an all lower case name from Namet, and now we want to set
|
|
|
2489 -- the appropriate case. If possible we copy the actual casing from
|
|
|
2490 -- the source. If not we use standard identifier casing.
|
|
|
2491
|
|
|
2492 declare
|
|
|
2493 Src_Ind : constant Source_File_Index := Get_Source_File_Index (Loc);
|
|
|
2494 Sbuffer : Source_Buffer_Ptr;
|
|
|
2495 Ref_Ptr : Integer;
|
|
|
2496 Src_Ptr : Source_Ptr;
|
|
|
2497
|
|
|
2498 begin
|
|
|
2499 Ref_Ptr := 1;
|
|
|
2500 Src_Ptr := Loc;
|
|
|
2501
|
|
|
2502 -- For standard locations, always use mixed case
|
|
|
2503
|
|
|
2504 if Loc <= No_Location then
|
|
|
2505 Set_Casing (Mixed_Case);
|
|
|
2506
|
|
|
2507 else
|
|
|
2508 -- Determine if the reference we are dealing with corresponds to
|
|
|
2509 -- text at the point of the error reference. This will often be
|
|
|
2510 -- the case for simple identifier references, and is the case
|
|
|
2511 -- where we can copy the casing from the source.
|
|
|
2512
|
|
|
2513 Sbuffer := Source_Text (Src_Ind);
|
|
|
2514
|
|
|
2515 while Ref_Ptr <= Buf.Length loop
|
|
|
2516 exit when
|
|
|
2517 Fold_Lower (Sbuffer (Src_Ptr)) /=
|
|
|
2518 Fold_Lower (Buf.Chars (Ref_Ptr));
|
|
|
2519 Ref_Ptr := Ref_Ptr + 1;
|
|
|
2520 Src_Ptr := Src_Ptr + 1;
|
|
|
2521 end loop;
|
|
|
2522
|
|
|
2523 -- If we get through the loop without a mismatch, then output the
|
|
|
2524 -- name the way it is cased in the source program
|
|
|
2525
|
|
|
2526 if Ref_Ptr > Buf.Length then
|
|
|
2527 Src_Ptr := Loc;
|
|
|
2528
|
|
|
2529 for J in 1 .. Buf.Length loop
|
|
|
2530 Buf.Chars (J) := Sbuffer (Src_Ptr);
|
|
|
2531 Src_Ptr := Src_Ptr + 1;
|
|
|
2532 end loop;
|
|
|
2533
|
|
|
2534 -- Otherwise set the casing using the default identifier casing
|
|
|
2535
|
|
|
2536 else
|
|
|
2537 Set_Casing (Buf, Identifier_Casing (Src_Ind));
|
|
|
2538 end if;
|
|
|
2539 end if;
|
|
|
2540 end;
|
|
|
2541 end Adjust_Name_Case;
|
|
|
2542
|
|
|
2543 procedure Adjust_Name_Case (Loc : Source_Ptr) is
|
|
|
2544 begin
|
|
|
2545 Adjust_Name_Case (Global_Name_Buffer, Loc);
|
|
|
2546 end Adjust_Name_Case;
|
|
|
2547
|
|
|
2548 ---------------------------
|
|
|
2549 -- Set_Identifier_Casing --
|
|
|
2550 ---------------------------
|
|
|
2551
|
|
|
2552 procedure Set_Identifier_Casing
|
|
|
2553 (Identifier_Name : System.Address;
|
|
|
2554 File_Name : System.Address)
|
|
|
2555 is
|
|
|
2556 Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name);
|
|
|
2557 File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name);
|
|
|
2558 Flen : Natural;
|
|
|
2559
|
|
|
2560 Desired_Case : Casing_Type := Mixed_Case;
|
|
|
2561 -- Casing required for result. Default value of Mixed_Case is used if
|
|
|
2562 -- for some reason we cannot find the right file name in the table.
|
|
|
2563
|
|
|
2564 begin
|
|
|
2565 -- Get length of file name
|
|
|
2566
|
|
|
2567 Flen := 0;
|
|
|
2568 while File (Flen + 1) /= ASCII.NUL loop
|
|
|
2569 Flen := Flen + 1;
|
|
|
2570 end loop;
|
|
|
2571
|
|
|
2572 -- Loop through file names to find matching one. This is a bit slow, but
|
|
|
2573 -- we only do it in error situations so it is not so terrible. Note that
|
|
|
2574 -- if the loop does not exit, then the desired case will be left set to
|
|
|
2575 -- Mixed_Case, this can happen if the name was not in canonical form.
|
|
|
2576
|
|
|
2577 for J in 1 .. Last_Source_File loop
|
|
|
2578 Get_Name_String (Full_Debug_Name (J));
|
|
|
2579
|
|
|
2580 if Name_Len = Flen
|
|
|
2581 and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen))
|
|
|
2582 then
|
|
|
2583 Desired_Case := Identifier_Casing (J);
|
|
|
2584 exit;
|
|
|
2585 end if;
|
|
|
2586 end loop;
|
|
|
2587
|
|
|
2588 -- Copy identifier as given to Name_Buffer
|
|
|
2589
|
|
|
2590 for J in Name_Buffer'Range loop
|
|
|
2591 Name_Buffer (J) := Ident (J);
|
|
|
2592
|
|
|
2593 if Name_Buffer (J) = ASCII.NUL then
|
|
|
2594 Name_Len := J - 1;
|
|
|
2595 exit;
|
|
|
2596 end if;
|
|
|
2597 end loop;
|
|
|
2598
|
|
|
2599 Set_Casing (Desired_Case);
|
|
|
2600 end Set_Identifier_Casing;
|
|
|
2601
|
|
|
2602 -----------------------
|
|
|
2603 -- Set_Ignore_Errors --
|
|
|
2604 -----------------------
|
|
|
2605
|
|
|
2606 procedure Set_Ignore_Errors (To : Boolean) is
|
|
|
2607 begin
|
|
|
2608 Errors_Must_Be_Ignored := To;
|
|
|
2609 end Set_Ignore_Errors;
|
|
|
2610
|
|
|
2611 ------------------------------
|
|
|
2612 -- Set_Msg_Insertion_Column --
|
|
|
2613 ------------------------------
|
|
|
2614
|
|
|
2615 procedure Set_Msg_Insertion_Column is
|
|
|
2616 begin
|
|
|
2617 if RM_Column_Check then
|
|
|
2618 Set_Msg_Str (" in column ");
|
|
|
2619 Set_Msg_Int (Int (Error_Msg_Col) + 1);
|
|
|
2620 end if;
|
|
|
2621 end Set_Msg_Insertion_Column;
|
|
|
2622
|
|
|
2623 ----------------------------
|
|
|
2624 -- Set_Msg_Insertion_Node --
|
|
|
2625 ----------------------------
|
|
|
2626
|
|
|
2627 procedure Set_Msg_Insertion_Node is
|
|
|
2628 K : Node_Kind;
|
|
|
2629
|
|
|
2630 begin
|
|
|
2631 Suppress_Message :=
|
|
|
2632 Error_Msg_Node_1 = Error
|
|
|
2633 or else Error_Msg_Node_1 = Any_Type;
|
|
|
2634
|
|
|
2635 if Error_Msg_Node_1 = Empty then
|
|
|
2636 Set_Msg_Blank_Conditional;
|
|
|
2637 Set_Msg_Str ("<empty>");
|
|
|
2638
|
|
|
2639 elsif Error_Msg_Node_1 = Error then
|
|
|
2640 Set_Msg_Blank;
|
|
|
2641 Set_Msg_Str ("<error>");
|
|
|
2642
|
|
|
2643 elsif Error_Msg_Node_1 = Standard_Void_Type then
|
|
|
2644 Set_Msg_Blank;
|
|
|
2645 Set_Msg_Str ("procedure name");
|
|
|
2646
|
|
|
2647 elsif Nkind (Error_Msg_Node_1) in N_Entity
|
|
|
2648 and then Ekind (Error_Msg_Node_1) = E_Anonymous_Access_Subprogram_Type
|
|
|
2649 then
|
|
|
2650 Set_Msg_Blank;
|
|
|
2651 Set_Msg_Str ("access to subprogram");
|
|
|
2652
|
|
|
2653 else
|
|
|
2654 Set_Msg_Blank_Conditional;
|
|
|
2655
|
|
|
2656 -- Output name
|
|
|
2657
|
|
|
2658 K := Nkind (Error_Msg_Node_1);
|
|
|
2659
|
|
|
2660 -- If we have operator case, skip quotes since name of operator
|
|
|
2661 -- itself will supply the required quotations. An operator can be an
|
|
|
2662 -- applied use in an expression or an explicit operator symbol, or an
|
|
|
2663 -- identifier whose name indicates it is an operator.
|
|
|
2664
|
|
|
2665 if K in N_Op
|
|
|
2666 or else K = N_Operator_Symbol
|
|
|
2667 or else K = N_Defining_Operator_Symbol
|
|
|
2668 or else ((K = N_Identifier or else K = N_Defining_Identifier)
|
|
|
2669 and then Is_Operator_Name (Chars (Error_Msg_Node_1)))
|
|
|
2670 then
|
|
|
2671 Set_Msg_Node (Error_Msg_Node_1);
|
|
|
2672
|
|
|
2673 -- Normal case, not an operator, surround with quotes
|
|
|
2674
|
|
|
2675 else
|
|
|
2676 Set_Msg_Quote;
|
|
|
2677 Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1);
|
|
|
2678 Set_Msg_Node (Error_Msg_Node_1);
|
|
|
2679 Set_Msg_Quote;
|
|
|
2680 end if;
|
|
|
2681 end if;
|
|
|
2682
|
|
|
2683 -- The following assignment ensures that a second ampersand insertion
|
|
|
2684 -- character will correspond to the Error_Msg_Node_2 parameter. We
|
|
|
2685 -- suppress possible validity checks in case operating in -gnatVa mode,
|
|
|
2686 -- and Error_Msg_Node_2 is not needed and has not been set.
|
|
|
2687
|
|
|
2688 declare
|
|
|
2689 pragma Suppress (Range_Check);
|
|
|
2690 begin
|
|
|
2691 Error_Msg_Node_1 := Error_Msg_Node_2;
|
|
|
2692 end;
|
|
|
2693 end Set_Msg_Insertion_Node;
|
|
|
2694
|
|
|
2695 --------------------------------------
|
|
|
2696 -- Set_Msg_Insertion_Type_Reference --
|
|
|
2697 --------------------------------------
|
|
|
2698
|
|
|
2699 procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is
|
|
|
2700 Ent : Entity_Id;
|
|
|
2701
|
|
|
2702 begin
|
|
|
2703 Set_Msg_Blank;
|
|
|
2704
|
|
|
2705 if Error_Msg_Node_1 = Standard_Void_Type then
|
|
|
2706 Set_Msg_Str ("package or procedure name");
|
|
|
2707 return;
|
|
|
2708
|
|
|
2709 elsif Error_Msg_Node_1 = Standard_Exception_Type then
|
|
|
2710 Set_Msg_Str ("exception name");
|
|
|
2711 return;
|
|
|
2712
|
|
|
2713 elsif Error_Msg_Node_1 = Any_Access
|
|
|
2714 or else Error_Msg_Node_1 = Any_Array
|
|
|
2715 or else Error_Msg_Node_1 = Any_Boolean
|
|
|
2716 or else Error_Msg_Node_1 = Any_Character
|
|
|
2717 or else Error_Msg_Node_1 = Any_Composite
|
|
|
2718 or else Error_Msg_Node_1 = Any_Discrete
|
|
|
2719 or else Error_Msg_Node_1 = Any_Fixed
|
|
|
2720 or else Error_Msg_Node_1 = Any_Integer
|
|
|
2721 or else Error_Msg_Node_1 = Any_Modular
|
|
|
2722 or else Error_Msg_Node_1 = Any_Numeric
|
|
|
2723 or else Error_Msg_Node_1 = Any_Real
|
|
|
2724 or else Error_Msg_Node_1 = Any_Scalar
|
|
|
2725 or else Error_Msg_Node_1 = Any_String
|
|
|
2726 then
|
|
|
2727 Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1));
|
|
|
2728 Set_Msg_Name_Buffer;
|
|
|
2729 return;
|
|
|
2730
|
|
|
2731 elsif Error_Msg_Node_1 = Universal_Real then
|
|
|
2732 Set_Msg_Str ("type universal real");
|
|
|
2733 return;
|
|
|
2734
|
|
|
2735 elsif Error_Msg_Node_1 = Universal_Integer then
|
|
|
2736 Set_Msg_Str ("type universal integer");
|
|
|
2737 return;
|
|
|
2738
|
|
|
2739 elsif Error_Msg_Node_1 = Universal_Fixed then
|
|
|
2740 Set_Msg_Str ("type universal fixed");
|
|
|
2741 return;
|
|
|
2742 end if;
|
|
|
2743
|
|
|
2744 -- Special case of anonymous array
|
|
|
2745
|
|
|
2746 if Nkind (Error_Msg_Node_1) in N_Entity
|
|
|
2747 and then Is_Array_Type (Error_Msg_Node_1)
|
|
|
2748 and then Present (Related_Array_Object (Error_Msg_Node_1))
|
|
|
2749 then
|
|
|
2750 Set_Msg_Str ("type of ");
|
|
|
2751 Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1));
|
|
|
2752 Set_Msg_Str (" declared");
|
|
|
2753 Set_Msg_Insertion_Line_Number
|
|
|
2754 (Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag);
|
|
|
2755 return;
|
|
|
2756 end if;
|
|
|
2757
|
|
|
2758 -- If we fall through, it is not a special case, so first output
|
|
|
2759 -- the name of the type, preceded by private for a private type
|
|
|
2760
|
|
|
2761 if Is_Private_Type (Error_Msg_Node_1) then
|
|
|
2762 Set_Msg_Str ("private type ");
|
|
|
2763 else
|
|
|
2764 Set_Msg_Str ("type ");
|
|
|
2765 end if;
|
|
|
2766
|
|
|
2767 Ent := Error_Msg_Node_1;
|
|
|
2768
|
|
|
2769 if Is_Internal_Name (Chars (Ent)) then
|
|
|
2770 Unwind_Internal_Type (Ent);
|
|
|
2771 end if;
|
|
|
2772
|
|
|
2773 -- Types in Standard are displayed as "Standard.name"
|
|
|
2774
|
|
|
2775 if Sloc (Ent) <= Standard_Location then
|
|
|
2776 Set_Msg_Quote;
|
|
|
2777 Set_Msg_Str ("Standard.");
|
|
|
2778 Set_Msg_Node (Ent);
|
|
|
2779 Add_Class;
|
|
|
2780 Set_Msg_Quote;
|
|
|
2781
|
|
|
2782 -- Types in other language defined units are displayed as
|
|
|
2783 -- "package-name.type-name"
|
|
|
2784
|
|
|
2785 elsif Is_Predefined_Unit (Get_Source_Unit (Ent)) then
|
|
|
2786 Get_Unqualified_Decoded_Name_String
|
|
|
2787 (Unit_Name (Get_Source_Unit (Ent)));
|
|
|
2788 Name_Len := Name_Len - 2;
|
|
|
2789 Set_Msg_Blank_Conditional;
|
|
|
2790 Set_Msg_Quote;
|
|
|
2791 Set_Casing (Mixed_Case);
|
|
|
2792 Set_Msg_Name_Buffer;
|
|
|
2793 Set_Msg_Char ('.');
|
|
|
2794 Set_Casing (Mixed_Case);
|
|
|
2795 Set_Msg_Node (Ent);
|
|
|
2796 Add_Class;
|
|
|
2797 Set_Msg_Quote;
|
|
|
2798
|
|
|
2799 -- All other types display as "type name" defined at line xxx
|
|
|
2800 -- possibly qualified if qualification is requested.
|
|
|
2801
|
|
|
2802 else
|
|
|
2803 Set_Msg_Quote;
|
|
|
2804 Set_Qualification (Error_Msg_Qual_Level, Ent);
|
|
|
2805 Set_Msg_Node (Ent);
|
|
|
2806 Add_Class;
|
|
|
2807
|
|
|
2808 -- If we did not print a name (e.g. in the case of an anonymous
|
|
|
2809 -- subprogram type), there is no name to print, so remove quotes.
|
|
|
2810
|
|
|
2811 if Buffer_Ends_With ('"') then
|
|
|
2812 Buffer_Remove ('"');
|
|
|
2813 else
|
|
|
2814 Set_Msg_Quote;
|
|
|
2815 end if;
|
|
|
2816 end if;
|
|
|
2817
|
|
|
2818 -- If the original type did not come from a predefined file, add the
|
|
|
2819 -- location where the type was defined.
|
|
|
2820
|
|
|
2821 if Sloc (Error_Msg_Node_1) > Standard_Location
|
|
|
2822 and then
|
|
|
2823 not Is_Predefined_Unit (Get_Source_Unit (Error_Msg_Node_1))
|
|
|
2824 then
|
|
|
2825 Get_Name_String (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1)));
|
|
|
2826 Set_Msg_Str (" defined");
|
|
|
2827 Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag);
|
|
|
2828
|
|
|
2829 -- If it did come from a predefined file, deal with the case where
|
|
|
2830 -- this was a file with a generic instantiation from elsewhere.
|
|
|
2831
|
|
|
2832 else
|
|
|
2833 if Sloc (Error_Msg_Node_1) > Standard_Location then
|
|
|
2834 declare
|
|
|
2835 Iloc : constant Source_Ptr :=
|
|
|
2836 Instantiation_Location (Sloc (Error_Msg_Node_1));
|
|
|
2837
|
|
|
2838 begin
|
|
|
2839 if Iloc /= No_Location
|
|
|
2840 and then not Suppress_Instance_Location
|
|
|
2841 then
|
|
|
2842 Set_Msg_Str (" from instance");
|
|
|
2843 Set_Msg_Insertion_Line_Number (Iloc, Flag);
|
|
|
2844 end if;
|
|
|
2845 end;
|
|
|
2846 end if;
|
|
|
2847 end if;
|
|
|
2848 end Set_Msg_Insertion_Type_Reference;
|
|
|
2849
|
|
|
2850 ---------------------------------
|
|
|
2851 -- Set_Msg_Insertion_Unit_Name --
|
|
|
2852 ---------------------------------
|
|
|
2853
|
|
|
2854 procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True) is
|
|
|
2855 begin
|
|
|
2856 if Error_Msg_Unit_1 = No_Unit_Name then
|
|
|
2857 null;
|
|
|
2858
|
|
|
2859 elsif Error_Msg_Unit_1 = Error_Unit_Name then
|
|
|
2860 Set_Msg_Blank;
|
|
|
2861 Set_Msg_Str ("<error>");
|
|
|
2862
|
|
|
2863 else
|
|
|
2864 Get_Unit_Name_String (Error_Msg_Unit_1, Suffix);
|
|
|
2865 Set_Msg_Blank;
|
|
|
2866 Set_Msg_Quote;
|
|
|
2867 Set_Msg_Name_Buffer;
|
|
|
2868 Set_Msg_Quote;
|
|
|
2869 end if;
|
|
|
2870
|
|
|
2871 -- The following assignment ensures that a second percent insertion
|
|
|
2872 -- character will correspond to the Error_Msg_Unit_2 parameter. We
|
|
|
2873 -- suppress possible validity checks in case operating in -gnatVa mode,
|
|
|
2874 -- and Error_Msg_Unit_2 is not needed and has not been set.
|
|
|
2875
|
|
|
2876 declare
|
|
|
2877 pragma Suppress (Range_Check);
|
|
|
2878 begin
|
|
|
2879 Error_Msg_Unit_1 := Error_Msg_Unit_2;
|
|
|
2880 end;
|
|
|
2881 end Set_Msg_Insertion_Unit_Name;
|
|
|
2882
|
|
|
2883 ------------------
|
|
|
2884 -- Set_Msg_Node --
|
|
|
2885 ------------------
|
|
|
2886
|
|
|
2887 procedure Set_Msg_Node (Node : Node_Id) is
|
|
|
2888 Loc : Source_Ptr;
|
|
|
2889 Ent : Entity_Id;
|
|
|
2890 Nam : Name_Id;
|
|
|
2891
|
|
|
2892 begin
|
|
|
2893 case Nkind (Node) is
|
|
|
2894 when N_Designator =>
|
|
|
2895 Set_Msg_Node (Name (Node));
|
|
|
2896 Set_Msg_Char ('.');
|
|
|
2897 Set_Msg_Node (Identifier (Node));
|
|
|
2898 return;
|
|
|
2899
|
|
|
2900 when N_Defining_Program_Unit_Name =>
|
|
|
2901 Set_Msg_Node (Name (Node));
|
|
|
2902 Set_Msg_Char ('.');
|
|
|
2903 Set_Msg_Node (Defining_Identifier (Node));
|
|
|
2904 return;
|
|
|
2905
|
|
|
2906 when N_Expanded_Name
|
|
|
2907 | N_Selected_Component
|
|
|
2908 =>
|
|
|
2909 Set_Msg_Node (Prefix (Node));
|
|
|
2910 Set_Msg_Char ('.');
|
|
|
2911 Set_Msg_Node (Selector_Name (Node));
|
|
|
2912 return;
|
|
|
2913
|
|
|
2914 when others =>
|
|
|
2915 null;
|
|
|
2916 end case;
|
|
|
2917
|
|
|
2918 -- The only remaining possibilities are identifiers, defining
|
|
|
2919 -- identifiers, pragmas, and pragma argument associations.
|
|
|
2920
|
|
|
2921 if Nkind (Node) = N_Pragma then
|
|
|
2922 Nam := Pragma_Name (Node);
|
|
|
2923 Loc := Sloc (Node);
|
|
|
2924
|
|
|
2925 -- The other cases have Chars fields
|
|
|
2926
|
|
|
2927 -- First deal with internal names, which generally represent something
|
|
|
2928 -- gone wrong. First attempt: if this is a rewritten node that rewrites
|
|
|
2929 -- something with a Chars field that is not an internal name, use that.
|
|
|
2930
|
|
|
2931 elsif Is_Internal_Name (Chars (Node))
|
|
|
2932 and then Nkind (Original_Node (Node)) in N_Has_Chars
|
|
|
2933 and then not Is_Internal_Name (Chars (Original_Node (Node)))
|
|
|
2934 then
|
|
|
2935 Nam := Chars (Original_Node (Node));
|
|
|
2936 Loc := Sloc (Original_Node (Node));
|
|
|
2937
|
|
|
2938 -- Another shot for internal names, in the case of internal type names,
|
|
|
2939 -- we try to find a reasonable representation for the external name.
|
|
|
2940
|
|
|
2941 elsif Is_Internal_Name (Chars (Node))
|
|
|
2942 and then
|
|
|
2943 ((Is_Entity_Name (Node)
|
|
|
2944 and then Present (Entity (Node))
|
|
|
2945 and then Is_Type (Entity (Node)))
|
|
|
2946 or else
|
|
|
2947 (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
|
|
|
2948 then
|
|
|
2949 if Nkind (Node) = N_Identifier then
|
|
|
2950 Ent := Entity (Node);
|
|
|
2951 else
|
|
|
2952 Ent := Node;
|
|
|
2953 end if;
|
|
|
2954
|
|
|
2955 Loc := Sloc (Ent);
|
|
|
2956
|
|
|
2957 -- If the type is the designated type of an access_to_subprogram,
|
|
|
2958 -- then there is no name to provide in the call.
|
|
|
2959
|
|
|
2960 if Ekind (Ent) = E_Subprogram_Type then
|
|
|
2961 return;
|
|
|
2962
|
|
|
2963 -- Otherwise, we will be able to find some kind of name to output
|
|
|
2964
|
|
|
2965 else
|
|
|
2966 Unwind_Internal_Type (Ent);
|
|
|
2967 Nam := Chars (Ent);
|
|
|
2968 end if;
|
|
|
2969
|
|
|
2970 -- If not internal name, or if we could not find a reasonable possible
|
|
|
2971 -- substitution for the internal name, just use name in Chars field.
|
|
|
2972
|
|
|
2973 else
|
|
|
2974 Nam := Chars (Node);
|
|
|
2975 Loc := Sloc (Node);
|
|
|
2976 end if;
|
|
|
2977
|
|
|
2978 -- At this stage, the name to output is in Nam
|
|
|
2979
|
|
|
2980 Get_Unqualified_Decoded_Name_String (Nam);
|
|
|
2981
|
|
|
2982 -- Remove trailing upper case letters from the name (useful for
|
|
|
2983 -- dealing with some cases of internal names).
|
|
|
2984
|
|
|
2985 while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop
|
|
|
2986 Name_Len := Name_Len - 1;
|
|
|
2987 end loop;
|
|
|
2988
|
|
|
2989 -- If we have any of the names from standard that start with the
|
|
|
2990 -- characters "any " (e.g. Any_Type), then kill the message since
|
|
|
2991 -- almost certainly it is a junk cascaded message.
|
|
|
2992
|
|
|
2993 if Name_Len > 4
|
|
|
2994 and then Name_Buffer (1 .. 4) = "any "
|
|
|
2995 then
|
|
|
2996 Kill_Message := True;
|
|
|
2997 end if;
|
|
|
2998
|
|
|
2999 -- If we still have an internal name, kill the message (will only
|
|
|
3000 -- work if we already had errors!)
|
|
|
3001
|
|
|
3002 if Is_Internal_Name then
|
|
|
3003 Kill_Message := True;
|
|
|
3004 end if;
|
|
|
3005 -- Remaining step is to adjust casing and possibly add 'Class
|
|
|
3006
|
|
|
3007 Adjust_Name_Case (Global_Name_Buffer, Loc);
|
|
|
3008 Set_Msg_Name_Buffer;
|
|
|
3009 Add_Class;
|
|
|
3010 end Set_Msg_Node;
|
|
|
3011
|
|
|
3012 ------------------
|
|
|
3013 -- Set_Msg_Text --
|
|
|
3014 ------------------
|
|
|
3015
|
|
|
3016 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
|
|
|
3017 C : Character; -- Current character
|
|
|
3018 P : Natural; -- Current index;
|
|
|
3019
|
|
|
3020 procedure Skip_Msg_Insertion_Warning (C : Character);
|
|
|
3021 -- Deal with ? ?? ?x? ?X? ?*? ?$? insertion sequences (and the same
|
|
|
3022 -- sequences using < instead of ?). The caller has already bumped
|
|
|
3023 -- the pointer past the initial ? or < and C is set to this initial
|
|
|
3024 -- character (? or <). This procedure skips past the rest of the
|
|
|
3025 -- sequence. We do not need to set Msg_Insertion_Char, since this
|
|
|
3026 -- was already done during the message prescan.
|
|
|
3027
|
|
|
3028 --------------------------------
|
|
|
3029 -- Skip_Msg_Insertion_Warning --
|
|
|
3030 --------------------------------
|
|
|
3031
|
|
|
3032 procedure Skip_Msg_Insertion_Warning (C : Character) is
|
|
|
3033 begin
|
|
|
3034 if P <= Text'Last and then Text (P) = C then
|
|
|
3035 P := P + 1;
|
|
|
3036
|
|
|
3037 elsif P + 1 <= Text'Last
|
|
|
3038 and then (Text (P) in 'a' .. 'z'
|
|
|
3039 or else
|
|
|
3040 Text (P) in 'A' .. 'Z'
|
|
|
3041 or else
|
|
|
3042 Text (P) = '*'
|
|
|
3043 or else
|
|
|
3044 Text (P) = '$')
|
|
|
3045 and then Text (P + 1) = C
|
|
|
3046 then
|
|
|
3047 P := P + 2;
|
|
|
3048 end if;
|
|
|
3049 end Skip_Msg_Insertion_Warning;
|
|
|
3050
|
|
|
3051 -- Start of processing for Set_Msg_Text
|
|
|
3052
|
|
|
3053 begin
|
|
|
3054 Manual_Quote_Mode := False;
|
|
|
3055 Msglen := 0;
|
|
|
3056 Flag_Source := Get_Source_File_Index (Flag);
|
|
|
3057
|
|
|
3058 -- Skip info: at start, we have recorded this in Is_Info_Msg, and this
|
|
|
3059 -- will be used (Info field in error message object) to put back the
|
|
|
3060 -- string when it is printed. We need to do this, or we get confused
|
|
|
3061 -- with instantiation continuations.
|
|
|
3062
|
|
|
3063 if Text'Length > 6
|
|
|
3064 and then Text (Text'First .. Text'First + 5) = "info: "
|
|
|
3065 then
|
|
|
3066 P := Text'First + 6;
|
|
|
3067 else
|
|
|
3068 P := Text'First;
|
|
|
3069 end if;
|
|
|
3070
|
|
|
3071 -- Loop through characters of message
|
|
|
3072
|
|
|
3073 while P <= Text'Last loop
|
|
|
3074 C := Text (P);
|
|
|
3075 P := P + 1;
|
|
|
3076
|
|
|
3077 -- Check for insertion character or sequence
|
|
|
3078
|
|
|
3079 case C is
|
|
|
3080 when '%' =>
|
|
|
3081 if P <= Text'Last and then Text (P) = '%' then
|
|
|
3082 P := P + 1;
|
|
|
3083 Set_Msg_Insertion_Name_Literal;
|
|
|
3084 else
|
|
|
3085 Set_Msg_Insertion_Name;
|
|
|
3086 end if;
|
|
|
3087
|
|
|
3088 when '$' =>
|
|
|
3089 if P <= Text'Last and then Text (P) = '$' then
|
|
|
3090 P := P + 1;
|
|
|
3091 Set_Msg_Insertion_Unit_Name (Suffix => False);
|
|
|
3092 else
|
|
|
3093 Set_Msg_Insertion_Unit_Name;
|
|
|
3094 end if;
|
|
|
3095
|
|
|
3096 when '{' =>
|
|
|
3097 Set_Msg_Insertion_File_Name;
|
|
|
3098
|
|
|
3099 when '}' =>
|
|
|
3100 Set_Msg_Insertion_Type_Reference (Flag);
|
|
|
3101
|
|
|
3102 when '*' =>
|
|
|
3103 Set_Msg_Insertion_Reserved_Name;
|
|
|
3104
|
|
|
3105 when '&' =>
|
|
|
3106 Set_Msg_Insertion_Node;
|
|
|
3107
|
|
|
3108 when '#' =>
|
|
|
3109 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
|
|
|
3110
|
|
|
3111 when '\' =>
|
|
|
3112 Continuation := True;
|
|
|
3113
|
|
|
3114 if P <= Text'Last and then Text (P) = '\' then
|
|
|
3115 Continuation_New_Line := True;
|
|
|
3116 P := P + 1;
|
|
|
3117 end if;
|
|
|
3118
|
|
|
3119 when '@' =>
|
|
|
3120 Set_Msg_Insertion_Column;
|
|
|
3121
|
|
|
3122 when '>' =>
|
|
|
3123 Set_Msg_Insertion_Run_Time_Name;
|
|
|
3124
|
|
|
3125 when '^' =>
|
|
|
3126 Set_Msg_Insertion_Uint;
|
|
|
3127
|
|
|
3128 when '`' =>
|
|
|
3129 Manual_Quote_Mode := not Manual_Quote_Mode;
|
|
|
3130 Set_Msg_Char ('"');
|
|
|
3131
|
|
|
3132 when '!' =>
|
|
|
3133 null; -- already dealt with
|
|
|
3134
|
|
|
3135 when '?' =>
|
|
|
3136 Skip_Msg_Insertion_Warning ('?');
|
|
|
3137
|
|
|
3138 when '<' =>
|
|
|
3139 Skip_Msg_Insertion_Warning ('<');
|
|
|
3140
|
|
|
3141 when '|' =>
|
|
|
3142 null; -- already dealt with
|
|
|
3143
|
|
|
3144 when ''' =>
|
|
|
3145 Set_Msg_Char (Text (P));
|
|
|
3146 P := P + 1;
|
|
|
3147
|
|
|
3148 when '~' =>
|
|
|
3149 Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen));
|
|
|
3150
|
|
|
3151 -- Upper case letter
|
|
|
3152
|
|
|
3153 when 'A' .. 'Z' =>
|
|
|
3154
|
|
|
3155 -- Start of reserved word if two or more
|
|
|
3156
|
|
|
3157 if P <= Text'Last and then Text (P) in 'A' .. 'Z' then
|
|
|
3158 P := P - 1;
|
|
|
3159 Set_Msg_Insertion_Reserved_Word (Text, P);
|
|
|
3160
|
|
|
3161 -- Single upper case letter is just inserted
|
|
|
3162
|
|
|
3163 else
|
|
|
3164 Set_Msg_Char (C);
|
|
|
3165 end if;
|
|
|
3166
|
|
|
3167 -- '[' (will be/would have been raised at run time)
|
|
|
3168
|
|
|
3169 when '[' =>
|
|
|
3170
|
|
|
3171 -- Switch the message from a warning to an error if the flag
|
|
|
3172 -- -gnatwE is specified to treat run-time exception warnings
|
|
|
3173 -- as errors.
|
|
|
3174
|
|
|
3175 if Is_Warning_Msg
|
|
|
3176 and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors
|
|
|
3177 then
|
|
|
3178 Is_Warning_Msg := False;
|
|
|
3179 end if;
|
|
|
3180
|
|
|
3181 if Is_Warning_Msg then
|
|
|
3182 Set_Msg_Str ("will be raised at run time");
|
|
|
3183 else
|
|
|
3184 Set_Msg_Str ("would have been raised at run time");
|
|
|
3185 end if;
|
|
|
3186
|
|
|
3187 -- ']' (may be/might have been raised at run time)
|
|
|
3188
|
|
|
3189 when ']' =>
|
|
|
3190 if Is_Warning_Msg then
|
|
|
3191 Set_Msg_Str ("may be raised at run time");
|
|
|
3192 else
|
|
|
3193 Set_Msg_Str ("might have been raised at run time");
|
|
|
3194 end if;
|
|
|
3195
|
|
|
3196 -- Normal character with no special treatment
|
|
|
3197
|
|
|
3198 when others =>
|
|
|
3199 Set_Msg_Char (C);
|
|
|
3200 end case;
|
|
|
3201 end loop;
|
|
|
3202 end Set_Msg_Text;
|
|
|
3203
|
|
|
3204 ----------------
|
|
|
3205 -- Set_Posted --
|
|
|
3206 ----------------
|
|
|
3207
|
|
|
3208 procedure Set_Posted (N : Node_Id) is
|
|
|
3209 P : Node_Id;
|
|
|
3210
|
|
|
3211 begin
|
|
|
3212 if Is_Serious_Error then
|
|
|
3213
|
|
|
3214 -- We always set Error_Posted on the node itself
|
|
|
3215
|
|
|
3216 Set_Error_Posted (N);
|
|
|
3217
|
|
|
3218 -- If it is a subexpression, then set Error_Posted on parents up to
|
|
|
3219 -- and including the first non-subexpression construct. This helps
|
|
|
3220 -- avoid cascaded error messages within a single expression.
|
|
|
3221
|
|
|
3222 P := N;
|
|
|
3223 loop
|
|
|
3224 P := Parent (P);
|
|
|
3225 exit when No (P);
|
|
|
3226 Set_Error_Posted (P);
|
|
|
3227 exit when Nkind (P) not in N_Subexpr;
|
|
|
3228 end loop;
|
|
|
3229
|
|
|
3230 if Nkind_In (P, N_Pragma_Argument_Association,
|
|
|
3231 N_Component_Association,
|
|
|
3232 N_Discriminant_Association,
|
|
|
3233 N_Generic_Association,
|
|
|
3234 N_Parameter_Association)
|
|
|
3235 then
|
|
|
3236 Set_Error_Posted (Parent (P));
|
|
|
3237 end if;
|
|
|
3238
|
|
|
3239 -- A special check, if we just posted an error on an attribute
|
|
|
3240 -- definition clause, then also set the entity involved as posted.
|
|
|
3241 -- For example, this stops complaining about the alignment after
|
|
|
3242 -- complaining about the size, which is likely to be useless.
|
|
|
3243
|
|
|
3244 if Nkind (P) = N_Attribute_Definition_Clause then
|
|
|
3245 if Is_Entity_Name (Name (P)) then
|
|
|
3246 Set_Error_Posted (Entity (Name (P)));
|
|
|
3247 end if;
|
|
|
3248 end if;
|
|
|
3249 end if;
|
|
|
3250 end Set_Posted;
|
|
|
3251
|
|
|
3252 -----------------------
|
|
|
3253 -- Set_Qualification --
|
|
|
3254 -----------------------
|
|
|
3255
|
|
|
3256 procedure Set_Qualification (N : Nat; E : Entity_Id) is
|
|
|
3257 begin
|
|
|
3258 if N /= 0 and then Scope (E) /= Standard_Standard then
|
|
|
3259 Set_Qualification (N - 1, Scope (E));
|
|
|
3260 Set_Msg_Node (Scope (E));
|
|
|
3261 Set_Msg_Char ('.');
|
|
|
3262 end if;
|
|
|
3263 end Set_Qualification;
|
|
|
3264
|
|
|
3265 ------------------------
|
|
|
3266 -- Special_Msg_Delete --
|
|
|
3267 ------------------------
|
|
|
3268
|
|
|
3269 -- Is it really right to have all this specialized knowledge in errout?
|
|
|
3270
|
|
|
3271 function Special_Msg_Delete
|
|
|
3272 (Msg : String;
|
|
|
3273 N : Node_Or_Entity_Id;
|
|
|
3274 E : Node_Or_Entity_Id) return Boolean
|
|
|
3275 is
|
|
|
3276 begin
|
|
|
3277 -- Never delete messages in -gnatdO mode
|
|
|
3278
|
|
|
3279 if Debug_Flag_OO then
|
|
|
3280 return False;
|
|
|
3281
|
|
|
3282 -- Processing for "Size too small" messages
|
|
|
3283
|
|
145
|
3284 elsif Is_Size_Too_Small_Message (Msg) then
|
|
111
|
3285
|
|
|
3286 -- Suppress "size too small" errors in CodePeer mode, since code may
|
|
|
3287 -- be analyzed in a different configuration than the one used for
|
|
|
3288 -- compilation. Even when the configurations match, this message
|
|
|
3289 -- may be issued on correct code, because pragma Pack is ignored
|
|
|
3290 -- in CodePeer mode.
|
|
|
3291
|
|
|
3292 if CodePeer_Mode then
|
|
|
3293 return True;
|
|
|
3294
|
|
|
3295 -- When a size is wrong for a frozen type there is no explicit size
|
|
|
3296 -- clause, and other errors have occurred, suppress the message,
|
|
|
3297 -- since it is likely that this size error is a cascaded result of
|
|
|
3298 -- other errors. The reason we eliminate unfrozen types is that
|
|
|
3299 -- messages issued before the freeze type are for sure OK.
|
|
|
3300
|
|
|
3301 elsif Is_Frozen (E)
|
|
|
3302 and then Serious_Errors_Detected > 0
|
|
|
3303 and then Nkind (N) /= N_Component_Clause
|
|
|
3304 and then Nkind (Parent (N)) /= N_Component_Clause
|
|
|
3305 and then
|
|
|
3306 No (Get_Attribute_Definition_Clause (E, Attribute_Size))
|
|
|
3307 and then
|
|
|
3308 No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
|
|
|
3309 and then
|
|
|
3310 No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))
|
|
|
3311 then
|
|
|
3312 return True;
|
|
|
3313 end if;
|
|
|
3314 end if;
|
|
|
3315
|
|
|
3316 -- All special tests complete, so go ahead with message
|
|
|
3317
|
|
|
3318 return False;
|
|
|
3319 end Special_Msg_Delete;
|
|
|
3320
|
|
|
3321 -----------------
|
|
|
3322 -- SPARK_Msg_N --
|
|
|
3323 -----------------
|
|
|
3324
|
|
|
3325 procedure SPARK_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
|
|
|
3326 begin
|
|
|
3327 if SPARK_Mode /= Off then
|
|
|
3328 Error_Msg_N (Msg, N);
|
|
|
3329 end if;
|
|
|
3330 end SPARK_Msg_N;
|
|
|
3331
|
|
|
3332 ------------------
|
|
|
3333 -- SPARK_Msg_NE --
|
|
|
3334 ------------------
|
|
|
3335
|
|
|
3336 procedure SPARK_Msg_NE
|
|
|
3337 (Msg : String;
|
|
|
3338 N : Node_Or_Entity_Id;
|
|
|
3339 E : Node_Or_Entity_Id)
|
|
|
3340 is
|
|
|
3341 begin
|
|
|
3342 if SPARK_Mode /= Off then
|
|
|
3343 Error_Msg_NE (Msg, N, E);
|
|
|
3344 end if;
|
|
|
3345 end SPARK_Msg_NE;
|
|
|
3346
|
|
|
3347 --------------------------
|
|
|
3348 -- Unwind_Internal_Type --
|
|
|
3349 --------------------------
|
|
|
3350
|
|
|
3351 procedure Unwind_Internal_Type (Ent : in out Entity_Id) is
|
|
|
3352 Derived : Boolean := False;
|
|
|
3353 Mchar : Character;
|
|
|
3354 Old_Ent : Entity_Id;
|
|
|
3355
|
|
|
3356 begin
|
|
|
3357 -- Undo placement of a quote, since we will put it back later
|
|
|
3358
|
|
|
3359 Mchar := Msg_Buffer (Msglen);
|
|
|
3360
|
|
|
3361 if Mchar = '"' then
|
|
|
3362 Msglen := Msglen - 1;
|
|
|
3363 end if;
|
|
|
3364
|
|
|
3365 -- The loop here deals with recursive types, we are trying to find a
|
|
|
3366 -- related entity that is not an implicit type. Note that the check with
|
|
|
3367 -- Old_Ent stops us from getting "stuck". Also, we don't output the
|
|
|
3368 -- "type derived from" message more than once in the case where we climb
|
|
|
3369 -- up multiple levels.
|
|
|
3370
|
|
|
3371 Find : loop
|
|
|
3372 Old_Ent := Ent;
|
|
|
3373
|
|
|
3374 -- Implicit access type, use directly designated type In Ada 2005,
|
|
|
3375 -- the designated type may be an anonymous access to subprogram, in
|
|
|
3376 -- which case we can only point to its definition.
|
|
|
3377
|
|
|
3378 if Is_Access_Type (Ent) then
|
|
|
3379 if Ekind (Ent) = E_Access_Subprogram_Type
|
|
|
3380 or else Ekind (Ent) = E_Anonymous_Access_Subprogram_Type
|
|
|
3381 or else Is_Access_Protected_Subprogram_Type (Ent)
|
|
|
3382 then
|
|
|
3383 Ent := Directly_Designated_Type (Ent);
|
|
|
3384
|
|
|
3385 if not Comes_From_Source (Ent) then
|
|
|
3386 if Buffer_Ends_With ("type ") then
|
|
|
3387 Buffer_Remove ("type ");
|
|
|
3388 end if;
|
|
|
3389 end if;
|
|
|
3390
|
|
|
3391 if Ekind (Ent) = E_Function then
|
|
|
3392 Set_Msg_Str ("access to function ");
|
|
|
3393 elsif Ekind (Ent) = E_Procedure then
|
|
|
3394 Set_Msg_Str ("access to procedure ");
|
|
|
3395 else
|
|
|
3396 Set_Msg_Str ("access to subprogram");
|
|
|
3397 end if;
|
|
|
3398
|
|
|
3399 exit Find;
|
|
|
3400
|
|
|
3401 -- Type is access to object, named or anonymous
|
|
|
3402
|
|
|
3403 else
|
|
|
3404 Set_Msg_Str ("access to ");
|
|
|
3405 Ent := Directly_Designated_Type (Ent);
|
|
|
3406 end if;
|
|
|
3407
|
|
|
3408 -- Classwide type
|
|
|
3409
|
|
|
3410 elsif Is_Class_Wide_Type (Ent) then
|
|
|
3411 Class_Flag := True;
|
|
|
3412 Ent := Root_Type (Ent);
|
|
|
3413
|
|
|
3414 -- Use base type if this is a subtype
|
|
|
3415
|
|
|
3416 elsif Ent /= Base_Type (Ent) then
|
|
|
3417 Buffer_Remove ("type ");
|
|
|
3418
|
|
|
3419 -- Avoid duplication "subtype of subtype of", and also replace
|
|
|
3420 -- "derived from subtype of" simply by "derived from"
|
|
|
3421
|
|
|
3422 if not Buffer_Ends_With ("subtype of ")
|
|
|
3423 and then not Buffer_Ends_With ("derived from ")
|
|
|
3424 then
|
|
|
3425 Set_Msg_Str ("subtype of ");
|
|
|
3426 end if;
|
|
|
3427
|
|
|
3428 Ent := Base_Type (Ent);
|
|
|
3429
|
|
|
3430 -- If this is a base type with a first named subtype, use the first
|
|
|
3431 -- named subtype instead. This is not quite accurate in all cases,
|
|
|
3432 -- but it makes too much noise to be accurate and add 'Base in all
|
|
|
3433 -- cases. Note that we only do this is the first named subtype is not
|
|
|
3434 -- itself an internal name. This avoids the obvious loop (subtype ->
|
|
|
3435 -- basetype -> subtype) which would otherwise occur).
|
|
|
3436
|
|
|
3437 else
|
|
|
3438 declare
|
|
|
3439 FST : constant Entity_Id := First_Subtype (Ent);
|
|
|
3440
|
|
|
3441 begin
|
|
|
3442 if not Is_Internal_Name (Chars (FST)) then
|
|
|
3443 Ent := FST;
|
|
|
3444 exit Find;
|
|
|
3445
|
|
|
3446 -- Otherwise use root type
|
|
|
3447
|
|
|
3448 else
|
|
|
3449 if not Derived then
|
|
|
3450 Buffer_Remove ("type ");
|
|
|
3451
|
|
|
3452 -- Test for "subtype of type derived from" which seems
|
|
|
3453 -- excessive and is replaced by "type derived from".
|
|
|
3454
|
|
|
3455 Buffer_Remove ("subtype of");
|
|
|
3456
|
|
|
3457 -- Avoid duplicated "type derived from type derived from"
|
|
|
3458
|
|
|
3459 if not Buffer_Ends_With ("type derived from ") then
|
|
|
3460 Set_Msg_Str ("type derived from ");
|
|
|
3461 end if;
|
|
|
3462
|
|
|
3463 Derived := True;
|
|
|
3464 end if;
|
|
|
3465 end if;
|
|
|
3466 end;
|
|
|
3467
|
|
|
3468 Ent := Etype (Ent);
|
|
|
3469 end if;
|
|
|
3470
|
|
|
3471 -- If we are stuck in a loop, get out and settle for the internal
|
|
|
3472 -- name after all. In this case we set to kill the message if it is
|
|
|
3473 -- not the first error message (we really try hard not to show the
|
|
|
3474 -- dirty laundry of the implementation to the poor user).
|
|
|
3475
|
|
|
3476 if Ent = Old_Ent then
|
|
|
3477 Kill_Message := True;
|
|
|
3478 exit Find;
|
|
|
3479 end if;
|
|
|
3480
|
|
|
3481 -- Get out if we finally found a non-internal name to use
|
|
|
3482
|
|
|
3483 exit Find when not Is_Internal_Name (Chars (Ent));
|
|
|
3484 end loop Find;
|
|
|
3485
|
|
|
3486 if Mchar = '"' then
|
|
|
3487 Set_Msg_Char ('"');
|
|
|
3488 end if;
|
|
|
3489 end Unwind_Internal_Type;
|
|
|
3490
|
|
|
3491 --------------------
|
|
|
3492 -- Warn_Insertion --
|
|
|
3493 --------------------
|
|
|
3494
|
|
|
3495 function Warn_Insertion return String is
|
|
|
3496 begin
|
|
|
3497 case Warning_Msg_Char is
|
|
|
3498 when '?' =>
|
|
|
3499 return "??";
|
|
|
3500
|
|
|
3501 when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' =>
|
|
|
3502 return '?' & Warning_Msg_Char & '?';
|
|
|
3503
|
|
|
3504 when ' ' =>
|
|
|
3505 return "?";
|
|
|
3506
|
|
|
3507 when others =>
|
|
|
3508 raise Program_Error;
|
|
|
3509 end case;
|
|
|
3510 end Warn_Insertion;
|
|
|
3511
|
|
|
3512 end Errout;
|
