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