|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- E R R O U T --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, 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;
|
|
|
864 end Handle_Serious_Error;
|
|
|
865
|
|
|
866 -- Start of processing for Error_Msg_Internal
|
|
|
867
|
|
|
868 begin
|
|
|
869 if Raise_Exception_On_Error /= 0 then
|
|
|
870 raise Error_Msg_Exception;
|
|
|
871 end if;
|
|
|
872
|
|
|
873 Continuation := Msg_Cont;
|
|
|
874 Continuation_New_Line := False;
|
|
|
875 Suppress_Message := False;
|
|
|
876 Kill_Message := False;
|
|
|
877 Set_Msg_Text (Msg, Sptr);
|
|
|
878
|
|
|
879 -- Kill continuation if parent message killed
|
|
|
880
|
|
|
881 if Continuation and Last_Killed then
|
|
|
882 return;
|
|
|
883 end if;
|
|
|
884
|
|
|
885 -- Return without doing anything if message is suppressed
|
|
|
886
|
|
|
887 if Suppress_Message
|
|
|
888 and then not All_Errors_Mode
|
|
|
889 and then not Is_Warning_Msg
|
|
|
890 and then not Is_Unconditional_Msg
|
|
|
891 then
|
|
|
892 if not Continuation then
|
|
|
893 Last_Killed := True;
|
|
|
894 end if;
|
|
|
895
|
|
|
896 return;
|
|
|
897 end if;
|
|
|
898
|
|
|
899 -- Return without doing anything if message is killed and this is not
|
|
|
900 -- the first error message. The philosophy is that if we get a weird
|
|
|
901 -- error message and we already have had a message, then we hope the
|
|
|
902 -- weird message is a junk cascaded message
|
|
|
903
|
|
|
904 if Kill_Message
|
|
|
905 and then not All_Errors_Mode
|
|
|
906 and then Total_Errors_Detected /= 0
|
|
|
907 then
|
|
|
908 if not Continuation then
|
|
|
909 Last_Killed := True;
|
|
|
910 end if;
|
|
|
911
|
|
|
912 return;
|
|
|
913 end if;
|
|
|
914
|
|
|
915 -- Special check for warning message to see if it should be output
|
|
|
916
|
|
|
917 if Is_Warning_Msg then
|
|
|
918
|
|
|
919 -- Immediate return if warning message and warnings are suppressed
|
|
|
920
|
|
|
921 if Warnings_Suppressed (Optr) /= No_String
|
|
|
922 or else
|
|
|
923 Warnings_Suppressed (Sptr) /= No_String
|
|
|
924 then
|
|
|
925 Cur_Msg := No_Error_Msg;
|
|
|
926 return;
|
|
|
927 end if;
|
|
|
928
|
|
|
929 -- If the flag location is in the main extended source unit then for
|
|
|
930 -- sure we want the warning since it definitely belongs
|
|
|
931
|
|
|
932 if In_Extended_Main_Source_Unit (Sptr) then
|
|
|
933 null;
|
|
|
934
|
|
|
935 -- If the main unit has not been read yet. the warning must be on
|
|
|
936 -- a configuration file: gnat.adc or user-defined. This means we
|
|
|
937 -- are not parsing the main unit yet, so skip following checks.
|
|
|
938
|
|
|
939 elsif No (Cunit (Main_Unit)) then
|
|
|
940 null;
|
|
|
941
|
|
|
942 -- If the flag location is not in the main extended source unit, then
|
|
|
943 -- we want to eliminate the warning, unless it is in the extended
|
|
|
944 -- main code unit and we want warnings on the instance.
|
|
|
945
|
|
|
946 elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then
|
|
|
947 null;
|
|
|
948
|
|
|
949 -- Keep warning if debug flag G set
|
|
|
950
|
|
|
951 elsif Debug_Flag_GG then
|
|
|
952 null;
|
|
|
953
|
|
|
954 -- Keep warning if message text contains !!
|
|
|
955
|
|
|
956 elsif Has_Double_Exclam then
|
|
|
957 null;
|
|
|
958
|
|
|
959 -- Here is where we delete a warning from a with'ed unit
|
|
|
960
|
|
|
961 else
|
|
|
962 Cur_Msg := No_Error_Msg;
|
|
|
963
|
|
|
964 if not Continuation then
|
|
|
965 Last_Killed := True;
|
|
|
966 end if;
|
|
|
967
|
|
|
968 return;
|
|
|
969 end if;
|
|
|
970 end if;
|
|
|
971
|
|
|
972 -- If message is to be ignored in special ignore message mode, this is
|
|
|
973 -- where we do this special processing, bypassing message output.
|
|
|
974
|
|
|
975 if Ignore_Errors_Enable > 0 then
|
|
|
976 if Is_Serious_Error then
|
|
|
977 Handle_Serious_Error;
|
|
|
978 end if;
|
|
|
979
|
|
|
980 return;
|
|
|
981 end if;
|
|
|
982
|
|
|
983 -- If error message line length set, and this is a continuation message
|
|
|
984 -- then all we do is to append the text to the text of the last message
|
|
|
985 -- with a comma space separator (eliminating a possible (style) or
|
|
|
986 -- info prefix).
|
|
|
987
|
|
|
988 if Error_Msg_Line_Length /= 0 and then Continuation then
|
|
|
989 Cur_Msg := Errors.Last;
|
|
|
990
|
|
|
991 declare
|
|
|
992 Oldm : String_Ptr := Errors.Table (Cur_Msg).Text;
|
|
|
993 Newm : String (1 .. Oldm'Last + 2 + Msglen);
|
|
|
994 Newl : Natural;
|
|
|
995 M : Natural;
|
|
|
996
|
|
|
997 begin
|
|
|
998 -- First copy old message to new one and free it
|
|
|
999
|
|
|
1000 Newm (Oldm'Range) := Oldm.all;
|
|
|
1001 Newl := Oldm'Length;
|
|
|
1002 Free (Oldm);
|
|
|
1003
|
|
|
1004 -- Remove (style) or info: at start of message
|
|
|
1005
|
|
|
1006 if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then
|
|
|
1007 M := 9;
|
|
|
1008
|
|
|
1009 elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then
|
|
|
1010 M := 7;
|
|
|
1011
|
|
|
1012 else
|
|
|
1013 M := 1;
|
|
|
1014 end if;
|
|
|
1015
|
|
|
1016 -- Now deal with separation between messages. Normally this is
|
|
|
1017 -- simply comma space, but there are some special cases.
|
|
|
1018
|
|
|
1019 -- If continuation new line, then put actual NL character in msg
|
|
|
1020
|
|
|
1021 if Continuation_New_Line then
|
|
|
1022 Newl := Newl + 1;
|
|
|
1023 Newm (Newl) := ASCII.LF;
|
|
|
1024
|
|
|
1025 -- If continuation message is enclosed in parentheses, then
|
|
|
1026 -- special treatment (don't need a comma, and we want to combine
|
|
|
1027 -- successive parenthetical remarks into a single one with
|
|
|
1028 -- separating commas).
|
|
|
1029
|
|
|
1030 elsif Msg_Buffer (M) = '(' and then Msg_Buffer (Msglen) = ')' then
|
|
|
1031
|
|
|
1032 -- Case where existing message ends in right paren, remove
|
|
|
1033 -- and separate parenthetical remarks with a comma.
|
|
|
1034
|
|
|
1035 if Newm (Newl) = ')' then
|
|
|
1036 Newm (Newl) := ',';
|
|
|
1037 Msg_Buffer (M) := ' ';
|
|
|
1038
|
|
|
1039 -- Case where we are adding new parenthetical comment
|
|
|
1040
|
|
|
1041 else
|
|
|
1042 Newl := Newl + 1;
|
|
|
1043 Newm (Newl) := ' ';
|
|
|
1044 end if;
|
|
|
1045
|
|
|
1046 -- Case where continuation not in parens and no new line
|
|
|
1047
|
|
|
1048 else
|
|
|
1049 Newm (Newl + 1 .. Newl + 2) := ", ";
|
|
|
1050 Newl := Newl + 2;
|
|
|
1051 end if;
|
|
|
1052
|
|
|
1053 -- Append new message
|
|
|
1054
|
|
|
1055 Newm (Newl + 1 .. Newl + Msglen - M + 1) :=
|
|
|
1056 Msg_Buffer (M .. Msglen);
|
|
|
1057 Newl := Newl + Msglen - M + 1;
|
|
|
1058 Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl));
|
|
|
1059
|
|
|
1060 -- Update warning msg flag and message doc char if needed
|
|
|
1061
|
|
|
1062 if Is_Warning_Msg then
|
|
|
1063 if not Errors.Table (Cur_Msg).Warn then
|
|
|
1064 Errors.Table (Cur_Msg).Warn := True;
|
|
|
1065 Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
|
|
|
1066
|
|
|
1067 elsif Warning_Msg_Char /= ' ' then
|
|
|
1068 Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
|
|
|
1069 end if;
|
|
|
1070 end if;
|
|
|
1071 end;
|
|
|
1072
|
|
|
1073 return;
|
|
|
1074 end if;
|
|
|
1075
|
|
|
1076 -- Here we build a new error object
|
|
|
1077
|
|
|
1078 Errors.Append
|
|
|
1079 ((Text => new String'(Msg_Buffer (1 .. Msglen)),
|
|
|
1080 Next => No_Error_Msg,
|
|
|
1081 Prev => No_Error_Msg,
|
|
|
1082 Sptr => Sptr,
|
|
|
1083 Optr => Optr,
|
|
|
1084 Sfile => Get_Source_File_Index (Sptr),
|
|
|
1085 Line => Get_Physical_Line_Number (Sptr),
|
|
|
1086 Col => Get_Column_Number (Sptr),
|
|
|
1087 Warn => Is_Warning_Msg,
|
|
|
1088 Info => Is_Info_Msg,
|
|
|
1089 Check => Is_Check_Msg,
|
|
|
1090 Warn_Err => False, -- reset below
|
|
|
1091 Warn_Chr => Warning_Msg_Char,
|
|
|
1092 Style => Is_Style_Msg,
|
|
|
1093 Serious => Is_Serious_Error,
|
|
|
1094 Uncond => Is_Unconditional_Msg,
|
|
|
1095 Msg_Cont => Continuation,
|
|
|
1096 Deleted => False,
|
|
|
1097 Node => Node));
|
|
|
1098 Cur_Msg := Errors.Last;
|
|
|
1099
|
|
|
1100 -- Test if warning to be treated as error
|
|
|
1101
|
|
|
1102 Warn_Err :=
|
|
|
1103 Is_Warning_Msg
|
|
|
1104 and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen))
|
|
|
1105 or else
|
|
|
1106 Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg)));
|
|
|
1107
|
|
|
1108 -- Propagate Warn_Err to this message and preceding continuations
|
|
|
1109
|
|
|
1110 for J in reverse 1 .. Errors.Last loop
|
|
|
1111 Errors.Table (J).Warn_Err := Warn_Err;
|
|
|
1112 exit when not Errors.Table (J).Msg_Cont;
|
|
|
1113 end loop;
|
|
|
1114
|
|
|
1115 -- If immediate errors mode set, output error message now. Also output
|
|
|
1116 -- now if the -d1 debug flag is set (so node number message comes out
|
|
|
1117 -- just before actual error message)
|
|
|
1118
|
|
|
1119 if Debug_Flag_OO or else Debug_Flag_1 then
|
|
|
1120 Write_Eol;
|
|
|
1121 Output_Source_Line
|
|
|
1122 (Errors.Table (Cur_Msg).Line, Errors.Table (Cur_Msg).Sfile, True);
|
|
|
1123 Temp_Msg := Cur_Msg;
|
|
|
1124 Output_Error_Msgs (Temp_Msg);
|
|
|
1125
|
|
|
1126 -- If not in immediate errors mode, then we insert the message in the
|
|
|
1127 -- error chain for later output by Finalize. The messages are sorted
|
|
|
1128 -- first by unit (main unit comes first), and within a unit by source
|
|
|
1129 -- location (earlier flag location first in the chain).
|
|
|
1130
|
|
|
1131 else
|
|
|
1132 -- First a quick check, does this belong at the very end of the chain
|
|
|
1133 -- of error messages. This saves a lot of time in the normal case if
|
|
|
1134 -- there are lots of messages.
|
|
|
1135
|
|
|
1136 if Last_Error_Msg /= No_Error_Msg
|
|
|
1137 and then Errors.Table (Cur_Msg).Sfile =
|
|
|
1138 Errors.Table (Last_Error_Msg).Sfile
|
|
|
1139 and then (Sptr > Errors.Table (Last_Error_Msg).Sptr
|
|
|
1140 or else
|
|
|
1141 (Sptr = Errors.Table (Last_Error_Msg).Sptr
|
|
|
1142 and then
|
|
|
1143 Optr > Errors.Table (Last_Error_Msg).Optr))
|
|
|
1144 then
|
|
|
1145 Prev_Msg := Last_Error_Msg;
|
|
|
1146 Next_Msg := No_Error_Msg;
|
|
|
1147
|
|
|
1148 -- Otherwise do a full sequential search for the insertion point
|
|
|
1149
|
|
|
1150 else
|
|
|
1151 Prev_Msg := No_Error_Msg;
|
|
|
1152 Next_Msg := First_Error_Msg;
|
|
|
1153 while Next_Msg /= No_Error_Msg loop
|
|
|
1154 exit when
|
|
|
1155 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
|
|
|
1156
|
|
|
1157 if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile
|
|
|
1158 then
|
|
|
1159 exit when Sptr < Errors.Table (Next_Msg).Sptr
|
|
|
1160 or else (Sptr = Errors.Table (Next_Msg).Sptr
|
|
|
1161 and then Optr < Errors.Table (Next_Msg).Optr);
|
|
|
1162 end if;
|
|
|
1163
|
|
|
1164 Prev_Msg := Next_Msg;
|
|
|
1165 Next_Msg := Errors.Table (Next_Msg).Next;
|
|
|
1166 end loop;
|
|
|
1167 end if;
|
|
|
1168
|
|
|
1169 -- Now we insert the new message in the error chain.
|
|
|
1170
|
|
|
1171 -- The possible insertion point for the new message is after Prev_Msg
|
|
|
1172 -- and before Next_Msg. However, this is where we do a special check
|
|
|
1173 -- for redundant parsing messages, defined as messages posted on the
|
|
|
1174 -- same line. The idea here is that probably such messages are junk
|
|
|
1175 -- from the parser recovering. In full errors mode, we don't do this
|
|
|
1176 -- deletion, but otherwise such messages are discarded at this stage.
|
|
|
1177
|
|
|
1178 if Prev_Msg /= No_Error_Msg
|
|
|
1179 and then Errors.Table (Prev_Msg).Line =
|
|
|
1180 Errors.Table (Cur_Msg).Line
|
|
|
1181 and then Errors.Table (Prev_Msg).Sfile =
|
|
|
1182 Errors.Table (Cur_Msg).Sfile
|
|
|
1183 and then Compiler_State = Parsing
|
|
|
1184 and then not All_Errors_Mode
|
|
|
1185 then
|
|
|
1186 -- Don't delete unconditional messages and at this stage, don't
|
|
|
1187 -- delete continuation lines; we attempted to delete those earlier
|
|
|
1188 -- if the parent message was deleted.
|
|
|
1189
|
|
|
1190 if not Errors.Table (Cur_Msg).Uncond
|
|
|
1191 and then not Continuation
|
|
|
1192 then
|
|
|
1193 -- Don't delete if prev msg is warning and new msg is an error.
|
|
|
1194 -- This is because we don't want a real error masked by a
|
|
|
1195 -- warning. In all other cases (that is parse errors for the
|
|
|
1196 -- same line that are not unconditional) we do delete the
|
|
|
1197 -- message. This helps to avoid junk extra messages from
|
|
|
1198 -- cascaded parsing errors
|
|
|
1199
|
|
|
1200 if not (Errors.Table (Prev_Msg).Warn
|
|
|
1201 or else
|
|
|
1202 Errors.Table (Prev_Msg).Style)
|
|
|
1203 or else
|
|
|
1204 (Errors.Table (Cur_Msg).Warn
|
|
|
1205 or else
|
|
|
1206 Errors.Table (Cur_Msg).Style)
|
|
|
1207 then
|
|
|
1208 -- All tests passed, delete the message by simply returning
|
|
|
1209 -- without any further processing.
|
|
|
1210
|
|
|
1211 pragma Assert (not Continuation);
|
|
|
1212
|
|
|
1213 Last_Killed := True;
|
|
|
1214 return;
|
|
|
1215 end if;
|
|
|
1216 end if;
|
|
|
1217 end if;
|
|
|
1218
|
|
|
1219 -- Come here if message is to be inserted in the error chain
|
|
|
1220
|
|
|
1221 if not Continuation then
|
|
|
1222 Last_Killed := False;
|
|
|
1223 end if;
|
|
|
1224
|
|
|
1225 if Prev_Msg = No_Error_Msg then
|
|
|
1226 First_Error_Msg := Cur_Msg;
|
|
|
1227 else
|
|
|
1228 Errors.Table (Prev_Msg).Next := Cur_Msg;
|
|
|
1229 end if;
|
|
|
1230
|
|
|
1231 Errors.Table (Cur_Msg).Next := Next_Msg;
|
|
|
1232
|
|
|
1233 if Next_Msg = No_Error_Msg then
|
|
|
1234 Last_Error_Msg := Cur_Msg;
|
|
|
1235 end if;
|
|
|
1236 end if;
|
|
|
1237
|
|
|
1238 -- Bump appropriate statistics counts
|
|
|
1239
|
|
|
1240 if Errors.Table (Cur_Msg).Info then
|
|
|
1241
|
|
|
1242 -- Could be (usually is) both "info" and "warning"
|
|
|
1243
|
|
|
1244 if Errors.Table (Cur_Msg).Warn then
|
|
|
1245 Warning_Info_Messages := Warning_Info_Messages + 1;
|
|
|
1246 Warnings_Detected := Warnings_Detected + 1;
|
|
|
1247 else
|
|
|
1248 Report_Info_Messages := Report_Info_Messages + 1;
|
|
|
1249 end if;
|
|
|
1250
|
|
|
1251 elsif Errors.Table (Cur_Msg).Warn
|
|
|
1252 or else Errors.Table (Cur_Msg).Style
|
|
|
1253 then
|
|
|
1254 Warnings_Detected := Warnings_Detected + 1;
|
|
|
1255
|
|
|
1256 elsif Errors.Table (Cur_Msg).Check then
|
|
|
1257 Check_Messages := Check_Messages + 1;
|
|
|
1258
|
|
|
1259 else
|
|
|
1260 Total_Errors_Detected := Total_Errors_Detected + 1;
|
|
|
1261
|
|
|
1262 if Errors.Table (Cur_Msg).Serious then
|
|
|
1263 Serious_Errors_Detected := Serious_Errors_Detected + 1;
|
|
|
1264 Handle_Serious_Error;
|
|
|
1265
|
|
|
1266 -- If not serious error, set Fatal_Error to indicate ignored error
|
|
|
1267
|
|
|
1268 else
|
|
|
1269 declare
|
|
|
1270 U : constant Unit_Number_Type := Get_Source_Unit (Sptr);
|
|
|
1271 begin
|
|
|
1272 if Fatal_Error (U) = None then
|
|
|
1273 Set_Fatal_Error (U, Error_Ignored);
|
|
|
1274 end if;
|
|
|
1275 end;
|
|
|
1276 end if;
|
|
|
1277 end if;
|
|
|
1278
|
|
|
1279 -- Record warning message issued
|
|
|
1280
|
|
|
1281 if Errors.Table (Cur_Msg).Warn
|
|
|
1282 and then not Errors.Table (Cur_Msg).Msg_Cont
|
|
|
1283 then
|
|
|
1284 Warning_Msg := Cur_Msg;
|
|
|
1285 end if;
|
|
|
1286
|
|
|
1287 -- If too many warnings turn off warnings
|
|
|
1288
|
|
|
1289 if Maximum_Messages /= 0 then
|
|
|
1290 if Warnings_Detected = Maximum_Messages then
|
|
|
1291 Warning_Mode := Suppress;
|
|
|
1292 end if;
|
|
|
1293
|
|
|
1294 -- If too many errors abandon compilation
|
|
|
1295
|
|
|
1296 if Total_Errors_Detected = Maximum_Messages then
|
|
|
1297 raise Unrecoverable_Error;
|
|
|
1298 end if;
|
|
|
1299 end if;
|
|
|
1300 end Error_Msg_Internal;
|
|
|
1301
|
|
|
1302 -----------------
|
|
|
1303 -- Error_Msg_N --
|
|
|
1304 -----------------
|
|
|
1305
|
|
|
1306 procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
|
|
|
1307 begin
|
|
|
1308 Error_Msg_NEL (Msg, N, N, Sloc (N));
|
|
|
1309 end Error_Msg_N;
|
|
|
1310
|
|
|
1311 ------------------
|
|
|
1312 -- Error_Msg_NE --
|
|
|
1313 ------------------
|
|
|
1314
|
|
|
1315 procedure Error_Msg_NE
|
|
|
1316 (Msg : String;
|
|
|
1317 N : Node_Or_Entity_Id;
|
|
|
1318 E : Node_Or_Entity_Id)
|
|
|
1319 is
|
|
|
1320 begin
|
|
|
1321 Error_Msg_NEL (Msg, N, E, Sloc (N));
|
|
|
1322 end Error_Msg_NE;
|
|
|
1323
|
|
|
1324 -------------------
|
|
|
1325 -- Error_Msg_NEL --
|
|
|
1326 -------------------
|
|
|
1327
|
|
|
1328 procedure Error_Msg_NEL
|
|
|
1329 (Msg : String;
|
|
|
1330 N : Node_Or_Entity_Id;
|
|
|
1331 E : Node_Or_Entity_Id;
|
|
|
1332 Flag_Location : Source_Ptr)
|
|
|
1333 is
|
|
|
1334 begin
|
|
|
1335 if Special_Msg_Delete (Msg, N, E) then
|
|
|
1336 return;
|
|
|
1337 end if;
|
|
|
1338
|
|
|
1339 Prescan_Message (Msg);
|
|
|
1340
|
|
|
1341 -- Special handling for warning messages
|
|
|
1342
|
|
|
1343 if Is_Warning_Msg then
|
|
|
1344
|
|
|
1345 -- Suppress if no warnings set for either entity or node
|
|
|
1346
|
|
|
1347 if No_Warnings (N) or else No_Warnings (E) then
|
|
|
1348
|
|
|
1349 -- Disable any continuation messages as well
|
|
|
1350
|
|
|
1351 Last_Killed := True;
|
|
|
1352 return;
|
|
|
1353 end if;
|
|
|
1354
|
|
|
1355 -- Suppress if inside loop that is known to be null or is probably
|
|
|
1356 -- null (case where loop executes only if invalid values present).
|
|
|
1357 -- In either case warnings in the loop are likely to be junk.
|
|
|
1358
|
|
|
1359 declare
|
|
|
1360 P : Node_Id;
|
|
|
1361
|
|
|
1362 begin
|
|
|
1363 P := Parent (N);
|
|
|
1364 while Present (P) loop
|
|
|
1365 if Nkind (P) = N_Loop_Statement
|
|
|
1366 and then Suppress_Loop_Warnings (P)
|
|
|
1367 then
|
|
|
1368 return;
|
|
|
1369 end if;
|
|
|
1370
|
|
|
1371 P := Parent (P);
|
|
|
1372 end loop;
|
|
|
1373 end;
|
|
|
1374 end if;
|
|
|
1375
|
|
|
1376 -- Test for message to be output
|
|
|
1377
|
|
|
1378 if All_Errors_Mode
|
|
|
1379 or else Is_Unconditional_Msg
|
|
|
1380 or else Is_Warning_Msg
|
|
|
1381 or else OK_Node (N)
|
|
|
1382 or else (Msg (Msg'First) = '\' and then not Last_Killed)
|
|
|
1383 then
|
|
|
1384 Debug_Output (N);
|
|
|
1385 Error_Msg_Node_1 := E;
|
|
|
1386 Error_Msg (Msg, Flag_Location, N);
|
|
|
1387
|
|
|
1388 else
|
|
|
1389 Last_Killed := True;
|
|
|
1390 end if;
|
|
|
1391
|
|
|
1392 Set_Posted (N);
|
|
|
1393 end Error_Msg_NEL;
|
|
|
1394
|
|
|
1395 ------------------
|
|
|
1396 -- Error_Msg_NW --
|
|
|
1397 ------------------
|
|
|
1398
|
|
|
1399 procedure Error_Msg_NW
|
|
|
1400 (Eflag : Boolean;
|
|
|
1401 Msg : String;
|
|
|
1402 N : Node_Or_Entity_Id)
|
|
|
1403 is
|
|
|
1404 begin
|
|
|
1405 if Eflag
|
|
|
1406 and then In_Extended_Main_Source_Unit (N)
|
|
|
1407 and then Comes_From_Source (N)
|
|
|
1408 then
|
|
|
1409 Error_Msg_NEL (Msg, N, N, Sloc (N));
|
|
|
1410 end if;
|
|
|
1411 end Error_Msg_NW;
|
|
|
1412
|
|
|
1413 -----------------
|
|
|
1414 -- Error_Msg_S --
|
|
|
1415 -----------------
|
|
|
1416
|
|
|
1417 procedure Error_Msg_S (Msg : String) is
|
|
|
1418 begin
|
|
|
1419 Error_Msg (Msg, Scan_Ptr);
|
|
|
1420 end Error_Msg_S;
|
|
|
1421
|
|
|
1422 ------------------
|
|
|
1423 -- Error_Msg_SC --
|
|
|
1424 ------------------
|
|
|
1425
|
|
|
1426 procedure Error_Msg_SC (Msg : String) is
|
|
|
1427 begin
|
|
|
1428 -- If we are at end of file, post the flag after the previous token
|
|
|
1429
|
|
|
1430 if Token = Tok_EOF then
|
|
|
1431 Error_Msg_AP (Msg);
|
|
|
1432
|
|
|
1433 -- For all other cases the message is posted at the current token
|
|
|
1434 -- pointer position
|
|
|
1435
|
|
|
1436 else
|
|
|
1437 Error_Msg (Msg, Token_Ptr);
|
|
|
1438 end if;
|
|
|
1439 end Error_Msg_SC;
|
|
|
1440
|
|
|
1441 ------------------
|
|
|
1442 -- Error_Msg_SP --
|
|
|
1443 ------------------
|
|
|
1444
|
|
|
1445 procedure Error_Msg_SP (Msg : String) is
|
|
|
1446 begin
|
|
|
1447 -- Note: in the case where there is no previous token, Prev_Token_Ptr
|
|
|
1448 -- is set to Source_First, which is a reasonable position for the
|
|
|
1449 -- error flag in this situation
|
|
|
1450
|
|
|
1451 Error_Msg (Msg, Prev_Token_Ptr);
|
|
|
1452 end Error_Msg_SP;
|
|
|
1453
|
|
|
1454 --------------
|
|
|
1455 -- Finalize --
|
|
|
1456 --------------
|
|
|
1457
|
|
|
1458 procedure Finalize (Last_Call : Boolean) is
|
|
|
1459 Cur : Error_Msg_Id;
|
|
|
1460 Nxt : Error_Msg_Id;
|
|
|
1461 F : Error_Msg_Id;
|
|
|
1462
|
|
|
1463 procedure Delete_Warning (E : Error_Msg_Id);
|
|
|
1464 -- Delete a warning msg if not already deleted and adjust warning count
|
|
|
1465
|
|
|
1466 --------------------
|
|
|
1467 -- Delete_Warning --
|
|
|
1468 --------------------
|
|
|
1469
|
|
|
1470 procedure Delete_Warning (E : Error_Msg_Id) is
|
|
|
1471 begin
|
|
|
1472 if not Errors.Table (E).Deleted then
|
|
|
1473 Errors.Table (E).Deleted := True;
|
|
|
1474 Warnings_Detected := Warnings_Detected - 1;
|
|
|
1475
|
|
|
1476 if Errors.Table (E).Info then
|
|
|
1477 Warning_Info_Messages := Warning_Info_Messages - 1;
|
|
|
1478 end if;
|
|
|
1479 end if;
|
|
|
1480 end Delete_Warning;
|
|
|
1481
|
|
|
1482 -- Start of processing for Finalize
|
|
|
1483
|
|
|
1484 begin
|
|
|
1485 -- Set Prev pointers
|
|
|
1486
|
|
|
1487 Cur := First_Error_Msg;
|
|
|
1488 while Cur /= No_Error_Msg loop
|
|
|
1489 Nxt := Errors.Table (Cur).Next;
|
|
|
1490 exit when Nxt = No_Error_Msg;
|
|
|
1491 Errors.Table (Nxt).Prev := Cur;
|
|
|
1492 Cur := Nxt;
|
|
|
1493 end loop;
|
|
|
1494
|
|
|
1495 -- Eliminate any duplicated error messages from the list. This is
|
|
|
1496 -- done after the fact to avoid problems with Change_Error_Text.
|
|
|
1497
|
|
|
1498 Cur := First_Error_Msg;
|
|
|
1499 while Cur /= No_Error_Msg loop
|
|
|
1500 Nxt := Errors.Table (Cur).Next;
|
|
|
1501
|
|
|
1502 F := Nxt;
|
|
|
1503 while F /= No_Error_Msg
|
|
|
1504 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
|
|
|
1505 loop
|
|
|
1506 Check_Duplicate_Message (Cur, F);
|
|
|
1507 F := Errors.Table (F).Next;
|
|
|
1508 end loop;
|
|
|
1509
|
|
|
1510 Cur := Nxt;
|
|
|
1511 end loop;
|
|
|
1512
|
|
|
1513 -- Mark any messages suppressed by specific warnings as Deleted
|
|
|
1514
|
|
|
1515 Cur := First_Error_Msg;
|
|
|
1516 while Cur /= No_Error_Msg loop
|
|
|
1517 declare
|
|
|
1518 CE : Error_Msg_Object renames Errors.Table (Cur);
|
|
|
1519 Tag : constant String := Get_Warning_Tag (Cur);
|
|
|
1520
|
|
|
1521 begin
|
|
|
1522 if (CE.Warn and not CE.Deleted)
|
|
|
1523 and then
|
|
|
1524 (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /=
|
|
|
1525 No_String
|
|
|
1526 or else
|
|
|
1527 Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /=
|
|
|
1528 No_String)
|
|
|
1529 then
|
|
|
1530 Delete_Warning (Cur);
|
|
|
1531
|
|
|
1532 -- If this is a continuation, delete previous parts of message
|
|
|
1533
|
|
|
1534 F := Cur;
|
|
|
1535 while Errors.Table (F).Msg_Cont loop
|
|
|
1536 F := Errors.Table (F).Prev;
|
|
|
1537 exit when F = No_Error_Msg;
|
|
|
1538 Delete_Warning (F);
|
|
|
1539 end loop;
|
|
|
1540
|
|
|
1541 -- Delete any following continuations
|
|
|
1542
|
|
|
1543 F := Cur;
|
|
|
1544 loop
|
|
|
1545 F := Errors.Table (F).Next;
|
|
|
1546 exit when F = No_Error_Msg;
|
|
|
1547 exit when not Errors.Table (F).Msg_Cont;
|
|
|
1548 Delete_Warning (F);
|
|
|
1549 end loop;
|
|
|
1550 end if;
|
|
|
1551 end;
|
|
|
1552
|
|
|
1553 Cur := Errors.Table (Cur).Next;
|
|
|
1554 end loop;
|
|
|
1555
|
|
|
1556 Finalize_Called := True;
|
|
|
1557
|
|
|
1558 -- Check consistency of specific warnings (may add warnings). We only
|
|
|
1559 -- do this on the last call, after all possible warnings are posted.
|
|
|
1560
|
|
|
1561 if Last_Call then
|
|
|
1562 Validate_Specific_Warnings (Error_Msg'Access);
|
|
|
1563 end if;
|
|
|
1564 end Finalize;
|
|
|
1565
|
|
|
1566 ----------------
|
|
|
1567 -- First_Node --
|
|
|
1568 ----------------
|
|
|
1569
|
|
|
1570 function First_Node (C : Node_Id) return Node_Id is
|
|
|
1571 Orig : constant Node_Id := Original_Node (C);
|
|
|
1572 Loc : constant Source_Ptr := Sloc (Orig);
|
|
|
1573 Sfile : constant Source_File_Index := Get_Source_File_Index (Loc);
|
|
|
1574 Earliest : Node_Id;
|
|
|
1575 Eloc : Source_Ptr;
|
|
|
1576
|
|
|
1577 function Test_Earlier (N : Node_Id) return Traverse_Result;
|
|
|
1578 -- Function applied to every node in the construct
|
|
|
1579
|
|
|
1580 procedure Search_Tree_First is new Traverse_Proc (Test_Earlier);
|
|
|
1581 -- Create traversal procedure
|
|
|
1582
|
|
|
1583 ------------------
|
|
|
1584 -- Test_Earlier --
|
|
|
1585 ------------------
|
|
|
1586
|
|
|
1587 function Test_Earlier (N : Node_Id) return Traverse_Result is
|
|
|
1588 Norig : constant Node_Id := Original_Node (N);
|
|
|
1589 Loc : constant Source_Ptr := Sloc (Norig);
|
|
|
1590
|
|
|
1591 begin
|
|
|
1592 -- Check for earlier
|
|
|
1593
|
|
|
1594 if Loc < Eloc
|
|
|
1595
|
|
|
1596 -- Ignore nodes with no useful location information
|
|
|
1597
|
|
|
1598 and then Loc /= Standard_Location
|
|
|
1599 and then Loc /= No_Location
|
|
|
1600
|
|
|
1601 -- Ignore nodes from a different file. This ensures against cases
|
|
|
1602 -- of strange foreign code somehow being present. We don't want
|
|
|
1603 -- wild placement of messages if that happens.
|
|
|
1604
|
|
|
1605 and then Get_Source_File_Index (Loc) = Sfile
|
|
|
1606 then
|
|
|
1607 Earliest := Norig;
|
|
|
1608 Eloc := Loc;
|
|
|
1609 end if;
|
|
|
1610
|
|
|
1611 return OK_Orig;
|
|
|
1612 end Test_Earlier;
|
|
|
1613
|
|
|
1614 -- Start of processing for First_Node
|
|
|
1615
|
|
|
1616 begin
|
|
|
1617 if Nkind (Orig) in N_Subexpr then
|
|
|
1618 Earliest := Orig;
|
|
|
1619 Eloc := Loc;
|
|
|
1620 Search_Tree_First (Orig);
|
|
|
1621 return Earliest;
|
|
|
1622
|
|
|
1623 else
|
|
|
1624 return Orig;
|
|
|
1625 end if;
|
|
|
1626 end First_Node;
|
|
|
1627
|
|
|
1628 ----------------
|
|
|
1629 -- First_Sloc --
|
|
|
1630 ----------------
|
|
|
1631
|
|
|
1632 function First_Sloc (N : Node_Id) return Source_Ptr is
|
|
|
1633 SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N));
|
|
|
1634 SF : constant Source_Ptr := Source_First (SI);
|
|
|
1635 F : Node_Id;
|
|
|
1636 S : Source_Ptr;
|
|
|
1637
|
|
|
1638 begin
|
|
|
1639 F := First_Node (N);
|
|
|
1640 S := Sloc (F);
|
|
|
1641
|
|
|
1642 -- The following circuit is a bit subtle. When we have parenthesized
|
|
|
1643 -- expressions, then the Sloc will not record the location of the paren,
|
|
|
1644 -- but we would like to post the flag on the paren. So what we do is to
|
|
|
1645 -- crawl up the tree from the First_Node, adjusting the Sloc value for
|
|
|
1646 -- any parentheses we know are present. Yes, we know this circuit is not
|
|
|
1647 -- 100% reliable (e.g. because we don't record all possible paren level
|
|
|
1648 -- values), but this is only for an error message so it is good enough.
|
|
|
1649
|
|
|
1650 Node_Loop : loop
|
|
|
1651 Paren_Loop : for J in 1 .. Paren_Count (F) loop
|
|
|
1652
|
|
|
1653 -- We don't look more than 12 characters behind the current
|
|
|
1654 -- location, and in any case not past the front of the source.
|
|
|
1655
|
|
|
1656 Search_Loop : for K in 1 .. 12 loop
|
|
|
1657 exit Search_Loop when S = SF;
|
|
|
1658
|
|
|
1659 if Source_Text (SI) (S - 1) = '(' then
|
|
|
1660 S := S - 1;
|
|
|
1661 exit Search_Loop;
|
|
|
1662
|
|
|
1663 elsif Source_Text (SI) (S - 1) <= ' ' then
|
|
|
1664 S := S - 1;
|
|
|
1665
|
|
|
1666 else
|
|
|
1667 exit Search_Loop;
|
|
|
1668 end if;
|
|
|
1669 end loop Search_Loop;
|
|
|
1670 end loop Paren_Loop;
|
|
|
1671
|
|
|
1672 exit Node_Loop when F = N;
|
|
|
1673 F := Parent (F);
|
|
|
1674 exit Node_Loop when Nkind (F) not in N_Subexpr;
|
|
|
1675 end loop Node_Loop;
|
|
|
1676
|
|
|
1677 return S;
|
|
|
1678 end First_Sloc;
|
|
|
1679
|
|
|
1680 -----------------------
|
|
|
1681 -- Get_Ignore_Errors --
|
|
|
1682 -----------------------
|
|
|
1683
|
|
|
1684 function Get_Ignore_Errors return Boolean is
|
|
|
1685 begin
|
|
|
1686 return Errors_Must_Be_Ignored;
|
|
|
1687 end Get_Ignore_Errors;
|
|
|
1688
|
|
|
1689 ----------------
|
|
|
1690 -- Initialize --
|
|
|
1691 ----------------
|
|
|
1692
|
|
|
1693 procedure Initialize is
|
|
|
1694 begin
|
|
|
1695 Errors.Init;
|
|
|
1696 First_Error_Msg := No_Error_Msg;
|
|
|
1697 Last_Error_Msg := No_Error_Msg;
|
|
|
1698 Serious_Errors_Detected := 0;
|
|
|
1699 Total_Errors_Detected := 0;
|
|
|
1700 Cur_Msg := No_Error_Msg;
|
|
|
1701 List_Pragmas.Init;
|
|
|
1702
|
|
|
1703 -- Reset counts for warnings
|
|
|
1704
|
|
|
1705 Reset_Warnings;
|
|
|
1706
|
|
|
1707 -- Initialize warnings tables
|
|
|
1708
|
|
|
1709 Warnings.Init;
|
|
|
1710 Specific_Warnings.Init;
|
|
|
1711 end Initialize;
|
|
|
1712
|
|
|
1713 -----------------
|
|
|
1714 -- No_Warnings --
|
|
|
1715 -----------------
|
|
|
1716
|
|
|
1717 function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
|
|
|
1718 begin
|
|
|
1719 if Error_Posted (N) then
|
|
|
1720 return True;
|
|
|
1721
|
|
|
1722 elsif Nkind (N) in N_Entity and then Has_Warnings_Off (N) then
|
|
|
1723 return True;
|
|
|
1724
|
|
|
1725 elsif Is_Entity_Name (N)
|
|
|
1726 and then Present (Entity (N))
|
|
|
1727 and then Has_Warnings_Off (Entity (N))
|
|
|
1728 then
|
|
|
1729 return True;
|
|
|
1730
|
|
|
1731 else
|
|
|
1732 return False;
|
|
|
1733 end if;
|
|
|
1734 end No_Warnings;
|
|
|
1735
|
|
|
1736 -------------
|
|
|
1737 -- OK_Node --
|
|
|
1738 -------------
|
|
|
1739
|
|
|
1740 function OK_Node (N : Node_Id) return Boolean is
|
|
|
1741 K : constant Node_Kind := Nkind (N);
|
|
|
1742
|
|
|
1743 begin
|
|
|
1744 if Error_Posted (N) then
|
|
|
1745 return False;
|
|
|
1746
|
|
|
1747 elsif K in N_Has_Etype
|
|
|
1748 and then Present (Etype (N))
|
|
|
1749 and then Error_Posted (Etype (N))
|
|
|
1750 then
|
|
|
1751 return False;
|
|
|
1752
|
|
|
1753 elsif (K in N_Op
|
|
|
1754 or else K = N_Attribute_Reference
|
|
|
1755 or else K = N_Character_Literal
|
|
|
1756 or else K = N_Expanded_Name
|
|
|
1757 or else K = N_Identifier
|
|
|
1758 or else K = N_Operator_Symbol)
|
|
|
1759 and then Present (Entity (N))
|
|
|
1760 and then Error_Posted (Entity (N))
|
|
|
1761 then
|
|
|
1762 return False;
|
|
|
1763 else
|
|
|
1764 return True;
|
|
|
1765 end if;
|
|
|
1766 end OK_Node;
|
|
|
1767
|
|
|
1768 ---------------------
|
|
|
1769 -- Output_Messages --
|
|
|
1770 ---------------------
|
|
|
1771
|
|
|
1772 procedure Output_Messages is
|
|
|
1773 E : Error_Msg_Id;
|
|
|
1774 Err_Flag : Boolean;
|
|
|
1775
|
|
|
1776 procedure Write_Error_Summary;
|
|
|
1777 -- Write error summary
|
|
|
1778
|
|
|
1779 procedure Write_Header (Sfile : Source_File_Index);
|
|
|
1780 -- Write header line (compiling or checking given file)
|
|
|
1781
|
|
|
1782 procedure Write_Max_Errors;
|
|
|
1783 -- Write message if max errors reached
|
|
|
1784
|
|
|
1785 -------------------------
|
|
|
1786 -- Write_Error_Summary --
|
|
|
1787 -------------------------
|
|
|
1788
|
|
|
1789 procedure Write_Error_Summary is
|
|
|
1790 begin
|
|
|
1791 -- Extra blank line if error messages or source listing were output
|
|
|
1792
|
|
|
1793 if Total_Errors_Detected + Warnings_Detected > 0 or else Full_List
|
|
|
1794 then
|
|
|
1795 Write_Eol;
|
|
|
1796 end if;
|
|
|
1797
|
|
|
1798 -- Message giving number of lines read and number of errors detected.
|
|
|
1799 -- This normally goes to Standard_Output. The exception is when brief
|
|
|
1800 -- mode is not set, verbose mode (or full list mode) is set, and
|
|
|
1801 -- there are errors. In this case we send the message to standard
|
|
|
1802 -- error to make sure that *something* appears on standard error
|
|
|
1803 -- in an error situation.
|
|
|
1804
|
|
|
1805 if Total_Errors_Detected + Warnings_Detected /= 0
|
|
|
1806 and then not Brief_Output
|
|
|
1807 and then (Verbose_Mode or Full_List)
|
|
|
1808 then
|
|
|
1809 Set_Standard_Error;
|
|
|
1810 end if;
|
|
|
1811
|
|
|
1812 -- Message giving total number of lines. Don't give this message if
|
|
|
1813 -- the Main_Source line is unknown (this happens in error situations,
|
|
|
1814 -- e.g. when integrated preprocessing fails).
|
|
|
1815
|
|
|
1816 if Main_Source_File > No_Source_File then
|
|
|
1817 Write_Str (" ");
|
|
|
1818 Write_Int (Num_Source_Lines (Main_Source_File));
|
|
|
1819
|
|
|
1820 if Num_Source_Lines (Main_Source_File) = 1 then
|
|
|
1821 Write_Str (" line: ");
|
|
|
1822 else
|
|
|
1823 Write_Str (" lines: ");
|
|
|
1824 end if;
|
|
|
1825 end if;
|
|
|
1826
|
|
|
1827 if Total_Errors_Detected = 0 then
|
|
|
1828 Write_Str ("No errors");
|
|
|
1829
|
|
|
1830 elsif Total_Errors_Detected = 1 then
|
|
|
1831 Write_Str ("1 error");
|
|
|
1832
|
|
|
1833 else
|
|
|
1834 Write_Int (Total_Errors_Detected);
|
|
|
1835 Write_Str (" errors");
|
|
|
1836 end if;
|
|
|
1837
|
|
|
1838 if Warnings_Detected - Warning_Info_Messages /= 0 then
|
|
|
1839 Write_Str (", ");
|
|
|
1840 Write_Int (Warnings_Detected);
|
|
|
1841 Write_Str (" warning");
|
|
|
1842
|
|
|
1843 if Warnings_Detected - Warning_Info_Messages /= 1 then
|
|
|
1844 Write_Char ('s');
|
|
|
1845 end if;
|
|
|
1846
|
|
|
1847 if Warning_Mode = Treat_As_Error then
|
|
|
1848 Write_Str (" (treated as error");
|
|
|
1849
|
|
|
1850 if Warnings_Detected /= 1 then
|
|
|
1851 Write_Char ('s');
|
|
|
1852 end if;
|
|
|
1853
|
|
|
1854 Write_Char (')');
|
|
|
1855
|
|
|
1856 elsif Warnings_Treated_As_Errors /= 0 then
|
|
|
1857 Write_Str (" (");
|
|
|
1858 Write_Int (Warnings_Treated_As_Errors);
|
|
|
1859 Write_Str (" treated as errors)");
|
|
|
1860 end if;
|
|
|
1861 end if;
|
|
|
1862
|
|
|
1863 if Warning_Info_Messages + Report_Info_Messages /= 0 then
|
|
|
1864 Write_Str (", ");
|
|
|
1865 Write_Int (Warning_Info_Messages + Report_Info_Messages);
|
|
|
1866 Write_Str (" info message");
|
|
|
1867
|
|
|
1868 if Warning_Info_Messages + Report_Info_Messages > 1 then
|
|
|
1869 Write_Char ('s');
|
|
|
1870 end if;
|
|
|
1871 end if;
|
|
|
1872
|
|
|
1873 Write_Eol;
|
|
|
1874 Set_Standard_Output;
|
|
|
1875 end Write_Error_Summary;
|
|
|
1876
|
|
|
1877 ------------------
|
|
|
1878 -- Write_Header --
|
|
|
1879 ------------------
|
|
|
1880
|
|
|
1881 procedure Write_Header (Sfile : Source_File_Index) is
|
|
|
1882 begin
|
|
|
1883 if Verbose_Mode or Full_List then
|
|
|
1884 if Original_Operating_Mode = Generate_Code then
|
|
|
1885 Write_Str ("Compiling: ");
|
|
|
1886 else
|
|
|
1887 Write_Str ("Checking: ");
|
|
|
1888 end if;
|
|
|
1889
|
|
|
1890 Write_Name (Full_File_Name (Sfile));
|
|
|
1891
|
|
|
1892 if not Debug_Flag_7 then
|
|
|
1893 Write_Eol;
|
|
|
1894 Write_Str ("Source file time stamp: ");
|
|
|
1895 Write_Time_Stamp (Sfile);
|
|
|
1896 Write_Eol;
|
|
|
1897 Write_Str ("Compiled at: " & Compilation_Time);
|
|
|
1898 end if;
|
|
|
1899
|
|
|
1900 Write_Eol;
|
|
|
1901 end if;
|
|
|
1902 end Write_Header;
|
|
|
1903
|
|
|
1904 ----------------------
|
|
|
1905 -- Write_Max_Errors --
|
|
|
1906 ----------------------
|
|
|
1907
|
|
|
1908 procedure Write_Max_Errors is
|
|
|
1909 begin
|
|
|
1910 if Maximum_Messages /= 0 then
|
|
|
1911 if Warnings_Detected >= Maximum_Messages then
|
|
|
1912 Set_Standard_Error;
|
|
|
1913 Write_Line ("maximum number of warnings output");
|
|
|
1914 Write_Line ("any further warnings suppressed");
|
|
|
1915 Set_Standard_Output;
|
|
|
1916 end if;
|
|
|
1917
|
|
|
1918 -- If too many errors print message
|
|
|
1919
|
|
|
1920 if Total_Errors_Detected >= Maximum_Messages then
|
|
|
1921 Set_Standard_Error;
|
|
|
1922 Write_Line ("fatal error: maximum number of errors detected");
|
|
|
1923 Set_Standard_Output;
|
|
|
1924 end if;
|
|
|
1925 end if;
|
|
|
1926 end Write_Max_Errors;
|
|
|
1927
|
|
|
1928 -- Start of processing for Output_Messages
|
|
|
1929
|
|
|
1930 begin
|
|
|
1931 -- Error if Finalize has not been called
|
|
|
1932
|
|
|
1933 if not Finalize_Called then
|
|
|
1934 raise Program_Error;
|
|
|
1935 end if;
|
|
|
1936
|
|
|
1937 -- Reset current error source file if the main unit has a pragma
|
|
|
1938 -- Source_Reference. This ensures outputting the proper name of
|
|
|
1939 -- the source file in this situation.
|
|
|
1940
|
|
|
1941 if Main_Source_File <= No_Source_File
|
|
|
1942 or else Num_SRef_Pragmas (Main_Source_File) /= 0
|
|
|
1943 then
|
|
|
1944 Current_Error_Source_File := No_Source_File;
|
|
|
1945 end if;
|
|
|
1946
|
|
|
1947 -- Brief Error mode
|
|
|
1948
|
|
|
1949 if Brief_Output or (not Full_List and not Verbose_Mode) then
|
|
|
1950 Set_Standard_Error;
|
|
|
1951
|
|
|
1952 E := First_Error_Msg;
|
|
|
1953 while E /= No_Error_Msg loop
|
|
|
1954 if not Errors.Table (E).Deleted and then not Debug_Flag_KK then
|
|
|
1955 if Full_Path_Name_For_Brief_Errors then
|
|
|
1956 Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
|
|
|
1957 else
|
|
|
1958 Write_Name (Reference_Name (Errors.Table (E).Sfile));
|
|
|
1959 end if;
|
|
|
1960
|
|
|
1961 Write_Char (':');
|
|
|
1962 Write_Int (Int (Physical_To_Logical
|
|
|
1963 (Errors.Table (E).Line,
|
|
|
1964 Errors.Table (E).Sfile)));
|
|
|
1965 Write_Char (':');
|
|
|
1966
|
|
|
1967 if Errors.Table (E).Col < 10 then
|
|
|
1968 Write_Char ('0');
|
|
|
1969 end if;
|
|
|
1970
|
|
|
1971 Write_Int (Int (Errors.Table (E).Col));
|
|
|
1972 Write_Str (": ");
|
|
|
1973 Output_Msg_Text (E);
|
|
|
1974 Write_Eol;
|
|
|
1975 end if;
|
|
|
1976
|
|
|
1977 E := Errors.Table (E).Next;
|
|
|
1978 end loop;
|
|
|
1979
|
|
|
1980 Set_Standard_Output;
|
|
|
1981 end if;
|
|
|
1982
|
|
|
1983 -- Full source listing case
|
|
|
1984
|
|
|
1985 if Full_List then
|
|
|
1986 List_Pragmas_Index := 1;
|
|
|
1987 List_Pragmas_Mode := True;
|
|
|
1988 E := First_Error_Msg;
|
|
|
1989
|
|
|
1990 -- Normal case, to stdout (copyright notice already output)
|
|
|
1991
|
|
|
1992 if Full_List_File_Name = null then
|
|
|
1993 if not Debug_Flag_7 then
|
|
|
1994 Write_Eol;
|
|
|
1995 end if;
|
|
|
1996
|
|
|
1997 -- Output to file
|
|
|
1998
|
|
|
1999 else
|
|
|
2000 Create_List_File_Access.all (Full_List_File_Name.all);
|
|
|
2001 Set_Special_Output (Write_List_Info_Access.all'Access);
|
|
|
2002
|
|
|
2003 -- Write copyright notice to file
|
|
|
2004
|
|
|
2005 if not Debug_Flag_7 then
|
|
|
2006 Write_Str ("GNAT ");
|
|
|
2007 Write_Str (Gnat_Version_String);
|
|
|
2008 Write_Eol;
|
|
|
2009 Write_Str ("Copyright 1992-" &
|
|
|
2010 Current_Year &
|
|
|
2011 ", Free Software Foundation, Inc.");
|
|
|
2012 Write_Eol;
|
|
|
2013 end if;
|
|
|
2014 end if;
|
|
|
2015
|
|
|
2016 -- First list extended main source file units with errors
|
|
|
2017
|
|
|
2018 for U in Main_Unit .. Last_Unit loop
|
|
|
2019 if In_Extended_Main_Source_Unit (Cunit_Entity (U))
|
|
|
2020
|
|
|
2021 -- If debug flag d.m is set, only the main source is listed
|
|
|
2022
|
|
|
2023 and then (U = Main_Unit or else not Debug_Flag_Dot_M)
|
|
|
2024
|
|
|
2025 -- If the unit of the entity does not come from source, it is
|
|
|
2026 -- an implicit subprogram declaration for a child subprogram.
|
|
|
2027 -- Do not emit errors for it, they are listed with the body.
|
|
|
2028
|
|
|
2029 and then
|
|
|
2030 (No (Cunit_Entity (U))
|
|
|
2031 or else Comes_From_Source (Cunit_Entity (U))
|
|
|
2032 or else not Is_Subprogram (Cunit_Entity (U)))
|
|
|
2033
|
|
|
2034 -- If the compilation unit associated with this unit does not
|
|
|
2035 -- come from source, it means it is an instantiation that should
|
|
|
2036 -- not be included in the source listing.
|
|
|
2037
|
|
|
2038 and then Comes_From_Source (Cunit (U))
|
|
|
2039 then
|
|
|
2040 declare
|
|
|
2041 Sfile : constant Source_File_Index := Source_Index (U);
|
|
|
2042
|
|
|
2043 begin
|
|
|
2044 Write_Eol;
|
|
|
2045
|
|
|
2046 -- Only write the header if Sfile is known
|
|
|
2047
|
|
|
2048 if Sfile > No_Source_File then
|
|
|
2049 Write_Header (Sfile);
|
|
|
2050 Write_Eol;
|
|
|
2051 end if;
|
|
|
2052
|
|
|
2053 -- Normally, we don't want an "error messages from file"
|
|
|
2054 -- message when listing the entire file, so we set the
|
|
|
2055 -- current source file as the current error source file.
|
|
|
2056 -- However, the old style of doing things was to list this
|
|
|
2057 -- message if pragma Source_Reference is present, even for
|
|
|
2058 -- the main unit. Since the purpose of the -gnatd.m switch
|
|
|
2059 -- is to duplicate the old behavior, we skip the reset if
|
|
|
2060 -- this debug flag is set.
|
|
|
2061
|
|
|
2062 if not Debug_Flag_Dot_M then
|
|
|
2063 Current_Error_Source_File := Sfile;
|
|
|
2064 end if;
|
|
|
2065
|
|
|
2066 -- Only output the listing if Sfile is known, to avoid
|
|
|
2067 -- crashing the compiler.
|
|
|
2068
|
|
|
2069 if Sfile > No_Source_File then
|
|
|
2070 for N in 1 .. Last_Source_Line (Sfile) loop
|
|
|
2071 while E /= No_Error_Msg
|
|
|
2072 and then Errors.Table (E).Deleted
|
|
|
2073 loop
|
|
|
2074 E := Errors.Table (E).Next;
|
|
|
2075 end loop;
|
|
|
2076
|
|
|
2077 Err_Flag :=
|
|
|
2078 E /= No_Error_Msg
|
|
|
2079 and then Errors.Table (E).Line = N
|
|
|
2080 and then Errors.Table (E).Sfile = Sfile;
|
|
|
2081
|
|
|
2082 Output_Source_Line (N, Sfile, Err_Flag);
|
|
|
2083
|
|
|
2084 if Err_Flag then
|
|
|
2085 Output_Error_Msgs (E);
|
|
|
2086
|
|
|
2087 if not Debug_Flag_2 then
|
|
|
2088 Write_Eol;
|
|
|
2089 end if;
|
|
|
2090 end if;
|
|
|
2091 end loop;
|
|
|
2092 end if;
|
|
|
2093 end;
|
|
|
2094 end if;
|
|
|
2095 end loop;
|
|
|
2096
|
|
|
2097 -- Then output errors, if any, for subsidiary units not in the
|
|
|
2098 -- main extended unit.
|
|
|
2099
|
|
|
2100 -- Note: if debug flag d.m set, include errors for any units other
|
|
|
2101 -- than the main unit in the extended source unit (e.g. spec and
|
|
|
2102 -- subunits for a body).
|
|
|
2103
|
|
|
2104 while E /= No_Error_Msg
|
|
|
2105 and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr)
|
|
|
2106 or else
|
|
|
2107 (Debug_Flag_Dot_M
|
|
|
2108 and then Get_Source_Unit
|
|
|
2109 (Errors.Table (E).Sptr) /= Main_Unit))
|
|
|
2110 loop
|
|
|
2111 if Errors.Table (E).Deleted then
|
|
|
2112 E := Errors.Table (E).Next;
|
|
|
2113
|
|
|
2114 else
|
|
|
2115 Write_Eol;
|
|
|
2116 Output_Source_Line
|
|
|
2117 (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
|
|
|
2118 Output_Error_Msgs (E);
|
|
|
2119 end if;
|
|
|
2120 end loop;
|
|
|
2121
|
|
|
2122 -- If output to file, write extra copy of error summary to the
|
|
|
2123 -- output file, and then close it.
|
|
|
2124
|
|
|
2125 if Full_List_File_Name /= null then
|
|
|
2126 Write_Error_Summary;
|
|
|
2127 Write_Max_Errors;
|
|
|
2128 Close_List_File_Access.all;
|
|
|
2129 Cancel_Special_Output;
|
|
|
2130 end if;
|
|
|
2131 end if;
|
|
|
2132
|
|
|
2133 -- Verbose mode (error lines only with error flags). Normally this is
|
|
|
2134 -- ignored in full list mode, unless we are listing to a file, in which
|
|
|
2135 -- case we still generate -gnatv output to standard output.
|
|
|
2136
|
|
|
2137 if Verbose_Mode
|
|
|
2138 and then (not Full_List or else Full_List_File_Name /= null)
|
|
|
2139 then
|
|
|
2140 Write_Eol;
|
|
|
2141
|
|
|
2142 -- Output the header only when Main_Source_File is known
|
|
|
2143
|
|
|
2144 if Main_Source_File > No_Source_File then
|
|
|
2145 Write_Header (Main_Source_File);
|
|
|
2146 end if;
|
|
|
2147
|
|
|
2148 E := First_Error_Msg;
|
|
|
2149
|
|
|
2150 -- Loop through error lines
|
|
|
2151
|
|
|
2152 while E /= No_Error_Msg loop
|
|
|
2153 if Errors.Table (E).Deleted then
|
|
|
2154 E := Errors.Table (E).Next;
|
|
|
2155 else
|
|
|
2156 Write_Eol;
|
|
|
2157 Output_Source_Line
|
|
|
2158 (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
|
|
|
2159 Output_Error_Msgs (E);
|
|
|
2160 end if;
|
|
|
2161 end loop;
|
|
|
2162 end if;
|
|
|
2163
|
|
|
2164 -- Output error summary if verbose or full list mode
|
|
|
2165
|
|
|
2166 if Verbose_Mode or else Full_List then
|
|
|
2167 Write_Error_Summary;
|
|
|
2168 end if;
|
|
|
2169
|
|
|
2170 Write_Max_Errors;
|
|
|
2171
|
|
|
2172 -- Even though Warning_Info_Messages are a subclass of warnings, they
|
|
|
2173 -- must not be treated as errors when -gnatwe is in effect.
|
|
|
2174
|
|
|
2175 if Warning_Mode = Treat_As_Error then
|
|
|
2176 Total_Errors_Detected :=
|
|
|
2177 Total_Errors_Detected + Warnings_Detected - Warning_Info_Messages;
|
|
|
2178 Warnings_Detected := Warning_Info_Messages;
|
|
|
2179 end if;
|
|
|
2180 end Output_Messages;
|
|
|
2181
|
|
|
2182 ------------------------
|
|
|
2183 -- Output_Source_Line --
|
|
|
2184 ------------------------
|
|
|
2185
|
|
|
2186 procedure Output_Source_Line
|
|
|
2187 (L : Physical_Line_Number;
|
|
|
2188 Sfile : Source_File_Index;
|
|
|
2189 Errs : Boolean)
|
|
|
2190 is
|
|
|
2191 S : Source_Ptr;
|
|
|
2192 C : Character;
|
|
|
2193
|
|
|
2194 Line_Number_Output : Boolean := False;
|
|
|
2195 -- Set True once line number is output
|
|
|
2196
|
|
|
2197 Empty_Line : Boolean := True;
|
|
|
2198 -- Set False if line includes at least one character
|
|
|
2199
|
|
|
2200 begin
|
|
|
2201 if Sfile /= Current_Error_Source_File then
|
|
|
2202 Write_Str ("==============Error messages for ");
|
|
|
2203
|
|
|
2204 case Sinput.File_Type (Sfile) is
|
|
|
2205 when Sinput.Src =>
|
|
|
2206 Write_Str ("source");
|
|
|
2207
|
|
|
2208 when Sinput.Config =>
|
|
|
2209 Write_Str ("configuration pragmas");
|
|
|
2210
|
|
|
2211 when Sinput.Def =>
|
|
|
2212 Write_Str ("symbol definition");
|
|
|
2213
|
|
|
2214 when Sinput.Preproc =>
|
|
|
2215 Write_Str ("preprocessing data");
|
|
|
2216 end case;
|
|
|
2217
|
|
|
2218 Write_Str (" file: ");
|
|
|
2219 Write_Name (Full_File_Name (Sfile));
|
|
|
2220 Write_Eol;
|
|
|
2221
|
|
|
2222 if Num_SRef_Pragmas (Sfile) > 0 then
|
|
|
2223 Write_Str ("--------------Line numbers from file: ");
|
|
|
2224 Write_Name (Full_Ref_Name (Sfile));
|
|
|
2225 Write_Str (" (starting at line ");
|
|
|
2226 Write_Int (Int (First_Mapped_Line (Sfile)));
|
|
|
2227 Write_Char (')');
|
|
|
2228 Write_Eol;
|
|
|
2229 end if;
|
|
|
2230
|
|
|
2231 Current_Error_Source_File := Sfile;
|
|
|
2232 end if;
|
|
|
2233
|
|
|
2234 if Errs or List_Pragmas_Mode then
|
|
|
2235 Output_Line_Number (Physical_To_Logical (L, Sfile));
|
|
|
2236 Line_Number_Output := True;
|
|
|
2237 end if;
|
|
|
2238
|
|
|
2239 S := Line_Start (L, Sfile);
|
|
|
2240
|
|
|
2241 loop
|
|
|
2242 C := Source_Text (Sfile) (S);
|
|
|
2243 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
|
|
|
2244
|
|
|
2245 -- Deal with matching entry in List_Pragmas table
|
|
|
2246
|
|
|
2247 if Full_List
|
|
|
2248 and then List_Pragmas_Index <= List_Pragmas.Last
|
|
|
2249 and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc
|
|
|
2250 then
|
|
|
2251 case List_Pragmas.Table (List_Pragmas_Index).Ptyp is
|
|
|
2252 when Page =>
|
|
|
2253 Write_Char (C);
|
|
|
2254
|
|
|
2255 -- Ignore if on line with errors so that error flags
|
|
|
2256 -- get properly listed with the error line .
|
|
|
2257
|
|
|
2258 if not Errs then
|
|
|
2259 Write_Char (ASCII.FF);
|
|
|
2260 end if;
|
|
|
2261
|
|
|
2262 when List_On =>
|
|
|
2263 List_Pragmas_Mode := True;
|
|
|
2264
|
|
|
2265 if not Line_Number_Output then
|
|
|
2266 Output_Line_Number (Physical_To_Logical (L, Sfile));
|
|
|
2267 Line_Number_Output := True;
|
|
|
2268 end if;
|
|
|
2269
|
|
|
2270 Write_Char (C);
|
|
|
2271
|
|
|
2272 when List_Off =>
|
|
|
2273 Write_Char (C);
|
|
|
2274 List_Pragmas_Mode := False;
|
|
|
2275 end case;
|
|
|
2276
|
|
|
2277 List_Pragmas_Index := List_Pragmas_Index + 1;
|
|
|
2278
|
|
|
2279 -- Normal case (no matching entry in List_Pragmas table)
|
|
|
2280
|
|
|
2281 else
|
|
|
2282 if Errs or List_Pragmas_Mode then
|
|
|
2283 Write_Char (C);
|
|
|
2284 end if;
|
|
|
2285 end if;
|
|
|
2286
|
|
|
2287 Empty_Line := False;
|
|
|
2288 S := S + 1;
|
|
|
2289 end loop;
|
|
|
2290
|
|
|
2291 -- If we have output a source line, then add the line terminator, with
|
|
|
2292 -- training spaces preserved (so we output the line exactly as input).
|
|
|
2293
|
|
|
2294 if Line_Number_Output then
|
|
|
2295 if Empty_Line then
|
|
|
2296 Write_Eol;
|
|
|
2297 else
|
|
|
2298 Write_Eol_Keep_Blanks;
|
|
|
2299 end if;
|
|
|
2300 end if;
|
|
|
2301 end Output_Source_Line;
|
|
|
2302
|
|
|
2303 -----------------------------
|
|
|
2304 -- Remove_Warning_Messages --
|
|
|
2305 -----------------------------
|
|
|
2306
|
|
|
2307 procedure Remove_Warning_Messages (N : Node_Id) is
|
|
|
2308
|
|
|
2309 function Check_For_Warning (N : Node_Id) return Traverse_Result;
|
|
|
2310 -- This function checks one node for a possible warning message
|
|
|
2311
|
|
|
2312 function Check_All_Warnings is new Traverse_Func (Check_For_Warning);
|
|
|
2313 -- This defines the traversal operation
|
|
|
2314
|
|
|
2315 -----------------------
|
|
|
2316 -- Check_For_Warning --
|
|
|
2317 -----------------------
|
|
|
2318
|
|
|
2319 function Check_For_Warning (N : Node_Id) return Traverse_Result is
|
|
|
2320 Loc : constant Source_Ptr := Sloc (N);
|
|
|
2321 E : Error_Msg_Id;
|
|
|
2322
|
|
|
2323 function To_Be_Removed (E : Error_Msg_Id) return Boolean;
|
|
|
2324 -- Returns True for a message that is to be removed. Also adjusts
|
|
|
2325 -- warning count appropriately.
|
|
|
2326
|
|
|
2327 -------------------
|
|
|
2328 -- To_Be_Removed --
|
|
|
2329 -------------------
|
|
|
2330
|
|
|
2331 function To_Be_Removed (E : Error_Msg_Id) return Boolean is
|
|
|
2332 begin
|
|
|
2333 if E /= No_Error_Msg
|
|
|
2334
|
|
|
2335 -- Don't remove if location does not match
|
|
|
2336
|
|
|
2337 and then Errors.Table (E).Optr = Loc
|
|
|
2338
|
|
|
2339 -- Don't remove if not warning/info message. Note that we do
|
|
|
2340 -- not remove style messages here. They are warning messages
|
|
|
2341 -- but not ones we want removed in this context.
|
|
|
2342
|
|
|
2343 and then Errors.Table (E).Warn
|
|
|
2344
|
|
|
2345 -- Don't remove unconditional messages
|
|
|
2346
|
|
|
2347 and then not Errors.Table (E).Uncond
|
|
|
2348 then
|
|
|
2349 Warnings_Detected := Warnings_Detected - 1;
|
|
|
2350
|
|
|
2351 if Errors.Table (E).Info then
|
|
|
2352 Warning_Info_Messages := Warning_Info_Messages - 1;
|
|
|
2353 end if;
|
|
|
2354
|
|
|
2355 return True;
|
|
|
2356
|
|
|
2357 -- No removal required
|
|
|
2358
|
|
|
2359 else
|
|
|
2360 return False;
|
|
|
2361 end if;
|
|
|
2362 end To_Be_Removed;
|
|
|
2363
|
|
|
2364 -- Start of processing for Check_For_Warnings
|
|
|
2365
|
|
|
2366 begin
|
|
|
2367 while To_Be_Removed (First_Error_Msg) loop
|
|
|
2368 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
|
|
|
2369 end loop;
|
|
|
2370
|
|
|
2371 if First_Error_Msg = No_Error_Msg then
|
|
|
2372 Last_Error_Msg := No_Error_Msg;
|
|
|
2373 end if;
|
|
|
2374
|
|
|
2375 E := First_Error_Msg;
|
|
|
2376 while E /= No_Error_Msg loop
|
|
|
2377 while To_Be_Removed (Errors.Table (E).Next) loop
|
|
|
2378 Errors.Table (E).Next :=
|
|
|
2379 Errors.Table (Errors.Table (E).Next).Next;
|
|
|
2380
|
|
|
2381 if Errors.Table (E).Next = No_Error_Msg then
|
|
|
2382 Last_Error_Msg := E;
|
|
|
2383 end if;
|
|
|
2384 end loop;
|
|
|
2385
|
|
|
2386 E := Errors.Table (E).Next;
|
|
|
2387 end loop;
|
|
|
2388
|
|
|
2389 if Nkind (N) = N_Raise_Constraint_Error
|
|
131
|
2390 and then Is_Rewrite_Substitution (N)
|
|
111
|
2391 and then No (Condition (N))
|
|
|
2392 then
|
|
|
2393 -- Warnings may have been posted on subexpressions of the original
|
|
|
2394 -- tree. We place the original node back on the tree to remove
|
|
|
2395 -- those warnings, whose sloc do not match those of any node in
|
|
|
2396 -- the current tree. Given that we are in unreachable code, this
|
|
|
2397 -- modification to the tree is harmless.
|
|
|
2398
|
|
|
2399 declare
|
|
|
2400 Status : Traverse_Final_Result;
|
|
|
2401
|
|
|
2402 begin
|
|
|
2403 if Is_List_Member (N) then
|
|
|
2404 Set_Condition (N, Original_Node (N));
|
|
|
2405 Status := Check_All_Warnings (Condition (N));
|
|
|
2406 else
|
|
|
2407 Rewrite (N, Original_Node (N));
|
|
|
2408 Status := Check_All_Warnings (N);
|
|
|
2409 end if;
|
|
|
2410
|
|
|
2411 return Status;
|
|
|
2412 end;
|
|
|
2413
|
|
|
2414 else
|
|
|
2415 return OK;
|
|
|
2416 end if;
|
|
|
2417 end Check_For_Warning;
|
|
|
2418
|
|
|
2419 -- Start of processing for Remove_Warning_Messages
|
|
|
2420
|
|
|
2421 begin
|
|
|
2422 if Warnings_Detected /= 0 then
|
|
|
2423 declare
|
|
|
2424 Discard : Traverse_Final_Result;
|
|
|
2425 pragma Warnings (Off, Discard);
|
|
|
2426
|
|
|
2427 begin
|
|
|
2428 Discard := Check_All_Warnings (N);
|
|
|
2429 end;
|
|
|
2430 end if;
|
|
|
2431 end Remove_Warning_Messages;
|
|
|
2432
|
|
|
2433 procedure Remove_Warning_Messages (L : List_Id) is
|
|
|
2434 Stat : Node_Id;
|
|
|
2435 begin
|
|
|
2436 if Is_Non_Empty_List (L) then
|
|
|
2437 Stat := First (L);
|
|
|
2438 while Present (Stat) loop
|
|
|
2439 Remove_Warning_Messages (Stat);
|
|
|
2440 Next (Stat);
|
|
|
2441 end loop;
|
|
|
2442 end if;
|
|
|
2443 end Remove_Warning_Messages;
|
|
|
2444
|
|
|
2445 --------------------
|
|
|
2446 -- Reset_Warnings --
|
|
|
2447 --------------------
|
|
|
2448
|
|
|
2449 procedure Reset_Warnings is
|
|
|
2450 begin
|
|
|
2451 Warnings_Treated_As_Errors := 0;
|
|
|
2452 Warnings_Detected := 0;
|
|
|
2453 Warning_Info_Messages := 0;
|
|
|
2454 Warnings_As_Errors_Count := 0;
|
|
|
2455 end Reset_Warnings;
|
|
|
2456
|
|
|
2457 ----------------------
|
|
|
2458 -- Adjust_Name_Case --
|
|
|
2459 ----------------------
|
|
|
2460
|
|
|
2461 procedure Adjust_Name_Case
|
|
|
2462 (Buf : in out Bounded_String;
|
|
|
2463 Loc : Source_Ptr)
|
|
|
2464 is
|
|
|
2465 begin
|
|
|
2466 -- We have an all lower case name from Namet, and now we want to set
|
|
|
2467 -- the appropriate case. If possible we copy the actual casing from
|
|
|
2468 -- the source. If not we use standard identifier casing.
|
|
|
2469
|
|
|
2470 declare
|
|
|
2471 Src_Ind : constant Source_File_Index := Get_Source_File_Index (Loc);
|
|
|
2472 Sbuffer : Source_Buffer_Ptr;
|
|
|
2473 Ref_Ptr : Integer;
|
|
|
2474 Src_Ptr : Source_Ptr;
|
|
|
2475
|
|
|
2476 begin
|
|
|
2477 Ref_Ptr := 1;
|
|
|
2478 Src_Ptr := Loc;
|
|
|
2479
|
|
|
2480 -- For standard locations, always use mixed case
|
|
|
2481
|
|
|
2482 if Loc <= No_Location then
|
|
|
2483 Set_Casing (Mixed_Case);
|
|
|
2484
|
|
|
2485 else
|
|
|
2486 -- Determine if the reference we are dealing with corresponds to
|
|
|
2487 -- text at the point of the error reference. This will often be
|
|
|
2488 -- the case for simple identifier references, and is the case
|
|
|
2489 -- where we can copy the casing from the source.
|
|
|
2490
|
|
|
2491 Sbuffer := Source_Text (Src_Ind);
|
|
|
2492
|
|
|
2493 while Ref_Ptr <= Buf.Length loop
|
|
|
2494 exit when
|
|
|
2495 Fold_Lower (Sbuffer (Src_Ptr)) /=
|
|
|
2496 Fold_Lower (Buf.Chars (Ref_Ptr));
|
|
|
2497 Ref_Ptr := Ref_Ptr + 1;
|
|
|
2498 Src_Ptr := Src_Ptr + 1;
|
|
|
2499 end loop;
|
|
|
2500
|
|
|
2501 -- If we get through the loop without a mismatch, then output the
|
|
|
2502 -- name the way it is cased in the source program
|
|
|
2503
|
|
|
2504 if Ref_Ptr > Buf.Length then
|
|
|
2505 Src_Ptr := Loc;
|
|
|
2506
|
|
|
2507 for J in 1 .. Buf.Length loop
|
|
|
2508 Buf.Chars (J) := Sbuffer (Src_Ptr);
|
|
|
2509 Src_Ptr := Src_Ptr + 1;
|
|
|
2510 end loop;
|
|
|
2511
|
|
|
2512 -- Otherwise set the casing using the default identifier casing
|
|
|
2513
|
|
|
2514 else
|
|
|
2515 Set_Casing (Buf, Identifier_Casing (Src_Ind));
|
|
|
2516 end if;
|
|
|
2517 end if;
|
|
|
2518 end;
|
|
|
2519 end Adjust_Name_Case;
|
|
|
2520
|
|
|
2521 procedure Adjust_Name_Case (Loc : Source_Ptr) is
|
|
|
2522 begin
|
|
|
2523 Adjust_Name_Case (Global_Name_Buffer, Loc);
|
|
|
2524 end Adjust_Name_Case;
|
|
|
2525
|
|
|
2526 ---------------------------
|
|
|
2527 -- Set_Identifier_Casing --
|
|
|
2528 ---------------------------
|
|
|
2529
|
|
|
2530 procedure Set_Identifier_Casing
|
|
|
2531 (Identifier_Name : System.Address;
|
|
|
2532 File_Name : System.Address)
|
|
|
2533 is
|
|
|
2534 Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name);
|
|
|
2535 File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name);
|
|
|
2536 Flen : Natural;
|
|
|
2537
|
|
|
2538 Desired_Case : Casing_Type := Mixed_Case;
|
|
|
2539 -- Casing required for result. Default value of Mixed_Case is used if
|
|
|
2540 -- for some reason we cannot find the right file name in the table.
|
|
|
2541
|
|
|
2542 begin
|
|
|
2543 -- Get length of file name
|
|
|
2544
|
|
|
2545 Flen := 0;
|
|
|
2546 while File (Flen + 1) /= ASCII.NUL loop
|
|
|
2547 Flen := Flen + 1;
|
|
|
2548 end loop;
|
|
|
2549
|
|
|
2550 -- Loop through file names to find matching one. This is a bit slow, but
|
|
|
2551 -- we only do it in error situations so it is not so terrible. Note that
|
|
|
2552 -- if the loop does not exit, then the desired case will be left set to
|
|
|
2553 -- Mixed_Case, this can happen if the name was not in canonical form.
|
|
|
2554
|
|
|
2555 for J in 1 .. Last_Source_File loop
|
|
|
2556 Get_Name_String (Full_Debug_Name (J));
|
|
|
2557
|
|
|
2558 if Name_Len = Flen
|
|
|
2559 and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen))
|
|
|
2560 then
|
|
|
2561 Desired_Case := Identifier_Casing (J);
|
|
|
2562 exit;
|
|
|
2563 end if;
|
|
|
2564 end loop;
|
|
|
2565
|
|
|
2566 -- Copy identifier as given to Name_Buffer
|
|
|
2567
|
|
|
2568 for J in Name_Buffer'Range loop
|
|
|
2569 Name_Buffer (J) := Ident (J);
|
|
|
2570
|
|
|
2571 if Name_Buffer (J) = ASCII.NUL then
|
|
|
2572 Name_Len := J - 1;
|
|
|
2573 exit;
|
|
|
2574 end if;
|
|
|
2575 end loop;
|
|
|
2576
|
|
|
2577 Set_Casing (Desired_Case);
|
|
|
2578 end Set_Identifier_Casing;
|
|
|
2579
|
|
|
2580 -----------------------
|
|
|
2581 -- Set_Ignore_Errors --
|
|
|
2582 -----------------------
|
|
|
2583
|
|
|
2584 procedure Set_Ignore_Errors (To : Boolean) is
|
|
|
2585 begin
|
|
|
2586 Errors_Must_Be_Ignored := To;
|
|
|
2587 end Set_Ignore_Errors;
|
|
|
2588
|
|
|
2589 ------------------------------
|
|
|
2590 -- Set_Msg_Insertion_Column --
|
|
|
2591 ------------------------------
|
|
|
2592
|
|
|
2593 procedure Set_Msg_Insertion_Column is
|
|
|
2594 begin
|
|
|
2595 if RM_Column_Check then
|
|
|
2596 Set_Msg_Str (" in column ");
|
|
|
2597 Set_Msg_Int (Int (Error_Msg_Col) + 1);
|
|
|
2598 end if;
|
|
|
2599 end Set_Msg_Insertion_Column;
|
|
|
2600
|
|
|
2601 ----------------------------
|
|
|
2602 -- Set_Msg_Insertion_Node --
|
|
|
2603 ----------------------------
|
|
|
2604
|
|
|
2605 procedure Set_Msg_Insertion_Node is
|
|
|
2606 K : Node_Kind;
|
|
|
2607
|
|
|
2608 begin
|
|
|
2609 Suppress_Message :=
|
|
|
2610 Error_Msg_Node_1 = Error
|
|
|
2611 or else Error_Msg_Node_1 = Any_Type;
|
|
|
2612
|
|
|
2613 if Error_Msg_Node_1 = Empty then
|
|
|
2614 Set_Msg_Blank_Conditional;
|
|
|
2615 Set_Msg_Str ("<empty>");
|
|
|
2616
|
|
|
2617 elsif Error_Msg_Node_1 = Error then
|
|
|
2618 Set_Msg_Blank;
|
|
|
2619 Set_Msg_Str ("<error>");
|
|
|
2620
|
|
|
2621 elsif Error_Msg_Node_1 = Standard_Void_Type then
|
|
|
2622 Set_Msg_Blank;
|
|
|
2623 Set_Msg_Str ("procedure name");
|
|
|
2624
|
|
|
2625 elsif Nkind (Error_Msg_Node_1) in N_Entity
|
|
|
2626 and then Ekind (Error_Msg_Node_1) = E_Anonymous_Access_Subprogram_Type
|
|
|
2627 then
|
|
|
2628 Set_Msg_Blank;
|
|
|
2629 Set_Msg_Str ("access to subprogram");
|
|
|
2630
|
|
|
2631 else
|
|
|
2632 Set_Msg_Blank_Conditional;
|
|
|
2633
|
|
|
2634 -- Output name
|
|
|
2635
|
|
|
2636 K := Nkind (Error_Msg_Node_1);
|
|
|
2637
|
|
|
2638 -- If we have operator case, skip quotes since name of operator
|
|
|
2639 -- itself will supply the required quotations. An operator can be an
|
|
|
2640 -- applied use in an expression or an explicit operator symbol, or an
|
|
|
2641 -- identifier whose name indicates it is an operator.
|
|
|
2642
|
|
|
2643 if K in N_Op
|
|
|
2644 or else K = N_Operator_Symbol
|
|
|
2645 or else K = N_Defining_Operator_Symbol
|
|
|
2646 or else ((K = N_Identifier or else K = N_Defining_Identifier)
|
|
|
2647 and then Is_Operator_Name (Chars (Error_Msg_Node_1)))
|
|
|
2648 then
|
|
|
2649 Set_Msg_Node (Error_Msg_Node_1);
|
|
|
2650
|
|
|
2651 -- Normal case, not an operator, surround with quotes
|
|
|
2652
|
|
|
2653 else
|
|
|
2654 Set_Msg_Quote;
|
|
|
2655 Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1);
|
|
|
2656 Set_Msg_Node (Error_Msg_Node_1);
|
|
|
2657 Set_Msg_Quote;
|
|
|
2658 end if;
|
|
|
2659 end if;
|
|
|
2660
|
|
|
2661 -- The following assignment ensures that a second ampersand insertion
|
|
|
2662 -- character will correspond to the Error_Msg_Node_2 parameter. We
|
|
|
2663 -- suppress possible validity checks in case operating in -gnatVa mode,
|
|
|
2664 -- and Error_Msg_Node_2 is not needed and has not been set.
|
|
|
2665
|
|
|
2666 declare
|
|
|
2667 pragma Suppress (Range_Check);
|
|
|
2668 begin
|
|
|
2669 Error_Msg_Node_1 := Error_Msg_Node_2;
|
|
|
2670 end;
|
|
|
2671 end Set_Msg_Insertion_Node;
|
|
|
2672
|
|
|
2673 --------------------------------------
|
|
|
2674 -- Set_Msg_Insertion_Type_Reference --
|
|
|
2675 --------------------------------------
|
|
|
2676
|
|
|
2677 procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is
|
|
|
2678 Ent : Entity_Id;
|
|
|
2679
|
|
|
2680 begin
|
|
|
2681 Set_Msg_Blank;
|
|
|
2682
|
|
|
2683 if Error_Msg_Node_1 = Standard_Void_Type then
|
|
|
2684 Set_Msg_Str ("package or procedure name");
|
|
|
2685 return;
|
|
|
2686
|
|
|
2687 elsif Error_Msg_Node_1 = Standard_Exception_Type then
|
|
|
2688 Set_Msg_Str ("exception name");
|
|
|
2689 return;
|
|
|
2690
|
|
|
2691 elsif Error_Msg_Node_1 = Any_Access
|
|
|
2692 or else Error_Msg_Node_1 = Any_Array
|
|
|
2693 or else Error_Msg_Node_1 = Any_Boolean
|
|
|
2694 or else Error_Msg_Node_1 = Any_Character
|
|
|
2695 or else Error_Msg_Node_1 = Any_Composite
|
|
|
2696 or else Error_Msg_Node_1 = Any_Discrete
|
|
|
2697 or else Error_Msg_Node_1 = Any_Fixed
|
|
|
2698 or else Error_Msg_Node_1 = Any_Integer
|
|
|
2699 or else Error_Msg_Node_1 = Any_Modular
|
|
|
2700 or else Error_Msg_Node_1 = Any_Numeric
|
|
|
2701 or else Error_Msg_Node_1 = Any_Real
|
|
|
2702 or else Error_Msg_Node_1 = Any_Scalar
|
|
|
2703 or else Error_Msg_Node_1 = Any_String
|
|
|
2704 then
|
|
|
2705 Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1));
|
|
|
2706 Set_Msg_Name_Buffer;
|
|
|
2707 return;
|
|
|
2708
|
|
|
2709 elsif Error_Msg_Node_1 = Universal_Real then
|
|
|
2710 Set_Msg_Str ("type universal real");
|
|
|
2711 return;
|
|
|
2712
|
|
|
2713 elsif Error_Msg_Node_1 = Universal_Integer then
|
|
|
2714 Set_Msg_Str ("type universal integer");
|
|
|
2715 return;
|
|
|
2716
|
|
|
2717 elsif Error_Msg_Node_1 = Universal_Fixed then
|
|
|
2718 Set_Msg_Str ("type universal fixed");
|
|
|
2719 return;
|
|
|
2720 end if;
|
|
|
2721
|
|
|
2722 -- Special case of anonymous array
|
|
|
2723
|
|
|
2724 if Nkind (Error_Msg_Node_1) in N_Entity
|
|
|
2725 and then Is_Array_Type (Error_Msg_Node_1)
|
|
|
2726 and then Present (Related_Array_Object (Error_Msg_Node_1))
|
|
|
2727 then
|
|
|
2728 Set_Msg_Str ("type of ");
|
|
|
2729 Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1));
|
|
|
2730 Set_Msg_Str (" declared");
|
|
|
2731 Set_Msg_Insertion_Line_Number
|
|
|
2732 (Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag);
|
|
|
2733 return;
|
|
|
2734 end if;
|
|
|
2735
|
|
|
2736 -- If we fall through, it is not a special case, so first output
|
|
|
2737 -- the name of the type, preceded by private for a private type
|
|
|
2738
|
|
|
2739 if Is_Private_Type (Error_Msg_Node_1) then
|
|
|
2740 Set_Msg_Str ("private type ");
|
|
|
2741 else
|
|
|
2742 Set_Msg_Str ("type ");
|
|
|
2743 end if;
|
|
|
2744
|
|
|
2745 Ent := Error_Msg_Node_1;
|
|
|
2746
|
|
|
2747 if Is_Internal_Name (Chars (Ent)) then
|
|
|
2748 Unwind_Internal_Type (Ent);
|
|
|
2749 end if;
|
|
|
2750
|
|
|
2751 -- Types in Standard are displayed as "Standard.name"
|
|
|
2752
|
|
|
2753 if Sloc (Ent) <= Standard_Location then
|
|
|
2754 Set_Msg_Quote;
|
|
|
2755 Set_Msg_Str ("Standard.");
|
|
|
2756 Set_Msg_Node (Ent);
|
|
|
2757 Add_Class;
|
|
|
2758 Set_Msg_Quote;
|
|
|
2759
|
|
|
2760 -- Types in other language defined units are displayed as
|
|
|
2761 -- "package-name.type-name"
|
|
|
2762
|
|
|
2763 elsif Is_Predefined_Unit (Get_Source_Unit (Ent)) then
|
|
|
2764 Get_Unqualified_Decoded_Name_String
|
|
|
2765 (Unit_Name (Get_Source_Unit (Ent)));
|
|
|
2766 Name_Len := Name_Len - 2;
|
|
|
2767 Set_Msg_Blank_Conditional;
|
|
|
2768 Set_Msg_Quote;
|
|
|
2769 Set_Casing (Mixed_Case);
|
|
|
2770 Set_Msg_Name_Buffer;
|
|
|
2771 Set_Msg_Char ('.');
|
|
|
2772 Set_Casing (Mixed_Case);
|
|
|
2773 Set_Msg_Node (Ent);
|
|
|
2774 Add_Class;
|
|
|
2775 Set_Msg_Quote;
|
|
|
2776
|
|
|
2777 -- All other types display as "type name" defined at line xxx
|
|
|
2778 -- possibly qualified if qualification is requested.
|
|
|
2779
|
|
|
2780 else
|
|
|
2781 Set_Msg_Quote;
|
|
|
2782 Set_Qualification (Error_Msg_Qual_Level, Ent);
|
|
|
2783 Set_Msg_Node (Ent);
|
|
|
2784 Add_Class;
|
|
|
2785
|
|
|
2786 -- If we did not print a name (e.g. in the case of an anonymous
|
|
|
2787 -- subprogram type), there is no name to print, so remove quotes.
|
|
|
2788
|
|
|
2789 if Buffer_Ends_With ('"') then
|
|
|
2790 Buffer_Remove ('"');
|
|
|
2791 else
|
|
|
2792 Set_Msg_Quote;
|
|
|
2793 end if;
|
|
|
2794 end if;
|
|
|
2795
|
|
|
2796 -- If the original type did not come from a predefined file, add the
|
|
|
2797 -- location where the type was defined.
|
|
|
2798
|
|
|
2799 if Sloc (Error_Msg_Node_1) > Standard_Location
|
|
|
2800 and then
|
|
|
2801 not Is_Predefined_Unit (Get_Source_Unit (Error_Msg_Node_1))
|
|
|
2802 then
|
|
|
2803 Get_Name_String (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1)));
|
|
|
2804 Set_Msg_Str (" defined");
|
|
|
2805 Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag);
|
|
|
2806
|
|
|
2807 -- If it did come from a predefined file, deal with the case where
|
|
|
2808 -- this was a file with a generic instantiation from elsewhere.
|
|
|
2809
|
|
|
2810 else
|
|
|
2811 if Sloc (Error_Msg_Node_1) > Standard_Location then
|
|
|
2812 declare
|
|
|
2813 Iloc : constant Source_Ptr :=
|
|
|
2814 Instantiation_Location (Sloc (Error_Msg_Node_1));
|
|
|
2815
|
|
|
2816 begin
|
|
|
2817 if Iloc /= No_Location
|
|
|
2818 and then not Suppress_Instance_Location
|
|
|
2819 then
|
|
|
2820 Set_Msg_Str (" from instance");
|
|
|
2821 Set_Msg_Insertion_Line_Number (Iloc, Flag);
|
|
|
2822 end if;
|
|
|
2823 end;
|
|
|
2824 end if;
|
|
|
2825 end if;
|
|
|
2826 end Set_Msg_Insertion_Type_Reference;
|
|
|
2827
|
|
|
2828 ---------------------------------
|
|
|
2829 -- Set_Msg_Insertion_Unit_Name --
|
|
|
2830 ---------------------------------
|
|
|
2831
|
|
|
2832 procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True) is
|
|
|
2833 begin
|
|
|
2834 if Error_Msg_Unit_1 = No_Unit_Name then
|
|
|
2835 null;
|
|
|
2836
|
|
|
2837 elsif Error_Msg_Unit_1 = Error_Unit_Name then
|
|
|
2838 Set_Msg_Blank;
|
|
|
2839 Set_Msg_Str ("<error>");
|
|
|
2840
|
|
|
2841 else
|
|
|
2842 Get_Unit_Name_String (Error_Msg_Unit_1, Suffix);
|
|
|
2843 Set_Msg_Blank;
|
|
|
2844 Set_Msg_Quote;
|
|
|
2845 Set_Msg_Name_Buffer;
|
|
|
2846 Set_Msg_Quote;
|
|
|
2847 end if;
|
|
|
2848
|
|
|
2849 -- The following assignment ensures that a second percent insertion
|
|
|
2850 -- character will correspond to the Error_Msg_Unit_2 parameter. We
|
|
|
2851 -- suppress possible validity checks in case operating in -gnatVa mode,
|
|
|
2852 -- and Error_Msg_Unit_2 is not needed and has not been set.
|
|
|
2853
|
|
|
2854 declare
|
|
|
2855 pragma Suppress (Range_Check);
|
|
|
2856 begin
|
|
|
2857 Error_Msg_Unit_1 := Error_Msg_Unit_2;
|
|
|
2858 end;
|
|
|
2859 end Set_Msg_Insertion_Unit_Name;
|
|
|
2860
|
|
|
2861 ------------------
|
|
|
2862 -- Set_Msg_Node --
|
|
|
2863 ------------------
|
|
|
2864
|
|
|
2865 procedure Set_Msg_Node (Node : Node_Id) is
|
|
|
2866 Loc : Source_Ptr;
|
|
|
2867 Ent : Entity_Id;
|
|
|
2868 Nam : Name_Id;
|
|
|
2869
|
|
|
2870 begin
|
|
|
2871 case Nkind (Node) is
|
|
|
2872 when N_Designator =>
|
|
|
2873 Set_Msg_Node (Name (Node));
|
|
|
2874 Set_Msg_Char ('.');
|
|
|
2875 Set_Msg_Node (Identifier (Node));
|
|
|
2876 return;
|
|
|
2877
|
|
|
2878 when N_Defining_Program_Unit_Name =>
|
|
|
2879 Set_Msg_Node (Name (Node));
|
|
|
2880 Set_Msg_Char ('.');
|
|
|
2881 Set_Msg_Node (Defining_Identifier (Node));
|
|
|
2882 return;
|
|
|
2883
|
|
|
2884 when N_Expanded_Name
|
|
|
2885 | N_Selected_Component
|
|
|
2886 =>
|
|
|
2887 Set_Msg_Node (Prefix (Node));
|
|
|
2888 Set_Msg_Char ('.');
|
|
|
2889 Set_Msg_Node (Selector_Name (Node));
|
|
|
2890 return;
|
|
|
2891
|
|
|
2892 when others =>
|
|
|
2893 null;
|
|
|
2894 end case;
|
|
|
2895
|
|
|
2896 -- The only remaining possibilities are identifiers, defining
|
|
|
2897 -- identifiers, pragmas, and pragma argument associations.
|
|
|
2898
|
|
|
2899 if Nkind (Node) = N_Pragma then
|
|
|
2900 Nam := Pragma_Name (Node);
|
|
|
2901 Loc := Sloc (Node);
|
|
|
2902
|
|
|
2903 -- The other cases have Chars fields
|
|
|
2904
|
|
|
2905 -- First deal with internal names, which generally represent something
|
|
|
2906 -- gone wrong. First attempt: if this is a rewritten node that rewrites
|
|
|
2907 -- something with a Chars field that is not an internal name, use that.
|
|
|
2908
|
|
|
2909 elsif Is_Internal_Name (Chars (Node))
|
|
|
2910 and then Nkind (Original_Node (Node)) in N_Has_Chars
|
|
|
2911 and then not Is_Internal_Name (Chars (Original_Node (Node)))
|
|
|
2912 then
|
|
|
2913 Nam := Chars (Original_Node (Node));
|
|
|
2914 Loc := Sloc (Original_Node (Node));
|
|
|
2915
|
|
|
2916 -- Another shot for internal names, in the case of internal type names,
|
|
|
2917 -- we try to find a reasonable representation for the external name.
|
|
|
2918
|
|
|
2919 elsif Is_Internal_Name (Chars (Node))
|
|
|
2920 and then
|
|
|
2921 ((Is_Entity_Name (Node)
|
|
|
2922 and then Present (Entity (Node))
|
|
|
2923 and then Is_Type (Entity (Node)))
|
|
|
2924 or else
|
|
|
2925 (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
|
|
|
2926 then
|
|
|
2927 if Nkind (Node) = N_Identifier then
|
|
|
2928 Ent := Entity (Node);
|
|
|
2929 else
|
|
|
2930 Ent := Node;
|
|
|
2931 end if;
|
|
|
2932
|
|
|
2933 Loc := Sloc (Ent);
|
|
|
2934
|
|
|
2935 -- If the type is the designated type of an access_to_subprogram,
|
|
|
2936 -- then there is no name to provide in the call.
|
|
|
2937
|
|
|
2938 if Ekind (Ent) = E_Subprogram_Type then
|
|
|
2939 return;
|
|
|
2940
|
|
|
2941 -- Otherwise, we will be able to find some kind of name to output
|
|
|
2942
|
|
|
2943 else
|
|
|
2944 Unwind_Internal_Type (Ent);
|
|
|
2945 Nam := Chars (Ent);
|
|
|
2946 end if;
|
|
|
2947
|
|
|
2948 -- If not internal name, or if we could not find a reasonable possible
|
|
|
2949 -- substitution for the internal name, just use name in Chars field.
|
|
|
2950
|
|
|
2951 else
|
|
|
2952 Nam := Chars (Node);
|
|
|
2953 Loc := Sloc (Node);
|
|
|
2954 end if;
|
|
|
2955
|
|
|
2956 -- At this stage, the name to output is in Nam
|
|
|
2957
|
|
|
2958 Get_Unqualified_Decoded_Name_String (Nam);
|
|
|
2959
|
|
|
2960 -- Remove trailing upper case letters from the name (useful for
|
|
|
2961 -- dealing with some cases of internal names).
|
|
|
2962
|
|
|
2963 while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop
|
|
|
2964 Name_Len := Name_Len - 1;
|
|
|
2965 end loop;
|
|
|
2966
|
|
|
2967 -- If we have any of the names from standard that start with the
|
|
|
2968 -- characters "any " (e.g. Any_Type), then kill the message since
|
|
|
2969 -- almost certainly it is a junk cascaded message.
|
|
|
2970
|
|
|
2971 if Name_Len > 4
|
|
|
2972 and then Name_Buffer (1 .. 4) = "any "
|
|
|
2973 then
|
|
|
2974 Kill_Message := True;
|
|
|
2975 end if;
|
|
|
2976
|
|
|
2977 -- If we still have an internal name, kill the message (will only
|
|
|
2978 -- work if we already had errors!)
|
|
|
2979
|
|
|
2980 if Is_Internal_Name then
|
|
|
2981 Kill_Message := True;
|
|
|
2982 end if;
|
|
|
2983 -- Remaining step is to adjust casing and possibly add 'Class
|
|
|
2984
|
|
|
2985 Adjust_Name_Case (Global_Name_Buffer, Loc);
|
|
|
2986 Set_Msg_Name_Buffer;
|
|
|
2987 Add_Class;
|
|
|
2988 end Set_Msg_Node;
|
|
|
2989
|
|
|
2990 ------------------
|
|
|
2991 -- Set_Msg_Text --
|
|
|
2992 ------------------
|
|
|
2993
|
|
|
2994 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
|
|
|
2995 C : Character; -- Current character
|
|
|
2996 P : Natural; -- Current index;
|
|
|
2997
|
|
|
2998 procedure Skip_Msg_Insertion_Warning (C : Character);
|
|
|
2999 -- Deal with ? ?? ?x? ?X? ?*? ?$? insertion sequences (and the same
|
|
|
3000 -- sequences using < instead of ?). The caller has already bumped
|
|
|
3001 -- the pointer past the initial ? or < and C is set to this initial
|
|
|
3002 -- character (? or <). This procedure skips past the rest of the
|
|
|
3003 -- sequence. We do not need to set Msg_Insertion_Char, since this
|
|
|
3004 -- was already done during the message prescan.
|
|
|
3005
|
|
|
3006 --------------------------------
|
|
|
3007 -- Skip_Msg_Insertion_Warning --
|
|
|
3008 --------------------------------
|
|
|
3009
|
|
|
3010 procedure Skip_Msg_Insertion_Warning (C : Character) is
|
|
|
3011 begin
|
|
|
3012 if P <= Text'Last and then Text (P) = C then
|
|
|
3013 P := P + 1;
|
|
|
3014
|
|
|
3015 elsif P + 1 <= Text'Last
|
|
|
3016 and then (Text (P) in 'a' .. 'z'
|
|
|
3017 or else
|
|
|
3018 Text (P) in 'A' .. 'Z'
|
|
|
3019 or else
|
|
|
3020 Text (P) = '*'
|
|
|
3021 or else
|
|
|
3022 Text (P) = '$')
|
|
|
3023 and then Text (P + 1) = C
|
|
|
3024 then
|
|
|
3025 P := P + 2;
|
|
|
3026 end if;
|
|
|
3027 end Skip_Msg_Insertion_Warning;
|
|
|
3028
|
|
|
3029 -- Start of processing for Set_Msg_Text
|
|
|
3030
|
|
|
3031 begin
|
|
|
3032 Manual_Quote_Mode := False;
|
|
|
3033 Msglen := 0;
|
|
|
3034 Flag_Source := Get_Source_File_Index (Flag);
|
|
|
3035
|
|
|
3036 -- Skip info: at start, we have recorded this in Is_Info_Msg, and this
|
|
|
3037 -- will be used (Info field in error message object) to put back the
|
|
|
3038 -- string when it is printed. We need to do this, or we get confused
|
|
|
3039 -- with instantiation continuations.
|
|
|
3040
|
|
|
3041 if Text'Length > 6
|
|
|
3042 and then Text (Text'First .. Text'First + 5) = "info: "
|
|
|
3043 then
|
|
|
3044 P := Text'First + 6;
|
|
|
3045 else
|
|
|
3046 P := Text'First;
|
|
|
3047 end if;
|
|
|
3048
|
|
|
3049 -- Loop through characters of message
|
|
|
3050
|
|
|
3051 while P <= Text'Last loop
|
|
|
3052 C := Text (P);
|
|
|
3053 P := P + 1;
|
|
|
3054
|
|
|
3055 -- Check for insertion character or sequence
|
|
|
3056
|
|
|
3057 case C is
|
|
|
3058 when '%' =>
|
|
|
3059 if P <= Text'Last and then Text (P) = '%' then
|
|
|
3060 P := P + 1;
|
|
|
3061 Set_Msg_Insertion_Name_Literal;
|
|
|
3062 else
|
|
|
3063 Set_Msg_Insertion_Name;
|
|
|
3064 end if;
|
|
|
3065
|
|
|
3066 when '$' =>
|
|
|
3067 if P <= Text'Last and then Text (P) = '$' then
|
|
|
3068 P := P + 1;
|
|
|
3069 Set_Msg_Insertion_Unit_Name (Suffix => False);
|
|
|
3070 else
|
|
|
3071 Set_Msg_Insertion_Unit_Name;
|
|
|
3072 end if;
|
|
|
3073
|
|
|
3074 when '{' =>
|
|
|
3075 Set_Msg_Insertion_File_Name;
|
|
|
3076
|
|
|
3077 when '}' =>
|
|
|
3078 Set_Msg_Insertion_Type_Reference (Flag);
|
|
|
3079
|
|
|
3080 when '*' =>
|
|
|
3081 Set_Msg_Insertion_Reserved_Name;
|
|
|
3082
|
|
|
3083 when '&' =>
|
|
|
3084 Set_Msg_Insertion_Node;
|
|
|
3085
|
|
|
3086 when '#' =>
|
|
|
3087 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
|
|
|
3088
|
|
|
3089 when '\' =>
|
|
|
3090 Continuation := True;
|
|
|
3091
|
|
|
3092 if P <= Text'Last and then Text (P) = '\' then
|
|
|
3093 Continuation_New_Line := True;
|
|
|
3094 P := P + 1;
|
|
|
3095 end if;
|
|
|
3096
|
|
|
3097 when '@' =>
|
|
|
3098 Set_Msg_Insertion_Column;
|
|
|
3099
|
|
|
3100 when '>' =>
|
|
|
3101 Set_Msg_Insertion_Run_Time_Name;
|
|
|
3102
|
|
|
3103 when '^' =>
|
|
|
3104 Set_Msg_Insertion_Uint;
|
|
|
3105
|
|
|
3106 when '`' =>
|
|
|
3107 Manual_Quote_Mode := not Manual_Quote_Mode;
|
|
|
3108 Set_Msg_Char ('"');
|
|
|
3109
|
|
|
3110 when '!' =>
|
|
|
3111 null; -- already dealt with
|
|
|
3112
|
|
|
3113 when '?' =>
|
|
|
3114 Skip_Msg_Insertion_Warning ('?');
|
|
|
3115
|
|
|
3116 when '<' =>
|
|
|
3117 Skip_Msg_Insertion_Warning ('<');
|
|
|
3118
|
|
|
3119 when '|' =>
|
|
|
3120 null; -- already dealt with
|
|
|
3121
|
|
|
3122 when ''' =>
|
|
|
3123 Set_Msg_Char (Text (P));
|
|
|
3124 P := P + 1;
|
|
|
3125
|
|
|
3126 when '~' =>
|
|
|
3127 Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen));
|
|
|
3128
|
|
|
3129 -- Upper case letter
|
|
|
3130
|
|
|
3131 when 'A' .. 'Z' =>
|
|
|
3132
|
|
|
3133 -- Start of reserved word if two or more
|
|
|
3134
|
|
|
3135 if P <= Text'Last and then Text (P) in 'A' .. 'Z' then
|
|
|
3136 P := P - 1;
|
|
|
3137 Set_Msg_Insertion_Reserved_Word (Text, P);
|
|
|
3138
|
|
|
3139 -- Single upper case letter is just inserted
|
|
|
3140
|
|
|
3141 else
|
|
|
3142 Set_Msg_Char (C);
|
|
|
3143 end if;
|
|
|
3144
|
|
|
3145 -- '[' (will be/would have been raised at run time)
|
|
|
3146
|
|
|
3147 when '[' =>
|
|
|
3148
|
|
|
3149 -- Switch the message from a warning to an error if the flag
|
|
|
3150 -- -gnatwE is specified to treat run-time exception warnings
|
|
|
3151 -- as errors.
|
|
|
3152
|
|
|
3153 if Is_Warning_Msg
|
|
|
3154 and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors
|
|
|
3155 then
|
|
|
3156 Is_Warning_Msg := False;
|
|
|
3157 end if;
|
|
|
3158
|
|
|
3159 if Is_Warning_Msg then
|
|
|
3160 Set_Msg_Str ("will be raised at run time");
|
|
|
3161 else
|
|
|
3162 Set_Msg_Str ("would have been raised at run time");
|
|
|
3163 end if;
|
|
|
3164
|
|
|
3165 -- ']' (may be/might have been raised at run time)
|
|
|
3166
|
|
|
3167 when ']' =>
|
|
|
3168 if Is_Warning_Msg then
|
|
|
3169 Set_Msg_Str ("may be raised at run time");
|
|
|
3170 else
|
|
|
3171 Set_Msg_Str ("might have been raised at run time");
|
|
|
3172 end if;
|
|
|
3173
|
|
|
3174 -- Normal character with no special treatment
|
|
|
3175
|
|
|
3176 when others =>
|
|
|
3177 Set_Msg_Char (C);
|
|
|
3178 end case;
|
|
|
3179 end loop;
|
|
|
3180 end Set_Msg_Text;
|
|
|
3181
|
|
|
3182 ----------------
|
|
|
3183 -- Set_Posted --
|
|
|
3184 ----------------
|
|
|
3185
|
|
|
3186 procedure Set_Posted (N : Node_Id) is
|
|
|
3187 P : Node_Id;
|
|
|
3188
|
|
|
3189 begin
|
|
|
3190 if Is_Serious_Error then
|
|
|
3191
|
|
|
3192 -- We always set Error_Posted on the node itself
|
|
|
3193
|
|
|
3194 Set_Error_Posted (N);
|
|
|
3195
|
|
|
3196 -- If it is a subexpression, then set Error_Posted on parents up to
|
|
|
3197 -- and including the first non-subexpression construct. This helps
|
|
|
3198 -- avoid cascaded error messages within a single expression.
|
|
|
3199
|
|
|
3200 P := N;
|
|
|
3201 loop
|
|
|
3202 P := Parent (P);
|
|
|
3203 exit when No (P);
|
|
|
3204 Set_Error_Posted (P);
|
|
|
3205 exit when Nkind (P) not in N_Subexpr;
|
|
|
3206 end loop;
|
|
|
3207
|
|
|
3208 if Nkind_In (P, N_Pragma_Argument_Association,
|
|
|
3209 N_Component_Association,
|
|
|
3210 N_Discriminant_Association,
|
|
|
3211 N_Generic_Association,
|
|
|
3212 N_Parameter_Association)
|
|
|
3213 then
|
|
|
3214 Set_Error_Posted (Parent (P));
|
|
|
3215 end if;
|
|
|
3216
|
|
|
3217 -- A special check, if we just posted an error on an attribute
|
|
|
3218 -- definition clause, then also set the entity involved as posted.
|
|
|
3219 -- For example, this stops complaining about the alignment after
|
|
|
3220 -- complaining about the size, which is likely to be useless.
|
|
|
3221
|
|
|
3222 if Nkind (P) = N_Attribute_Definition_Clause then
|
|
|
3223 if Is_Entity_Name (Name (P)) then
|
|
|
3224 Set_Error_Posted (Entity (Name (P)));
|
|
|
3225 end if;
|
|
|
3226 end if;
|
|
|
3227 end if;
|
|
|
3228 end Set_Posted;
|
|
|
3229
|
|
|
3230 -----------------------
|
|
|
3231 -- Set_Qualification --
|
|
|
3232 -----------------------
|
|
|
3233
|
|
|
3234 procedure Set_Qualification (N : Nat; E : Entity_Id) is
|
|
|
3235 begin
|
|
|
3236 if N /= 0 and then Scope (E) /= Standard_Standard then
|
|
|
3237 Set_Qualification (N - 1, Scope (E));
|
|
|
3238 Set_Msg_Node (Scope (E));
|
|
|
3239 Set_Msg_Char ('.');
|
|
|
3240 end if;
|
|
|
3241 end Set_Qualification;
|
|
|
3242
|
|
|
3243 ------------------------
|
|
|
3244 -- Special_Msg_Delete --
|
|
|
3245 ------------------------
|
|
|
3246
|
|
|
3247 -- Is it really right to have all this specialized knowledge in errout?
|
|
|
3248
|
|
|
3249 function Special_Msg_Delete
|
|
|
3250 (Msg : String;
|
|
|
3251 N : Node_Or_Entity_Id;
|
|
|
3252 E : Node_Or_Entity_Id) return Boolean
|
|
|
3253 is
|
|
|
3254 begin
|
|
|
3255 -- Never delete messages in -gnatdO mode
|
|
|
3256
|
|
|
3257 if Debug_Flag_OO then
|
|
|
3258 return False;
|
|
|
3259
|
|
|
3260 -- Processing for "Size too small" messages
|
|
|
3261
|
|
|
3262 elsif Msg = "size for& too small, minimum allowed is ^" then
|
|
|
3263
|
|
|
3264 -- Suppress "size too small" errors in CodePeer mode, since code may
|
|
|
3265 -- be analyzed in a different configuration than the one used for
|
|
|
3266 -- compilation. Even when the configurations match, this message
|
|
|
3267 -- may be issued on correct code, because pragma Pack is ignored
|
|
|
3268 -- in CodePeer mode.
|
|
|
3269
|
|
|
3270 if CodePeer_Mode then
|
|
|
3271 return True;
|
|
|
3272
|
|
|
3273 -- When a size is wrong for a frozen type there is no explicit size
|
|
|
3274 -- clause, and other errors have occurred, suppress the message,
|
|
|
3275 -- since it is likely that this size error is a cascaded result of
|
|
|
3276 -- other errors. The reason we eliminate unfrozen types is that
|
|
|
3277 -- messages issued before the freeze type are for sure OK.
|
|
|
3278
|
|
|
3279 elsif Is_Frozen (E)
|
|
|
3280 and then Serious_Errors_Detected > 0
|
|
|
3281 and then Nkind (N) /= N_Component_Clause
|
|
|
3282 and then Nkind (Parent (N)) /= N_Component_Clause
|
|
|
3283 and then
|
|
|
3284 No (Get_Attribute_Definition_Clause (E, Attribute_Size))
|
|
|
3285 and then
|
|
|
3286 No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
|
|
|
3287 and then
|
|
|
3288 No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))
|
|
|
3289 then
|
|
|
3290 return True;
|
|
|
3291 end if;
|
|
|
3292 end if;
|
|
|
3293
|
|
|
3294 -- All special tests complete, so go ahead with message
|
|
|
3295
|
|
|
3296 return False;
|
|
|
3297 end Special_Msg_Delete;
|
|
|
3298
|
|
|
3299 -----------------
|
|
|
3300 -- SPARK_Msg_N --
|
|
|
3301 -----------------
|
|
|
3302
|
|
|
3303 procedure SPARK_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
|
|
|
3304 begin
|
|
|
3305 if SPARK_Mode /= Off then
|
|
|
3306 Error_Msg_N (Msg, N);
|
|
|
3307 end if;
|
|
|
3308 end SPARK_Msg_N;
|
|
|
3309
|
|
|
3310 ------------------
|
|
|
3311 -- SPARK_Msg_NE --
|
|
|
3312 ------------------
|
|
|
3313
|
|
|
3314 procedure SPARK_Msg_NE
|
|
|
3315 (Msg : String;
|
|
|
3316 N : Node_Or_Entity_Id;
|
|
|
3317 E : Node_Or_Entity_Id)
|
|
|
3318 is
|
|
|
3319 begin
|
|
|
3320 if SPARK_Mode /= Off then
|
|
|
3321 Error_Msg_NE (Msg, N, E);
|
|
|
3322 end if;
|
|
|
3323 end SPARK_Msg_NE;
|
|
|
3324
|
|
|
3325 --------------------------
|
|
|
3326 -- Unwind_Internal_Type --
|
|
|
3327 --------------------------
|
|
|
3328
|
|
|
3329 procedure Unwind_Internal_Type (Ent : in out Entity_Id) is
|
|
|
3330 Derived : Boolean := False;
|
|
|
3331 Mchar : Character;
|
|
|
3332 Old_Ent : Entity_Id;
|
|
|
3333
|
|
|
3334 begin
|
|
|
3335 -- Undo placement of a quote, since we will put it back later
|
|
|
3336
|
|
|
3337 Mchar := Msg_Buffer (Msglen);
|
|
|
3338
|
|
|
3339 if Mchar = '"' then
|
|
|
3340 Msglen := Msglen - 1;
|
|
|
3341 end if;
|
|
|
3342
|
|
|
3343 -- The loop here deals with recursive types, we are trying to find a
|
|
|
3344 -- related entity that is not an implicit type. Note that the check with
|
|
|
3345 -- Old_Ent stops us from getting "stuck". Also, we don't output the
|
|
|
3346 -- "type derived from" message more than once in the case where we climb
|
|
|
3347 -- up multiple levels.
|
|
|
3348
|
|
|
3349 Find : loop
|
|
|
3350 Old_Ent := Ent;
|
|
|
3351
|
|
|
3352 -- Implicit access type, use directly designated type In Ada 2005,
|
|
|
3353 -- the designated type may be an anonymous access to subprogram, in
|
|
|
3354 -- which case we can only point to its definition.
|
|
|
3355
|
|
|
3356 if Is_Access_Type (Ent) then
|
|
|
3357 if Ekind (Ent) = E_Access_Subprogram_Type
|
|
|
3358 or else Ekind (Ent) = E_Anonymous_Access_Subprogram_Type
|
|
|
3359 or else Is_Access_Protected_Subprogram_Type (Ent)
|
|
|
3360 then
|
|
|
3361 Ent := Directly_Designated_Type (Ent);
|
|
|
3362
|
|
|
3363 if not Comes_From_Source (Ent) then
|
|
|
3364 if Buffer_Ends_With ("type ") then
|
|
|
3365 Buffer_Remove ("type ");
|
|
|
3366 end if;
|
|
|
3367 end if;
|
|
|
3368
|
|
|
3369 if Ekind (Ent) = E_Function then
|
|
|
3370 Set_Msg_Str ("access to function ");
|
|
|
3371 elsif Ekind (Ent) = E_Procedure then
|
|
|
3372 Set_Msg_Str ("access to procedure ");
|
|
|
3373 else
|
|
|
3374 Set_Msg_Str ("access to subprogram");
|
|
|
3375 end if;
|
|
|
3376
|
|
|
3377 exit Find;
|
|
|
3378
|
|
|
3379 -- Type is access to object, named or anonymous
|
|
|
3380
|
|
|
3381 else
|
|
|
3382 Set_Msg_Str ("access to ");
|
|
|
3383 Ent := Directly_Designated_Type (Ent);
|
|
|
3384 end if;
|
|
|
3385
|
|
|
3386 -- Classwide type
|
|
|
3387
|
|
|
3388 elsif Is_Class_Wide_Type (Ent) then
|
|
|
3389 Class_Flag := True;
|
|
|
3390 Ent := Root_Type (Ent);
|
|
|
3391
|
|
|
3392 -- Use base type if this is a subtype
|
|
|
3393
|
|
|
3394 elsif Ent /= Base_Type (Ent) then
|
|
|
3395 Buffer_Remove ("type ");
|
|
|
3396
|
|
|
3397 -- Avoid duplication "subtype of subtype of", and also replace
|
|
|
3398 -- "derived from subtype of" simply by "derived from"
|
|
|
3399
|
|
|
3400 if not Buffer_Ends_With ("subtype of ")
|
|
|
3401 and then not Buffer_Ends_With ("derived from ")
|
|
|
3402 then
|
|
|
3403 Set_Msg_Str ("subtype of ");
|
|
|
3404 end if;
|
|
|
3405
|
|
|
3406 Ent := Base_Type (Ent);
|
|
|
3407
|
|
|
3408 -- If this is a base type with a first named subtype, use the first
|
|
|
3409 -- named subtype instead. This is not quite accurate in all cases,
|
|
|
3410 -- but it makes too much noise to be accurate and add 'Base in all
|
|
|
3411 -- cases. Note that we only do this is the first named subtype is not
|
|
|
3412 -- itself an internal name. This avoids the obvious loop (subtype ->
|
|
|
3413 -- basetype -> subtype) which would otherwise occur).
|
|
|
3414
|
|
|
3415 else
|
|
|
3416 declare
|
|
|
3417 FST : constant Entity_Id := First_Subtype (Ent);
|
|
|
3418
|
|
|
3419 begin
|
|
|
3420 if not Is_Internal_Name (Chars (FST)) then
|
|
|
3421 Ent := FST;
|
|
|
3422 exit Find;
|
|
|
3423
|
|
|
3424 -- Otherwise use root type
|
|
|
3425
|
|
|
3426 else
|
|
|
3427 if not Derived then
|
|
|
3428 Buffer_Remove ("type ");
|
|
|
3429
|
|
|
3430 -- Test for "subtype of type derived from" which seems
|
|
|
3431 -- excessive and is replaced by "type derived from".
|
|
|
3432
|
|
|
3433 Buffer_Remove ("subtype of");
|
|
|
3434
|
|
|
3435 -- Avoid duplicated "type derived from type derived from"
|
|
|
3436
|
|
|
3437 if not Buffer_Ends_With ("type derived from ") then
|
|
|
3438 Set_Msg_Str ("type derived from ");
|
|
|
3439 end if;
|
|
|
3440
|
|
|
3441 Derived := True;
|
|
|
3442 end if;
|
|
|
3443 end if;
|
|
|
3444 end;
|
|
|
3445
|
|
|
3446 Ent := Etype (Ent);
|
|
|
3447 end if;
|
|
|
3448
|
|
|
3449 -- If we are stuck in a loop, get out and settle for the internal
|
|
|
3450 -- name after all. In this case we set to kill the message if it is
|
|
|
3451 -- not the first error message (we really try hard not to show the
|
|
|
3452 -- dirty laundry of the implementation to the poor user).
|
|
|
3453
|
|
|
3454 if Ent = Old_Ent then
|
|
|
3455 Kill_Message := True;
|
|
|
3456 exit Find;
|
|
|
3457 end if;
|
|
|
3458
|
|
|
3459 -- Get out if we finally found a non-internal name to use
|
|
|
3460
|
|
|
3461 exit Find when not Is_Internal_Name (Chars (Ent));
|
|
|
3462 end loop Find;
|
|
|
3463
|
|
|
3464 if Mchar = '"' then
|
|
|
3465 Set_Msg_Char ('"');
|
|
|
3466 end if;
|
|
|
3467 end Unwind_Internal_Type;
|
|
|
3468
|
|
|
3469 --------------------
|
|
|
3470 -- Warn_Insertion --
|
|
|
3471 --------------------
|
|
|
3472
|
|
|
3473 function Warn_Insertion return String is
|
|
|
3474 begin
|
|
|
3475 case Warning_Msg_Char is
|
|
|
3476 when '?' =>
|
|
|
3477 return "??";
|
|
|
3478
|
|
|
3479 when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' =>
|
|
|
3480 return '?' & Warning_Msg_Char & '?';
|
|
|
3481
|
|
|
3482 when ' ' =>
|
|
|
3483 return "?";
|
|
|
3484
|
|
|
3485 when others =>
|
|
|
3486 raise Program_Error;
|
|
|
3487 end case;
|
|
|
3488 end Warn_Insertion;
|
|
|
3489
|
|
|
3490 end Errout;
|
