]>
Commit | Line | Data |
---|---|---|
19235870 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- P A R . P R A G -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
1e60643a | 9 | -- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- |
19235870 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- -- |
19235870 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. -- | |
f197d2f2 | 20 | -- -- |
19235870 | 21 | -- GNAT was originally developed by the GNAT team at New York University. -- |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
19235870 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | -- Generally the parser checks the basic syntax of pragmas, but does not | |
27 | -- do specialized syntax checks for individual pragmas, these are deferred | |
28 | -- to semantic analysis time (see unit Sem_Prag). There are some pragmas | |
29 | -- which require recognition and either partial or complete processing | |
30 | -- during parsing, and this unit performs this required processing. | |
31 | ||
32 | with Fname.UF; use Fname.UF; | |
33 | with Osint; use Osint; | |
5f3ab6fb AC |
34 | with Rident; use Rident; |
35 | with Restrict; use Restrict; | |
19235870 RK |
36 | with Stringt; use Stringt; |
37 | with Stylesw; use Stylesw; | |
38 | with Uintp; use Uintp; | |
39 | with Uname; use Uname; | |
40 | ||
3cb8344b RD |
41 | with System.WCh_Con; use System.WCh_Con; |
42 | ||
19235870 RK |
43 | separate (Par) |
44 | ||
45 | function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is | |
1b24ada5 RD |
46 | Prag_Name : constant Name_Id := Pragma_Name (Pragma_Node); |
47 | Prag_Id : constant Pragma_Id := Get_Pragma_Id (Prag_Name); | |
19235870 RK |
48 | Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node); |
49 | Arg_Count : Nat; | |
50 | Arg_Node : Node_Id; | |
51 | ||
52 | ----------------------- | |
53 | -- Local Subprograms -- | |
54 | ----------------------- | |
55 | ||
dbb4cfef AC |
56 | procedure Add_List_Pragma_Entry (PT : List_Pragma_Type; Loc : Source_Ptr); |
57 | -- Make a new entry in the List_Pragmas table if this entry is not already | |
58 | -- in the table (it will always be the last one if there is a duplication | |
59 | -- resulting from the use of Save/Restore_Scan_State). | |
60 | ||
19235870 RK |
61 | function Arg1 return Node_Id; |
62 | function Arg2 return Node_Id; | |
63 | function Arg3 return Node_Id; | |
19235870 RK |
64 | -- Obtain specified Pragma_Argument_Association. It is allowable to call |
65 | -- the routine for the argument one past the last present argument, but | |
66 | -- that is the only case in which a non-present argument can be referenced. | |
67 | ||
68 | procedure Check_Arg_Count (Required : Int); | |
12b4d338 AC |
69 | -- Check argument count for pragma = Required. If not give error and raise |
70 | -- Error_Resync. | |
19235870 RK |
71 | |
72 | procedure Check_Arg_Is_String_Literal (Arg : Node_Id); | |
73 | -- Check the expression of the specified argument to make sure that it | |
74 | -- is a string literal. If not give error and raise Error_Resync. | |
75 | ||
76 | procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id); | |
77 | -- Check the expression of the specified argument to make sure that it | |
78 | -- is an identifier which is either ON or OFF, and if not, then issue | |
79 | -- an error message and raise Error_Resync. | |
80 | ||
81 | procedure Check_No_Identifier (Arg : Node_Id); | |
fbf5a39b AC |
82 | -- Checks that the given argument does not have an identifier. If |
83 | -- an identifier is present, then an error message is issued, and | |
19235870 RK |
84 | -- Error_Resync is raised. |
85 | ||
86 | procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); | |
87 | -- Checks if the given argument has an identifier, and if so, requires | |
88 | -- it to match the given identifier name. If there is a non-matching | |
89 | -- identifier, then an error message is given and Error_Resync raised. | |
90 | ||
91 | procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id); | |
92 | -- Same as Check_Optional_Identifier, except that the name is required | |
93 | -- to be present and to match the given Id value. | |
94 | ||
5f3ab6fb AC |
95 | procedure Process_Restrictions_Or_Restriction_Warnings; |
96 | -- Common processing for Restrictions and Restriction_Warnings pragmas. | |
0580d807 AC |
97 | -- For the most part, restrictions need not be processed at parse time, |
98 | -- since they only affect semantic processing. This routine handles the | |
99 | -- exceptions as follows | |
100 | -- | |
101 | -- No_Obsolescent_Features must be processed at parse time, since there | |
102 | -- are some obsolescent features (e.g. character replacements) which are | |
103 | -- handled at parse time. | |
104 | -- | |
105 | -- SPARK must be processed at parse time, since this restriction controls | |
106 | -- whether the scanner recognizes a spark HIDE directive formatted as an | |
107 | -- Ada comment (and generates a Tok_SPARK_Hide token for the directive). | |
108 | -- | |
109 | -- No_Dependence must be processed at parse time, since otherwise it gets | |
110 | -- handled too late. | |
111 | -- | |
112 | -- Note that we don't need to do full error checking for badly formed cases | |
113 | -- of restrictions, since these will be caught during semantic analysis. | |
5f3ab6fb | 114 | |
dbb4cfef AC |
115 | --------------------------- |
116 | -- Add_List_Pragma_Entry -- | |
117 | --------------------------- | |
118 | ||
119 | procedure Add_List_Pragma_Entry (PT : List_Pragma_Type; Loc : Source_Ptr) is | |
120 | begin | |
121 | if List_Pragmas.Last < List_Pragmas.First | |
122 | or else (List_Pragmas.Table (List_Pragmas.Last)) /= ((PT, Loc)) | |
123 | then | |
124 | List_Pragmas.Append ((PT, Loc)); | |
125 | end if; | |
126 | end Add_List_Pragma_Entry; | |
127 | ||
19235870 RK |
128 | ---------- |
129 | -- Arg1 -- | |
130 | ---------- | |
131 | ||
132 | function Arg1 return Node_Id is | |
133 | begin | |
134 | return First (Pragma_Argument_Associations (Pragma_Node)); | |
135 | end Arg1; | |
136 | ||
137 | ---------- | |
138 | -- Arg2 -- | |
139 | ---------- | |
140 | ||
141 | function Arg2 return Node_Id is | |
142 | begin | |
143 | return Next (Arg1); | |
144 | end Arg2; | |
145 | ||
146 | ---------- | |
147 | -- Arg3 -- | |
148 | ---------- | |
149 | ||
150 | function Arg3 return Node_Id is | |
151 | begin | |
152 | return Next (Arg2); | |
153 | end Arg3; | |
154 | ||
19235870 RK |
155 | --------------------- |
156 | -- Check_Arg_Count -- | |
157 | --------------------- | |
158 | ||
159 | procedure Check_Arg_Count (Required : Int) is | |
160 | begin | |
161 | if Arg_Count /= Required then | |
162 | Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc); | |
163 | raise Error_Resync; | |
164 | end if; | |
165 | end Check_Arg_Count; | |
166 | ||
167 | ---------------------------- | |
168 | -- Check_Arg_Is_On_Or_Off -- | |
169 | ---------------------------- | |
170 | ||
171 | procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is | |
172 | Argx : constant Node_Id := Expression (Arg); | |
173 | ||
174 | begin | |
175 | if Nkind (Expression (Arg)) /= N_Identifier | |
b69cd36a | 176 | or else not Nam_In (Chars (Argx), Name_On, Name_Off) |
19235870 RK |
177 | then |
178 | Error_Msg_Name_2 := Name_On; | |
179 | Error_Msg_Name_3 := Name_Off; | |
180 | ||
ed2233dc | 181 | Error_Msg ("argument for pragma% must be% or%", Sloc (Argx)); |
19235870 RK |
182 | raise Error_Resync; |
183 | end if; | |
184 | end Check_Arg_Is_On_Or_Off; | |
185 | ||
186 | --------------------------------- | |
187 | -- Check_Arg_Is_String_Literal -- | |
188 | --------------------------------- | |
189 | ||
190 | procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is | |
191 | begin | |
192 | if Nkind (Expression (Arg)) /= N_String_Literal then | |
193 | Error_Msg | |
194 | ("argument for pragma% must be string literal", | |
195 | Sloc (Expression (Arg))); | |
196 | raise Error_Resync; | |
197 | end if; | |
198 | end Check_Arg_Is_String_Literal; | |
199 | ||
200 | ------------------------- | |
201 | -- Check_No_Identifier -- | |
202 | ------------------------- | |
203 | ||
204 | procedure Check_No_Identifier (Arg : Node_Id) is | |
205 | begin | |
206 | if Chars (Arg) /= No_Name then | |
207 | Error_Msg_N ("pragma% does not permit named arguments", Arg); | |
208 | raise Error_Resync; | |
209 | end if; | |
210 | end Check_No_Identifier; | |
211 | ||
212 | ------------------------------- | |
213 | -- Check_Optional_Identifier -- | |
214 | ------------------------------- | |
215 | ||
216 | procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is | |
217 | begin | |
218 | if Present (Arg) and then Chars (Arg) /= No_Name then | |
219 | if Chars (Arg) /= Id then | |
220 | Error_Msg_Name_2 := Id; | |
221 | Error_Msg_N ("pragma% argument expects identifier%", Arg); | |
222 | end if; | |
223 | end if; | |
224 | end Check_Optional_Identifier; | |
225 | ||
226 | ------------------------------- | |
227 | -- Check_Required_Identifier -- | |
228 | ------------------------------- | |
229 | ||
230 | procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id) is | |
231 | begin | |
232 | if Chars (Arg) /= Id then | |
233 | Error_Msg_Name_2 := Id; | |
234 | Error_Msg_N ("pragma% argument must have identifier%", Arg); | |
235 | end if; | |
236 | end Check_Required_Identifier; | |
237 | ||
5f3ab6fb AC |
238 | -------------------------------------------------- |
239 | -- Process_Restrictions_Or_Restriction_Warnings -- | |
240 | -------------------------------------------------- | |
241 | ||
242 | procedure Process_Restrictions_Or_Restriction_Warnings is | |
243 | Arg : Node_Id; | |
244 | Id : Name_Id; | |
245 | Expr : Node_Id; | |
246 | ||
247 | begin | |
248 | Arg := Arg1; | |
249 | while Present (Arg) loop | |
250 | Id := Chars (Arg); | |
251 | Expr := Expression (Arg); | |
252 | ||
d7a3e18c AC |
253 | if Id = No_Name and then Nkind (Expr) = N_Identifier then |
254 | case Chars (Expr) is | |
6480338a | 255 | when Name_No_Obsolescent_Features => |
cb7fa356 AC |
256 | Set_Restriction (No_Obsolescent_Features, Pragma_Node); |
257 | Restriction_Warnings (No_Obsolescent_Features) := | |
258 | Prag_Id = Pragma_Restriction_Warnings; | |
0580d807 | 259 | |
6480338a AC |
260 | when Name_SPARK | Name_SPARK_05 => |
261 | Set_Restriction (SPARK_05, Pragma_Node); | |
262 | Restriction_Warnings (SPARK_05) := | |
f9adb9d4 | 263 | Prag_Id = Pragma_Restriction_Warnings; |
0580d807 | 264 | |
cb7fa356 AC |
265 | when others => |
266 | null; | |
267 | end case; | |
5f3ab6fb AC |
268 | |
269 | elsif Id = Name_No_Dependence then | |
270 | Set_Restriction_No_Dependence | |
271 | (Unit => Expr, | |
23e6615e RD |
272 | Warn => Prag_Id = Pragma_Restriction_Warnings |
273 | or else Treat_Restrictions_As_Warnings); | |
5f3ab6fb AC |
274 | end if; |
275 | ||
276 | Next (Arg); | |
277 | end loop; | |
278 | end Process_Restrictions_Or_Restriction_Warnings; | |
279 | ||
1b24ada5 | 280 | -- Start of processing for Prag |
19235870 RK |
281 | |
282 | begin | |
1b24ada5 | 283 | Error_Msg_Name_1 := Prag_Name; |
19235870 | 284 | |
07fc65c4 GB |
285 | -- Ignore unrecognized pragma. We let Sem post the warning for this, since |
286 | -- it is a semantic error, not a syntactic one (we have already checked | |
287 | -- the syntax for the unrecognized pragma as required by (RM 2.8(11)). | |
288 | ||
5f3ab6fb | 289 | if Prag_Id = Unknown_Pragma then |
07fc65c4 GB |
290 | return Pragma_Node; |
291 | end if; | |
292 | ||
47346923 AC |
293 | -- Ignore pragma previously flagged by Ignore_Pragma |
294 | ||
295 | if Get_Name_Table_Boolean3 (Prag_Name) then | |
296 | return Pragma_Node; | |
297 | end if; | |
298 | ||
19235870 RK |
299 | -- Count number of arguments. This loop also checks if any of the arguments |
300 | -- are Error, indicating a syntax error as they were parsed. If so, we | |
301 | -- simply return, because we get into trouble with cascaded errors if we | |
302 | -- try to perform our error checks on junk arguments. | |
303 | ||
304 | Arg_Count := 0; | |
305 | ||
306 | if Present (Pragma_Argument_Associations (Pragma_Node)) then | |
307 | Arg_Node := Arg1; | |
19235870 RK |
308 | while Arg_Node /= Empty loop |
309 | Arg_Count := Arg_Count + 1; | |
310 | ||
311 | if Expression (Arg_Node) = Error then | |
312 | return Error; | |
313 | end if; | |
314 | ||
315 | Next (Arg_Node); | |
316 | end loop; | |
317 | end if; | |
318 | ||
319 | -- Remaining processing is pragma dependent | |
320 | ||
5f3ab6fb | 321 | case Prag_Id is |
19235870 RK |
322 | |
323 | ------------ | |
324 | -- Ada_83 -- | |
325 | ------------ | |
326 | ||
327 | -- This pragma must be processed at parse time, since we want to set | |
0ab80019 AC |
328 | -- the Ada version properly at parse time to recognize the appropriate |
329 | -- Ada version syntax. | |
19235870 RK |
330 | |
331 | when Pragma_Ada_83 => | |
1e60643a AC |
332 | if not Latest_Ada_Only then |
333 | Ada_Version := Ada_83; | |
334 | Ada_Version_Explicit := Ada_83; | |
335 | Ada_Version_Pragma := Pragma_Node; | |
336 | end if; | |
19235870 RK |
337 | |
338 | ------------ | |
339 | -- Ada_95 -- | |
340 | ------------ | |
341 | ||
342 | -- This pragma must be processed at parse time, since we want to set | |
0ab80019 AC |
343 | -- the Ada version properly at parse time to recognize the appropriate |
344 | -- Ada version syntax. | |
19235870 RK |
345 | |
346 | when Pragma_Ada_95 => | |
1e60643a AC |
347 | if not Latest_Ada_Only then |
348 | Ada_Version := Ada_95; | |
349 | Ada_Version_Explicit := Ada_95; | |
350 | Ada_Version_Pragma := Pragma_Node; | |
351 | end if; | |
0ab80019 | 352 | |
1f6a2b51 RD |
353 | --------------------- |
354 | -- Ada_05/Ada_2005 -- | |
355 | --------------------- | |
0ab80019 | 356 | |
0eed45bb | 357 | -- These pragmas must be processed at parse time, since we want to set |
0ab80019 | 358 | -- the Ada version properly at parse time to recognize the appropriate |
82c80734 RD |
359 | -- Ada version syntax. However, it is only the zero argument form that |
360 | -- must be processed at parse time. | |
0ab80019 | 361 | |
1f6a2b51 | 362 | when Pragma_Ada_05 | Pragma_Ada_2005 => |
1e60643a | 363 | if Arg_Count = 0 and not Latest_Ada_Only then |
0791fbe9 BD |
364 | Ada_Version := Ada_2005; |
365 | Ada_Version_Explicit := Ada_2005; | |
fb620b37 | 366 | Ada_Version_Pragma := Pragma_Node; |
82c80734 | 367 | end if; |
19235870 | 368 | |
0eed45bb AC |
369 | --------------------- |
370 | -- Ada_12/Ada_2012 -- | |
371 | --------------------- | |
372 | ||
373 | -- These pragmas must be processed at parse time, since we want to set | |
374 | -- the Ada version properly at parse time to recognize the appropriate | |
599a7411 AC |
375 | -- Ada version syntax. However, it is only the zero argument form that |
376 | -- must be processed at parse time. | |
0eed45bb AC |
377 | |
378 | when Pragma_Ada_12 | Pragma_Ada_2012 => | |
599a7411 | 379 | if Arg_Count = 0 then |
dbe945f1 AC |
380 | Ada_Version := Ada_2012; |
381 | Ada_Version_Explicit := Ada_2012; | |
fb620b37 | 382 | Ada_Version_Pragma := Pragma_Node; |
599a7411 | 383 | end if; |
0eed45bb | 384 | |
c86cf714 RD |
385 | --------------------------- |
386 | -- Compiler_Unit_Warning -- | |
387 | --------------------------- | |
388 | ||
389 | -- This pragma must be processed at parse time, since the resulting | |
390 | -- status may be tested during the parsing of the program. | |
391 | ||
392 | when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning => | |
393 | Check_Arg_Count (0); | |
394 | ||
395 | -- Only recognized in main unit | |
396 | ||
397 | if Current_Source_Unit = Main_Unit then | |
398 | Compiler_Unit := True; | |
399 | end if; | |
400 | ||
19235870 RK |
401 | ----------- |
402 | -- Debug -- | |
403 | ----------- | |
404 | ||
7ab4d95a | 405 | -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); |
19235870 | 406 | |
7ab4d95a AC |
407 | when Pragma_Debug => |
408 | Check_No_Identifier (Arg1); | |
19235870 | 409 | |
c3217dac | 410 | if Arg_Count = 2 then |
c3217dac | 411 | Check_No_Identifier (Arg2); |
c3217dac RD |
412 | else |
413 | Check_Arg_Count (1); | |
c3217dac | 414 | end if; |
19235870 RK |
415 | |
416 | ------------------------------- | |
417 | -- Extensions_Allowed (GNAT) -- | |
418 | ------------------------------- | |
419 | ||
420 | -- pragma Extensions_Allowed (Off | On) | |
421 | ||
422 | -- The processing for pragma Extensions_Allowed must be done at | |
423 | -- parse time, since extensions mode may affect what is accepted. | |
424 | ||
425 | when Pragma_Extensions_Allowed => | |
426 | Check_Arg_Count (1); | |
427 | Check_No_Identifier (Arg1); | |
428 | Check_Arg_Is_On_Or_Off (Arg1); | |
0ab80019 AC |
429 | |
430 | if Chars (Expression (Arg1)) = Name_On then | |
431 | Extensions_Allowed := True; | |
dbe945f1 | 432 | Ada_Version := Ada_2012; |
0ab80019 AC |
433 | else |
434 | Extensions_Allowed := False; | |
0eed45bb | 435 | Ada_Version := Ada_Version_Explicit; |
0ab80019 | 436 | end if; |
19235870 | 437 | |
47346923 AC |
438 | ------------------- |
439 | -- Ignore_Pragma -- | |
440 | ------------------- | |
441 | ||
442 | -- Processing for this pragma must be done at parse time, since we want | |
443 | -- be able to ignore pragmas that are otherwise processed at parse time. | |
444 | ||
445 | when Pragma_Ignore_Pragma => Ignore_Pragma : declare | |
446 | A : Node_Id; | |
447 | ||
448 | begin | |
449 | Check_Arg_Count (1); | |
450 | Check_No_Identifier (Arg1); | |
451 | A := Expression (Arg1); | |
452 | ||
453 | if Nkind (A) /= N_Identifier then | |
454 | Error_Msg ("incorrect argument for pragma %", Sloc (A)); | |
455 | else | |
456 | Set_Name_Table_Boolean3 (Chars (A), True); | |
457 | end if; | |
458 | end Ignore_Pragma; | |
459 | ||
19235870 RK |
460 | ---------------- |
461 | -- List (2.8) -- | |
462 | ---------------- | |
463 | ||
464 | -- pragma List (Off | On) | |
465 | ||
dbb4cfef AC |
466 | -- The processing for pragma List must be done at parse time, since a |
467 | -- listing can be generated in parse only mode. | |
19235870 RK |
468 | |
469 | when Pragma_List => | |
470 | Check_Arg_Count (1); | |
471 | Check_No_Identifier (Arg1); | |
472 | Check_Arg_Is_On_Or_Off (Arg1); | |
473 | ||
474 | -- We unconditionally make a List_On entry for the pragma, so that | |
475 | -- in the List (Off) case, the pragma will print even in a region | |
a90bd866 | 476 | -- of code with listing turned off (this is required). |
19235870 | 477 | |
dbb4cfef | 478 | Add_List_Pragma_Entry (List_On, Sloc (Pragma_Node)); |
19235870 RK |
479 | |
480 | -- Now generate the list off entry for pragma List (Off) | |
481 | ||
482 | if Chars (Expression (Arg1)) = Name_Off then | |
dbb4cfef | 483 | Add_List_Pragma_Entry (List_Off, Semi); |
19235870 RK |
484 | end if; |
485 | ||
486 | ---------------- | |
487 | -- Page (2.8) -- | |
488 | ---------------- | |
489 | ||
490 | -- pragma Page; | |
491 | ||
492 | -- Processing for this pragma must be done at parse time, since a | |
493 | -- listing can be generated in parse only mode with semantics off. | |
494 | ||
495 | when Pragma_Page => | |
496 | Check_Arg_Count (0); | |
dbb4cfef | 497 | Add_List_Pragma_Entry (Page, Semi); |
19235870 | 498 | |
53beff22 YM |
499 | ------------------ |
500 | -- Restrictions -- | |
501 | ------------------ | |
5f3ab6fb | 502 | |
53beff22 | 503 | -- pragma Restrictions (RESTRICTION {, RESTRICTION}); |
5f3ab6fb | 504 | |
53beff22 YM |
505 | -- RESTRICTION ::= |
506 | -- restriction_IDENTIFIER | |
507 | -- | restriction_parameter_IDENTIFIER => EXPRESSION | |
5f3ab6fb | 508 | |
53beff22 YM |
509 | -- We process the case of No_Obsolescent_Features, since this has |
510 | -- a syntactic effect that we need to detect at parse time (the use | |
511 | -- of replacement characters such as colon for pound sign). | |
5f3ab6fb | 512 | |
53beff22 YM |
513 | when Pragma_Restrictions => |
514 | Process_Restrictions_Or_Restriction_Warnings; | |
5f3ab6fb | 515 | |
53beff22 YM |
516 | -------------------------- |
517 | -- Restriction_Warnings -- | |
518 | -------------------------- | |
5f3ab6fb | 519 | |
53beff22 | 520 | -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); |
5f3ab6fb | 521 | |
53beff22 YM |
522 | -- RESTRICTION ::= |
523 | -- restriction_IDENTIFIER | |
524 | -- | restriction_parameter_IDENTIFIER => EXPRESSION | |
5f3ab6fb | 525 | |
53beff22 | 526 | -- See above comment for pragma Restrictions |
5f3ab6fb | 527 | |
53beff22 YM |
528 | when Pragma_Restriction_Warnings => |
529 | Process_Restrictions_Or_Restriction_Warnings; | |
5f3ab6fb | 530 | |
fbf5a39b AC |
531 | ---------------------------------------------------------- |
532 | -- Source_File_Name and Source_File_Name_Project (GNAT) -- | |
533 | ---------------------------------------------------------- | |
19235870 | 534 | |
fbf5a39b AC |
535 | -- These two pragmas have the same syntax and semantics. |
536 | -- There are five forms of these pragmas: | |
19235870 | 537 | |
2820d220 | 538 | -- pragma Source_File_Name[_Project] ( |
19235870 | 539 | -- [UNIT_NAME =>] unit_NAME, |
2820d220 AC |
540 | -- BODY_FILE_NAME => STRING_LITERAL |
541 | -- [, [INDEX =>] INTEGER_LITERAL]); | |
19235870 | 542 | |
2820d220 | 543 | -- pragma Source_File_Name[_Project] ( |
19235870 | 544 | -- [UNIT_NAME =>] unit_NAME, |
2820d220 AC |
545 | -- SPEC_FILE_NAME => STRING_LITERAL |
546 | -- [, [INDEX =>] INTEGER_LITERAL]); | |
19235870 | 547 | |
2820d220 | 548 | -- pragma Source_File_Name[_Project] ( |
19235870 RK |
549 | -- BODY_FILE_NAME => STRING_LITERAL |
550 | -- [, DOT_REPLACEMENT => STRING_LITERAL] | |
551 | -- [, CASING => CASING_SPEC]); | |
552 | ||
2820d220 | 553 | -- pragma Source_File_Name[_Project] ( |
19235870 RK |
554 | -- SPEC_FILE_NAME => STRING_LITERAL |
555 | -- [, DOT_REPLACEMENT => STRING_LITERAL] | |
556 | -- [, CASING => CASING_SPEC]); | |
557 | ||
2820d220 | 558 | -- pragma Source_File_Name[_Project] ( |
19235870 RK |
559 | -- SUBUNIT_FILE_NAME => STRING_LITERAL |
560 | -- [, DOT_REPLACEMENT => STRING_LITERAL] | |
561 | -- [, CASING => CASING_SPEC]); | |
562 | ||
563 | -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase | |
564 | ||
fbf5a39b AC |
565 | -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma |
566 | -- Source_File_Name (SFN), however their usage is exclusive: | |
567 | -- SFN can only be used when no project file is used, while | |
568 | -- SFNP can only be used when a project file is used. | |
569 | ||
570 | -- The Project Manager produces a configuration pragmas file that | |
571 | -- is communicated to the compiler with -gnatec switch. This file | |
572 | -- contains only SFNP pragmas (at least two for the default naming | |
573 | -- scheme. As this configuration pragmas file is always the first | |
574 | -- processed by the compiler, it prevents the use of pragmas SFN in | |
575 | -- other config files when a project file is in use. | |
576 | ||
19235870 RK |
577 | -- Note: we process this during parsing, since we need to have the |
578 | -- source file names set well before the semantic analysis starts, | |
579 | -- since we load the spec and with'ed packages before analysis. | |
580 | ||
fbf5a39b AC |
581 | when Pragma_Source_File_Name | Pragma_Source_File_Name_Project => |
582 | Source_File_Name : declare | |
583 | Unam : Unit_Name_Type; | |
584 | Expr1 : Node_Id; | |
585 | Pat : String_Ptr; | |
586 | Typ : Character; | |
587 | Dot : String_Ptr; | |
588 | Cas : Casing_Type; | |
589 | Nast : Nat; | |
2820d220 AC |
590 | Expr : Node_Id; |
591 | Index : Nat; | |
19235870 | 592 | |
2fa9443e | 593 | function Get_Fname (Arg : Node_Id) return File_Name_Type; |
fbf5a39b | 594 | -- Process file name from unit name form of pragma |
19235870 | 595 | |
fbf5a39b AC |
596 | function Get_String_Argument (Arg : Node_Id) return String_Ptr; |
597 | -- Process string literal value from argument | |
19235870 | 598 | |
fbf5a39b AC |
599 | procedure Process_Casing (Arg : Node_Id); |
600 | -- Process Casing argument of pattern form of pragma | |
19235870 | 601 | |
fbf5a39b | 602 | procedure Process_Dot_Replacement (Arg : Node_Id); |
dec55d76 | 603 | -- Process Dot_Replacement argument of pattern form of pragma |
19235870 | 604 | |
fbf5a39b AC |
605 | --------------- |
606 | -- Get_Fname -- | |
607 | --------------- | |
19235870 | 608 | |
2fa9443e | 609 | function Get_Fname (Arg : Node_Id) return File_Name_Type is |
fbf5a39b AC |
610 | begin |
611 | String_To_Name_Buffer (Strval (Expression (Arg))); | |
19235870 | 612 | |
fbf5a39b AC |
613 | for J in 1 .. Name_Len loop |
614 | if Is_Directory_Separator (Name_Buffer (J)) then | |
ed2233dc | 615 | Error_Msg |
fbf5a39b AC |
616 | ("directory separator character not allowed", |
617 | Sloc (Expression (Arg)) + Source_Ptr (J)); | |
618 | end if; | |
619 | end loop; | |
19235870 | 620 | |
fbf5a39b AC |
621 | return Name_Find; |
622 | end Get_Fname; | |
19235870 | 623 | |
fbf5a39b AC |
624 | ------------------------- |
625 | -- Get_String_Argument -- | |
626 | ------------------------- | |
19235870 | 627 | |
fbf5a39b AC |
628 | function Get_String_Argument (Arg : Node_Id) return String_Ptr is |
629 | Str : String_Id; | |
19235870 | 630 | |
fbf5a39b AC |
631 | begin |
632 | if Nkind (Expression (Arg)) /= N_String_Literal | |
633 | and then | |
634 | Nkind (Expression (Arg)) /= N_Operator_Symbol | |
635 | then | |
636 | Error_Msg_N | |
637 | ("argument for pragma% must be string literal", Arg); | |
638 | raise Error_Resync; | |
639 | end if; | |
19235870 | 640 | |
fbf5a39b | 641 | Str := Strval (Expression (Arg)); |
19235870 | 642 | |
fbf5a39b | 643 | -- Check string has no wide chars |
19235870 | 644 | |
fbf5a39b AC |
645 | for J in 1 .. String_Length (Str) loop |
646 | if Get_String_Char (Str, J) > 255 then | |
647 | Error_Msg | |
648 | ("wide character not allowed in pattern for pragma%", | |
649 | Sloc (Expression (Arg2)) + Text_Ptr (J) - 1); | |
650 | end if; | |
651 | end loop; | |
652 | ||
653 | -- Acquire string | |
654 | ||
655 | String_To_Name_Buffer (Str); | |
656 | return new String'(Name_Buffer (1 .. Name_Len)); | |
657 | end Get_String_Argument; | |
658 | ||
659 | -------------------- | |
660 | -- Process_Casing -- | |
661 | -------------------- | |
662 | ||
663 | procedure Process_Casing (Arg : Node_Id) is | |
664 | Expr : constant Node_Id := Expression (Arg); | |
665 | ||
666 | begin | |
667 | Check_Required_Identifier (Arg, Name_Casing); | |
668 | ||
669 | if Nkind (Expr) = N_Identifier then | |
670 | if Chars (Expr) = Name_Lowercase then | |
671 | Cas := All_Lower_Case; | |
672 | return; | |
673 | elsif Chars (Expr) = Name_Uppercase then | |
674 | Cas := All_Upper_Case; | |
675 | return; | |
676 | elsif Chars (Expr) = Name_Mixedcase then | |
677 | Cas := Mixed_Case; | |
678 | return; | |
679 | end if; | |
19235870 | 680 | end if; |
19235870 | 681 | |
ed2233dc | 682 | Error_Msg_N |
fbf5a39b AC |
683 | ("Casing argument for pragma% must be " & |
684 | "one of Mixedcase, Lowercase, Uppercase", | |
685 | Arg); | |
686 | end Process_Casing; | |
19235870 | 687 | |
fbf5a39b AC |
688 | ----------------------------- |
689 | -- Process_Dot_Replacement -- | |
690 | ----------------------------- | |
19235870 | 691 | |
fbf5a39b AC |
692 | procedure Process_Dot_Replacement (Arg : Node_Id) is |
693 | begin | |
694 | Check_Required_Identifier (Arg, Name_Dot_Replacement); | |
695 | Dot := Get_String_Argument (Arg); | |
696 | end Process_Dot_Replacement; | |
19235870 | 697 | |
fbf5a39b AC |
698 | -- Start of processing for Source_File_Name and |
699 | -- Source_File_Name_Project pragmas. | |
19235870 RK |
700 | |
701 | begin | |
1b24ada5 | 702 | if Prag_Id = Pragma_Source_File_Name then |
fbf5a39b AC |
703 | if Project_File_In_Use = In_Use then |
704 | Error_Msg | |
705 | ("pragma Source_File_Name cannot be used " & | |
706 | "with a project file", Pragma_Sloc); | |
19235870 | 707 | |
fbf5a39b AC |
708 | else |
709 | Project_File_In_Use := Not_In_Use; | |
710 | end if; | |
19235870 | 711 | |
fbf5a39b AC |
712 | else |
713 | if Project_File_In_Use = Not_In_Use then | |
714 | Error_Msg | |
715 | ("pragma Source_File_Name_Project should only be used " & | |
716 | "with a project file", Pragma_Sloc); | |
fbf5a39b AC |
717 | else |
718 | Project_File_In_Use := In_Use; | |
719 | end if; | |
720 | end if; | |
19235870 | 721 | |
fbf5a39b | 722 | -- We permit from 1 to 3 arguments |
19235870 | 723 | |
fbf5a39b AC |
724 | if Arg_Count not in 1 .. 3 then |
725 | Check_Arg_Count (1); | |
726 | end if; | |
19235870 | 727 | |
fbf5a39b | 728 | Expr1 := Expression (Arg1); |
19235870 | 729 | |
fbf5a39b AC |
730 | -- If first argument is identifier or selected component, then |
731 | -- we have the specific file case of the Source_File_Name pragma, | |
732 | -- and the first argument is a unit name. | |
19235870 | 733 | |
07fc65c4 | 734 | if Nkind (Expr1) = N_Identifier |
fbf5a39b AC |
735 | or else |
736 | (Nkind (Expr1) = N_Selected_Component | |
737 | and then | |
738 | Nkind (Selector_Name (Expr1)) = N_Identifier) | |
07fc65c4 | 739 | then |
fbf5a39b AC |
740 | if Nkind (Expr1) = N_Identifier |
741 | and then Chars (Expr1) = Name_System | |
742 | then | |
743 | Error_Msg_N | |
744 | ("pragma Source_File_Name may not be used for System", | |
745 | Arg1); | |
746 | return Error; | |
747 | end if; | |
07fc65c4 | 748 | |
2820d220 AC |
749 | -- Process index argument if present |
750 | ||
751 | if Arg_Count = 3 then | |
752 | Expr := Expression (Arg3); | |
753 | ||
754 | if Nkind (Expr) /= N_Integer_Literal | |
755 | or else not UI_Is_In_Int_Range (Intval (Expr)) | |
756 | or else Intval (Expr) > 999 | |
757 | or else Intval (Expr) <= 0 | |
758 | then | |
759 | Error_Msg | |
760 | ("pragma% index must be integer literal" & | |
761 | " in range 1 .. 999", Sloc (Expr)); | |
762 | raise Error_Resync; | |
763 | else | |
764 | Index := UI_To_Int (Intval (Expr)); | |
765 | end if; | |
766 | ||
767 | -- No index argument present | |
768 | ||
769 | else | |
770 | Check_Arg_Count (2); | |
771 | Index := 0; | |
772 | end if; | |
19235870 | 773 | |
fbf5a39b AC |
774 | Check_Optional_Identifier (Arg1, Name_Unit_Name); |
775 | Unam := Get_Unit_Name (Expr1); | |
19235870 | 776 | |
fbf5a39b | 777 | Check_Arg_Is_String_Literal (Arg2); |
19235870 | 778 | |
fbf5a39b | 779 | if Chars (Arg2) = Name_Spec_File_Name then |
2820d220 AC |
780 | Set_File_Name |
781 | (Get_Spec_Name (Unam), Get_Fname (Arg2), Index); | |
19235870 | 782 | |
fbf5a39b | 783 | elsif Chars (Arg2) = Name_Body_File_Name then |
2820d220 AC |
784 | Set_File_Name |
785 | (Unam, Get_Fname (Arg2), Index); | |
19235870 | 786 | |
fbf5a39b AC |
787 | else |
788 | Error_Msg_N | |
789 | ("pragma% argument has incorrect identifier", Arg2); | |
790 | return Pragma_Node; | |
791 | end if; | |
19235870 | 792 | |
fbf5a39b AC |
793 | -- If the first argument is not an identifier, then we must have |
794 | -- the pattern form of the pragma, and the first argument must be | |
795 | -- the pattern string with an appropriate name. | |
19235870 | 796 | |
fbf5a39b AC |
797 | else |
798 | if Chars (Arg1) = Name_Spec_File_Name then | |
799 | Typ := 's'; | |
19235870 | 800 | |
fbf5a39b AC |
801 | elsif Chars (Arg1) = Name_Body_File_Name then |
802 | Typ := 'b'; | |
19235870 | 803 | |
fbf5a39b AC |
804 | elsif Chars (Arg1) = Name_Subunit_File_Name then |
805 | Typ := 'u'; | |
19235870 | 806 | |
fbf5a39b AC |
807 | elsif Chars (Arg1) = Name_Unit_Name then |
808 | Error_Msg_N | |
809 | ("Unit_Name parameter for pragma% must be an identifier", | |
810 | Arg1); | |
811 | raise Error_Resync; | |
19235870 | 812 | |
fbf5a39b AC |
813 | else |
814 | Error_Msg_N | |
815 | ("pragma% argument has incorrect identifier", Arg1); | |
816 | raise Error_Resync; | |
817 | end if; | |
19235870 | 818 | |
fbf5a39b | 819 | Pat := Get_String_Argument (Arg1); |
19235870 | 820 | |
fbf5a39b | 821 | -- Check pattern has exactly one asterisk |
19235870 | 822 | |
fbf5a39b AC |
823 | Nast := 0; |
824 | for J in Pat'Range loop | |
825 | if Pat (J) = '*' then | |
826 | Nast := Nast + 1; | |
827 | end if; | |
828 | end loop; | |
19235870 | 829 | |
fbf5a39b AC |
830 | if Nast /= 1 then |
831 | Error_Msg_N | |
832 | ("file name pattern must have exactly one * character", | |
7324bf49 | 833 | Arg1); |
fbf5a39b AC |
834 | return Pragma_Node; |
835 | end if; | |
19235870 | 836 | |
fbf5a39b | 837 | -- Set defaults for Casing and Dot_Separator parameters |
19235870 | 838 | |
fbf5a39b | 839 | Cas := All_Lower_Case; |
fbf5a39b | 840 | Dot := new String'("."); |
19235870 | 841 | |
fbf5a39b | 842 | -- Process second and third arguments if present |
19235870 | 843 | |
fbf5a39b AC |
844 | if Arg_Count > 1 then |
845 | if Chars (Arg2) = Name_Casing then | |
846 | Process_Casing (Arg2); | |
19235870 | 847 | |
fbf5a39b AC |
848 | if Arg_Count = 3 then |
849 | Process_Dot_Replacement (Arg3); | |
850 | end if; | |
19235870 | 851 | |
fbf5a39b AC |
852 | else |
853 | Process_Dot_Replacement (Arg2); | |
19235870 | 854 | |
fbf5a39b AC |
855 | if Arg_Count = 3 then |
856 | Process_Casing (Arg3); | |
857 | end if; | |
19235870 RK |
858 | end if; |
859 | end if; | |
19235870 | 860 | |
fbf5a39b AC |
861 | Set_File_Name_Pattern (Pat, Typ, Dot, Cas); |
862 | end if; | |
863 | end Source_File_Name; | |
19235870 RK |
864 | |
865 | ----------------------------- | |
866 | -- Source_Reference (GNAT) -- | |
867 | ----------------------------- | |
868 | ||
869 | -- pragma Source_Reference | |
870 | -- (INTEGER_LITERAL [, STRING_LITERAL] ); | |
871 | ||
872 | -- Processing for this pragma must be done at parse time, since error | |
873 | -- messages needing the proper line numbers can be generated in parse | |
874 | -- only mode with semantic checking turned off, and indeed we usually | |
875 | -- turn off semantic checking anyway if any parse errors are found. | |
876 | ||
877 | when Pragma_Source_Reference => Source_Reference : declare | |
2fa9443e | 878 | Fname : File_Name_Type; |
19235870 RK |
879 | |
880 | begin | |
881 | if Arg_Count /= 1 then | |
882 | Check_Arg_Count (2); | |
883 | Check_No_Identifier (Arg2); | |
884 | end if; | |
885 | ||
886 | -- Check that this is first line of file. We skip this test if | |
887 | -- we are in syntax check only mode, since we may be dealing with | |
888 | -- multiple compilation units. | |
889 | ||
890 | if Get_Physical_Line_Number (Pragma_Sloc) /= 1 | |
891 | and then Num_SRef_Pragmas (Current_Source_File) = 0 | |
892 | and then Operating_Mode /= Check_Syntax | |
893 | then | |
483c78cb | 894 | Error_Msg -- CODEFIX |
19235870 RK |
895 | ("first % pragma must be first line of file", Pragma_Sloc); |
896 | raise Error_Resync; | |
897 | end if; | |
898 | ||
899 | Check_No_Identifier (Arg1); | |
900 | ||
901 | if Arg_Count = 1 then | |
902 | if Num_SRef_Pragmas (Current_Source_File) = 0 then | |
903 | Error_Msg | |
904 | ("file name required for first % pragma in file", | |
905 | Pragma_Sloc); | |
906 | raise Error_Resync; | |
19235870 | 907 | else |
2fa9443e | 908 | Fname := No_File; |
19235870 RK |
909 | end if; |
910 | ||
911 | -- File name present | |
912 | ||
913 | else | |
914 | Check_Arg_Is_String_Literal (Arg2); | |
915 | String_To_Name_Buffer (Strval (Expression (Arg2))); | |
916 | Fname := Name_Find; | |
917 | ||
918 | if Num_SRef_Pragmas (Current_Source_File) > 0 then | |
919 | if Fname /= Full_Ref_Name (Current_Source_File) then | |
920 | Error_Msg | |
921 | ("file name must be same in all % pragmas", Pragma_Sloc); | |
922 | raise Error_Resync; | |
923 | end if; | |
924 | end if; | |
925 | end if; | |
926 | ||
927 | if Nkind (Expression (Arg1)) /= N_Integer_Literal then | |
928 | Error_Msg | |
929 | ("argument for pragma% must be integer literal", | |
930 | Sloc (Expression (Arg1))); | |
931 | raise Error_Resync; | |
932 | ||
933 | -- OK, this source reference pragma is effective, however, we | |
934 | -- ignore it if it is not in the first unit in the multiple unit | |
935 | -- case. This is because the only purpose in this case is to | |
936 | -- provide source pragmas for subsequent use by gnatchop. | |
937 | ||
938 | else | |
939 | if Num_Library_Units = 1 then | |
940 | Register_Source_Ref_Pragma | |
941 | (Fname, | |
942 | Strip_Directory (Fname), | |
943 | UI_To_Int (Intval (Expression (Arg1))), | |
944 | Get_Physical_Line_Number (Pragma_Sloc) + 1); | |
945 | end if; | |
946 | end if; | |
947 | end Source_Reference; | |
948 | ||
949 | ------------------------- | |
950 | -- Style_Checks (GNAT) -- | |
951 | ------------------------- | |
952 | ||
953 | -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); | |
954 | ||
955 | -- This is processed by the parser since some of the style | |
956 | -- checks take place during source scanning and parsing. | |
957 | ||
958 | when Pragma_Style_Checks => Style_Checks : declare | |
959 | A : Node_Id; | |
960 | S : String_Id; | |
961 | C : Char_Code; | |
962 | OK : Boolean := True; | |
963 | ||
964 | begin | |
965 | -- Two argument case is only for semantics | |
966 | ||
967 | if Arg_Count = 2 then | |
968 | null; | |
969 | ||
970 | else | |
971 | Check_Arg_Count (1); | |
972 | Check_No_Identifier (Arg1); | |
973 | A := Expression (Arg1); | |
974 | ||
975 | if Nkind (A) = N_String_Literal then | |
3cb8344b | 976 | S := Strval (A); |
19235870 RK |
977 | |
978 | declare | |
fbf5a39b | 979 | Slen : constant Natural := Natural (String_Length (S)); |
19235870 | 980 | Options : String (1 .. Slen); |
b3143037 AC |
981 | J : Positive; |
982 | Ptr : Positive; | |
19235870 RK |
983 | |
984 | begin | |
985 | J := 1; | |
986 | loop | |
b3143037 | 987 | C := Get_String_Char (S, Pos (J)); |
19235870 RK |
988 | |
989 | if not In_Character_Range (C) then | |
990 | OK := False; | |
991 | Ptr := J; | |
992 | exit; | |
993 | ||
994 | else | |
995 | Options (J) := Get_Character (C); | |
996 | end if; | |
997 | ||
998 | if J = Slen then | |
42f1d661 AC |
999 | if not Ignore_Style_Checks_Pragmas then |
1000 | Set_Style_Check_Options (Options, OK, Ptr); | |
1001 | end if; | |
1002 | ||
19235870 RK |
1003 | exit; |
1004 | ||
1005 | else | |
1006 | J := J + 1; | |
1007 | end if; | |
1008 | end loop; | |
1009 | ||
1010 | if not OK then | |
1011 | Error_Msg | |
c3217dac | 1012 | (Style_Msg_Buf (1 .. Style_Msg_Len), |
19235870 RK |
1013 | Sloc (Expression (Arg1)) + Source_Ptr (Ptr)); |
1014 | raise Error_Resync; | |
1015 | end if; | |
1016 | end; | |
1017 | ||
1018 | elsif Nkind (A) /= N_Identifier then | |
1019 | OK := False; | |
1020 | ||
1021 | elsif Chars (A) = Name_All_Checks then | |
42f1d661 AC |
1022 | if not Ignore_Style_Checks_Pragmas then |
1023 | if GNAT_Mode then | |
1024 | Stylesw.Set_GNAT_Style_Check_Options; | |
1025 | else | |
1026 | Stylesw.Set_Default_Style_Check_Options; | |
1027 | end if; | |
19d846a0 | 1028 | end if; |
19235870 RK |
1029 | |
1030 | elsif Chars (A) = Name_On then | |
42f1d661 AC |
1031 | if not Ignore_Style_Checks_Pragmas then |
1032 | Style_Check := True; | |
1033 | end if; | |
19235870 RK |
1034 | |
1035 | elsif Chars (A) = Name_Off then | |
42f1d661 AC |
1036 | if not Ignore_Style_Checks_Pragmas then |
1037 | Style_Check := False; | |
1038 | end if; | |
19235870 RK |
1039 | |
1040 | else | |
1041 | OK := False; | |
1042 | end if; | |
1043 | ||
1044 | if not OK then | |
1045 | Error_Msg ("incorrect argument for pragma%", Sloc (A)); | |
1046 | raise Error_Resync; | |
1047 | end if; | |
1048 | end if; | |
1049 | end Style_Checks; | |
1050 | ||
c775c209 AC |
1051 | ------------------------- |
1052 | -- Suppress_All (GNAT) -- | |
1053 | ------------------------- | |
1054 | ||
1055 | -- pragma Suppress_All | |
1056 | ||
1057 | -- This is a rather odd pragma, because other compilers allow it in | |
1058 | -- strange places. DEC allows it at the end of units, and Rational | |
1059 | -- allows it as a program unit pragma, when it would be more natural | |
1060 | -- if it were a configuration pragma. | |
1061 | ||
1062 | -- Since the reason we provide this pragma is for compatibility with | |
308e6f3a | 1063 | -- these other compilers, we want to accommodate these strange placement |
c775c209 AC |
1064 | -- rules, and the easiest thing is simply to allow it anywhere in a |
1065 | -- unit. If this pragma appears anywhere within a unit, then the effect | |
1066 | -- is as though a pragma Suppress (All_Checks) had appeared as the first | |
1067 | -- line of the current file, i.e. as the first configuration pragma in | |
1068 | -- the current unit. | |
1069 | ||
1070 | -- To get this effect, we set the flag Has_Pragma_Suppress_All in the | |
1071 | -- compilation unit node for the current source file then in the last | |
1072 | -- stage of parsing a file, if this flag is set, we materialize the | |
1073 | -- Suppress (All_Checks) pragma, marked as not coming from Source. | |
1074 | ||
1075 | when Pragma_Suppress_All => | |
1076 | Set_Has_Pragma_Suppress_All (Cunit (Current_Source_Unit)); | |
1077 | ||
19235870 RK |
1078 | --------------------- |
1079 | -- Warnings (GNAT) -- | |
1080 | --------------------- | |
1081 | ||
b21d8148 YM |
1082 | -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]); |
1083 | ||
1084 | -- DETAILS ::= On | Off | |
1085 | -- DETAILS ::= On | Off, local_NAME | |
1086 | -- DETAILS ::= static_string_EXPRESSION | |
1087 | -- DETAILS ::= On | Off, static_string_EXPRESSION | |
1088 | ||
1089 | -- TOOL_NAME ::= GNAT | GNATProve | |
6d13d38e YM |
1090 | |
1091 | -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL} | |
19235870 | 1092 | |
b21d8148 YM |
1093 | -- Note: If the first argument matches an allowed tool name, it is |
1094 | -- always considered to be a tool name, even if there is a string | |
1095 | -- variable of that name. | |
1096 | ||
b47efa93 ES |
1097 | -- The one argument ON/OFF case is processed by the parser, since it may |
1098 | -- control parser warnings as well as semantic warnings, and in any case | |
1099 | -- we want to be absolutely sure that the range in the warnings table is | |
cca5ded0 AC |
1100 | -- set well before any semantic analysis is performed. Note that we |
1101 | -- ignore this pragma if debug flag -gnatd.i is set. | |
19235870 | 1102 | |
6d13d38e YM |
1103 | -- Also note that the "one argument" case may have two or three |
1104 | -- arguments if the first one is a tool name, and/or the last one is a | |
1105 | -- reason argument. | |
bbee5cc4 | 1106 | |
6d13d38e YM |
1107 | when Pragma_Warnings => Warnings : declare |
1108 | function First_Arg_Is_Matching_Tool_Name return Boolean; | |
1109 | -- Returns True if the first argument is a tool name matching the | |
1110 | -- current tool being run. | |
0c7e0c32 | 1111 | |
6d13d38e YM |
1112 | function Last_Arg return Node_Id; |
1113 | -- Returns the last argument | |
0c7e0c32 | 1114 | |
6d13d38e YM |
1115 | function Last_Arg_Is_Reason return Boolean; |
1116 | -- Returns True if the last argument is a reason argument | |
0c7e0c32 | 1117 | |
6d13d38e YM |
1118 | function Get_Reason return String_Id; |
1119 | -- Analyzes Reason argument and returns corresponding String_Id | |
1120 | -- value, or null if there is no Reason argument, or if the | |
1121 | -- argument is not of the required form. | |
0c7e0c32 | 1122 | |
6d13d38e YM |
1123 | ------------------------------------- |
1124 | -- First_Arg_Is_Matching_Tool_Name -- | |
1125 | ------------------------------------- | |
1126 | ||
6d13d38e YM |
1127 | function First_Arg_Is_Matching_Tool_Name return Boolean is |
1128 | begin | |
1129 | return Nkind (Arg1) = N_Identifier | |
b21d8148 YM |
1130 | |
1131 | -- Return True if the tool name is GNAT, and we're not in | |
1132 | -- GNATprove or CodePeer or ASIS mode... | |
1133 | ||
6d13d38e YM |
1134 | and then ((Chars (Arg1) = Name_Gnat |
1135 | and then not | |
1136 | (CodePeer_Mode or GNATprove_Mode or ASIS_Mode)) | |
b21d8148 YM |
1137 | |
1138 | -- or if the tool name is GNATprove, and we're in GNATprove | |
1139 | -- mode. | |
1140 | ||
6d13d38e YM |
1141 | or else |
1142 | (Chars (Arg1) = Name_Gnatprove | |
1143 | and then GNATprove_Mode)); | |
1144 | end First_Arg_Is_Matching_Tool_Name; | |
1145 | ||
1146 | ---------------- | |
1147 | -- Get_Reason -- | |
1148 | ---------------- | |
1149 | ||
1150 | function Get_Reason return String_Id is | |
1151 | Arg : constant Node_Id := Last_Arg; | |
1152 | begin | |
1153 | if Last_Arg_Is_Reason then | |
1154 | Start_String; | |
1155 | Get_Reason_String (Expression (Arg)); | |
1156 | return End_String; | |
1157 | else | |
1158 | return Null_String_Id; | |
1159 | end if; | |
1160 | end Get_Reason; | |
1161 | ||
1162 | -------------- | |
1163 | -- Last_Arg -- | |
1164 | -------------- | |
1165 | ||
1166 | function Last_Arg return Node_Id is | |
1167 | Last_Arg : Node_Id; | |
1168 | ||
1169 | begin | |
1170 | if Arg_Count = 1 then | |
1171 | Last_Arg := Arg1; | |
1172 | elsif Arg_Count = 2 then | |
1173 | Last_Arg := Arg2; | |
1174 | elsif Arg_Count = 3 then | |
1175 | Last_Arg := Arg3; | |
1176 | elsif Arg_Count = 4 then | |
1177 | Last_Arg := Next (Arg3); | |
1178 | ||
1179 | -- Illegal case, error issued in semantic analysis | |
1180 | ||
1181 | else | |
1182 | Last_Arg := Empty; | |
1183 | end if; | |
1184 | ||
1185 | return Last_Arg; | |
1186 | end Last_Arg; | |
1187 | ||
1188 | ------------------------ | |
1189 | -- Last_Arg_Is_Reason -- | |
1190 | ------------------------ | |
1191 | ||
1192 | function Last_Arg_Is_Reason return Boolean is | |
1193 | Arg : constant Node_Id := Last_Arg; | |
1194 | begin | |
1195 | return Nkind (Arg) in N_Has_Chars | |
1196 | and then Chars (Arg) = Name_Reason; | |
1197 | end Last_Arg_Is_Reason; | |
1198 | ||
1199 | The_Arg : Node_Id; -- On/Off argument | |
1200 | Argx : Node_Id; | |
1201 | ||
1202 | -- Start of processing for Warnings | |
1203 | ||
1204 | begin | |
1205 | if not Debug_Flag_Dot_I | |
1206 | and then (Arg_Count = 1 | |
1207 | or else (Arg_Count = 2 | |
1208 | and then (First_Arg_Is_Matching_Tool_Name | |
1209 | or else | |
1210 | Last_Arg_Is_Reason)) | |
1211 | or else (Arg_Count = 3 | |
1212 | and then First_Arg_Is_Matching_Tool_Name | |
1213 | and then Last_Arg_Is_Reason)) | |
1214 | then | |
1215 | if First_Arg_Is_Matching_Tool_Name then | |
1216 | The_Arg := Arg2; | |
1217 | else | |
1218 | The_Arg := Arg1; | |
1219 | end if; | |
1220 | ||
1221 | Check_No_Identifier (The_Arg); | |
1222 | Argx := Expression (The_Arg); | |
1223 | ||
1224 | if Nkind (Argx) = N_Identifier then | |
1225 | if Chars (Argx) = Name_On then | |
1226 | Set_Warnings_Mode_On (Pragma_Sloc); | |
1227 | elsif Chars (Argx) = Name_Off then | |
1228 | Set_Warnings_Mode_Off (Pragma_Sloc, Get_Reason); | |
b47efa93 | 1229 | end if; |
6d13d38e | 1230 | end if; |
19235870 | 1231 | end if; |
6d13d38e | 1232 | end Warnings; |
19235870 | 1233 | |
3cb8344b RD |
1234 | ----------------------------- |
1235 | -- Wide_Character_Encoding -- | |
1236 | ----------------------------- | |
1237 | ||
1238 | -- pragma Wide_Character_Encoding (IDENTIFIER | CHARACTER_LITERAL); | |
1239 | ||
1240 | -- This is processed by the parser, since the scanner is affected | |
1241 | ||
1242 | when Pragma_Wide_Character_Encoding => Wide_Character_Encoding : declare | |
1243 | A : Node_Id; | |
1244 | ||
1245 | begin | |
1246 | Check_Arg_Count (1); | |
1247 | Check_No_Identifier (Arg1); | |
1248 | A := Expression (Arg1); | |
1249 | ||
1250 | if Nkind (A) = N_Identifier then | |
1251 | Get_Name_String (Chars (A)); | |
1252 | Wide_Character_Encoding_Method := | |
1253 | Get_WC_Encoding_Method (Name_Buffer (1 .. Name_Len)); | |
1254 | ||
1255 | elsif Nkind (A) = N_Character_Literal then | |
1256 | declare | |
1257 | R : constant Char_Code := | |
1258 | Char_Code (UI_To_Int (Char_Literal_Value (A))); | |
1259 | begin | |
1260 | if In_Character_Range (R) then | |
1261 | Wide_Character_Encoding_Method := | |
1262 | Get_WC_Encoding_Method (Get_Character (R)); | |
1263 | else | |
1264 | raise Constraint_Error; | |
1265 | end if; | |
1266 | end; | |
1267 | ||
1268 | else | |
470cd9e9 | 1269 | raise Constraint_Error; |
3cb8344b RD |
1270 | end if; |
1271 | ||
60e435fe RD |
1272 | Upper_Half_Encoding := |
1273 | Wide_Character_Encoding_Method in | |
1274 | WC_Upper_Half_Encoding_Method; | |
1275 | ||
3cb8344b RD |
1276 | exception |
1277 | when Constraint_Error => | |
1278 | Error_Msg_N ("invalid argument for pragma%", Arg1); | |
1279 | end Wide_Character_Encoding; | |
1280 | ||
19235870 RK |
1281 | ----------------------- |
1282 | -- All Other Pragmas -- | |
1283 | ----------------------- | |
1284 | ||
1285 | -- For all other pragmas, checking and processing is handled | |
1286 | -- entirely in Sem_Prag, and no further checking is done by Par. | |
1287 | ||
12b4d338 | 1288 | when Pragma_Abort_Defer | |
cf6956bb | 1289 | Pragma_Abstract_State | |
6c3c671e AC |
1290 | Pragma_Async_Readers | |
1291 | Pragma_Async_Writers | | |
12b4d338 | 1292 | Pragma_Assertion_Policy | |
1c66c4f5 | 1293 | Pragma_Assume | |
12b4d338 | 1294 | Pragma_Assume_No_Invalid_Values | |
12b4d338 | 1295 | Pragma_All_Calls_Remote | |
818b578d | 1296 | Pragma_Allow_Integer_Address | |
12b4d338 AC |
1297 | Pragma_Annotate | |
1298 | Pragma_Assert | | |
9c79f208 | 1299 | Pragma_Assert_And_Cut | |
12b4d338 AC |
1300 | Pragma_Asynchronous | |
1301 | Pragma_Atomic | | |
1302 | Pragma_Atomic_Components | | |
1303 | Pragma_Attach_Handler | | |
2d7b3fa4 | 1304 | Pragma_Attribute_Definition | |
12b4d338 | 1305 | Pragma_Check | |
347c766a | 1306 | Pragma_Check_Float_Overflow | |
12b4d338 AC |
1307 | Pragma_Check_Name | |
1308 | Pragma_Check_Policy | | |
12b4d338 AC |
1309 | Pragma_Compile_Time_Error | |
1310 | Pragma_Compile_Time_Warning | | |
1df7c326 | 1311 | Pragma_Constant_After_Elaboration | |
570104df | 1312 | Pragma_Contract_Cases | |
12b4d338 AC |
1313 | Pragma_Convention_Identifier | |
1314 | Pragma_CPP_Class | | |
1315 | Pragma_CPP_Constructor | | |
1316 | Pragma_CPP_Virtual | | |
1317 | Pragma_CPP_Vtable | | |
1318 | Pragma_CPU | | |
1319 | Pragma_C_Pass_By_Copy | | |
1320 | Pragma_Comment | | |
1321 | Pragma_Common_Object | | |
1322 | Pragma_Complete_Representation | | |
1323 | Pragma_Complex_Representation | | |
1324 | Pragma_Component_Alignment | | |
1325 | Pragma_Controlled | | |
1326 | Pragma_Convention | | |
1327 | Pragma_Debug_Policy | | |
fe96ecb9 | 1328 | Pragma_Depends | |
12b4d338 | 1329 | Pragma_Detect_Blocking | |
e477d718 | 1330 | Pragma_Default_Initial_Condition | |
39678b1c | 1331 | Pragma_Default_Scalar_Storage_Order | |
12b4d338 | 1332 | Pragma_Default_Storage_Pool | |
12b4d338 AC |
1333 | Pragma_Disable_Atomic_Synchronization | |
1334 | Pragma_Discard_Names | | |
1335 | Pragma_Dispatching_Domain | | |
6c3c671e AC |
1336 | Pragma_Effective_Reads | |
1337 | Pragma_Effective_Writes | | |
12b4d338 AC |
1338 | Pragma_Eliminate | |
1339 | Pragma_Elaborate | | |
1340 | Pragma_Elaborate_All | | |
1341 | Pragma_Elaborate_Body | | |
1342 | Pragma_Elaboration_Checks | | |
1343 | Pragma_Enable_Atomic_Synchronization | | |
1344 | Pragma_Export | | |
12b4d338 AC |
1345 | Pragma_Export_Function | |
1346 | Pragma_Export_Object | | |
1347 | Pragma_Export_Procedure | | |
1348 | Pragma_Export_Value | | |
1349 | Pragma_Export_Valued_Procedure | | |
1350 | Pragma_Extend_System | | |
039538bc | 1351 | Pragma_Extensions_Visible | |
12b4d338 AC |
1352 | Pragma_External | |
1353 | Pragma_External_Name_Casing | | |
1354 | Pragma_Favor_Top_Level | | |
1355 | Pragma_Fast_Math | | |
1356 | Pragma_Finalize_Storage_Only | | |
c5cec2fe | 1357 | Pragma_Ghost | |
7a1f1775 | 1358 | Pragma_Global | |
12b4d338 AC |
1359 | Pragma_Ident | |
1360 | Pragma_Implementation_Defined | | |
1361 | Pragma_Implemented | | |
1362 | Pragma_Implicit_Packing | | |
1363 | Pragma_Import | | |
12b4d338 AC |
1364 | Pragma_Import_Function | |
1365 | Pragma_Import_Object | | |
1366 | Pragma_Import_Procedure | | |
1367 | Pragma_Import_Valued_Procedure | | |
1368 | Pragma_Independent | | |
1369 | Pragma_Independent_Components | | |
9b2451e5 | 1370 | Pragma_Initial_Condition | |
12b4d338 | 1371 | Pragma_Initialize_Scalars | |
54e28df2 | 1372 | Pragma_Initializes | |
12b4d338 AC |
1373 | Pragma_Inline | |
1374 | Pragma_Inline_Always | | |
1375 | Pragma_Inline_Generic | | |
1376 | Pragma_Inspection_Point | | |
1377 | Pragma_Interface | | |
1378 | Pragma_Interface_Name | | |
1379 | Pragma_Interrupt_Handler | | |
1380 | Pragma_Interrupt_State | | |
1381 | Pragma_Interrupt_Priority | | |
1382 | Pragma_Invariant | | |
12b4d338 AC |
1383 | Pragma_Keep_Names | |
1384 | Pragma_License | | |
1385 | Pragma_Link_With | | |
1386 | Pragma_Linker_Alias | | |
1387 | Pragma_Linker_Constructor | | |
1388 | Pragma_Linker_Destructor | | |
1389 | Pragma_Linker_Options | | |
1390 | Pragma_Linker_Section | | |
2a290fec | 1391 | Pragma_Lock_Free | |
12b4d338 | 1392 | Pragma_Locking_Policy | |
5e29ae82 | 1393 | Pragma_Loop_Invariant | |
a75ea295 | 1394 | Pragma_Loop_Optimize | |
5e29ae82 | 1395 | Pragma_Loop_Variant | |
12b4d338 AC |
1396 | Pragma_Machine_Attribute | |
1397 | Pragma_Main | | |
1398 | Pragma_Main_Storage | | |
442d1abb | 1399 | Pragma_Max_Queue_Length | |
12b4d338 AC |
1400 | Pragma_Memory_Size | |
1401 | Pragma_No_Body | | |
4887624e | 1402 | Pragma_No_Elaboration_Code_All | |
42ae3870 | 1403 | Pragma_No_Inline | |
12b4d338 AC |
1404 | Pragma_No_Return | |
1405 | Pragma_No_Run_Time | | |
1406 | Pragma_No_Strict_Aliasing | | |
49d41397 | 1407 | Pragma_No_Tagged_Streams | |
12b4d338 AC |
1408 | Pragma_Normalize_Scalars | |
1409 | Pragma_Obsolescent | | |
1410 | Pragma_Ordered | | |
1411 | Pragma_Optimize | | |
1412 | Pragma_Optimize_Alignment | | |
15c94a55 | 1413 | Pragma_Overflow_Mode | |
9b7424a7 | 1414 | Pragma_Overriding_Renamings | |
12b4d338 | 1415 | Pragma_Pack | |
d7af5ea5 | 1416 | Pragma_Part_Of | |
54f471f0 | 1417 | Pragma_Partition_Elaboration_Policy | |
12b4d338 AC |
1418 | Pragma_Passive | |
1419 | Pragma_Preelaborable_Initialization | | |
1420 | Pragma_Polling | | |
8f819471 | 1421 | Pragma_Prefix_Exception_Messages | |
12b4d338 | 1422 | Pragma_Persistent_BSS | |
ff7a7e12 | 1423 | Pragma_Post | |
12b4d338 | 1424 | Pragma_Postcondition | |
ff7a7e12 RD |
1425 | Pragma_Post_Class | |
1426 | Pragma_Pre | | |
12b4d338 AC |
1427 | Pragma_Precondition | |
1428 | Pragma_Predicate | | |
a2c314c7 | 1429 | Pragma_Predicate_Failure | |
12b4d338 | 1430 | Pragma_Preelaborate | |
ff7a7e12 | 1431 | Pragma_Pre_Class | |
12b4d338 AC |
1432 | Pragma_Priority | |
1433 | Pragma_Priority_Specific_Dispatching | | |
1434 | Pragma_Profile | | |
1435 | Pragma_Profile_Warnings | | |
1436 | Pragma_Propagate_Exceptions | | |
4c51ff88 | 1437 | Pragma_Provide_Shift_Operators | |
12b4d338 AC |
1438 | Pragma_Psect_Object | |
1439 | Pragma_Pure | | |
12b4d338 AC |
1440 | Pragma_Pure_Function | |
1441 | Pragma_Queuing_Policy | | |
ea3c0651 AC |
1442 | Pragma_Refined_Depends | |
1443 | Pragma_Refined_Global | | |
e7f23f06 | 1444 | Pragma_Refined_Post | |
39af2bac | 1445 | Pragma_Refined_State | |
12b4d338 | 1446 | Pragma_Relative_Deadline | |
25081892 | 1447 | Pragma_Remote_Access_Type | |
12b4d338 AC |
1448 | Pragma_Remote_Call_Interface | |
1449 | Pragma_Remote_Types | | |
1450 | Pragma_Restricted_Run_Time | | |
c91dbd18 | 1451 | Pragma_Rational | |
12b4d338 | 1452 | Pragma_Ravenscar | |
ffa168bc | 1453 | Pragma_Rename_Pragma | |
12b4d338 | 1454 | Pragma_Reviewable | |
73bfca78 | 1455 | Pragma_Secondary_Stack_Size | |
12b4d338 AC |
1456 | Pragma_Share_Generic | |
1457 | Pragma_Shared | | |
1458 | Pragma_Shared_Passive | | |
1459 | Pragma_Short_Circuit_And_Or | | |
1460 | Pragma_Short_Descriptors | | |
f6205414 | 1461 | Pragma_Simple_Storage_Pool_Type | |
1c6269d3 | 1462 | Pragma_SPARK_Mode | |
12b4d338 AC |
1463 | Pragma_Storage_Size | |
1464 | Pragma_Storage_Unit | | |
1465 | Pragma_Static_Elaboration_Desired | | |
1466 | Pragma_Stream_Convert | | |
1467 | Pragma_Subtitle | | |
1468 | Pragma_Suppress | | |
1469 | Pragma_Suppress_Debug_Info | | |
1470 | Pragma_Suppress_Exception_Locations | | |
1471 | Pragma_Suppress_Initialization | | |
1472 | Pragma_System_Name | | |
1473 | Pragma_Task_Dispatching_Policy | | |
1474 | Pragma_Task_Info | | |
1475 | Pragma_Task_Name | | |
1476 | Pragma_Task_Storage | | |
1477 | Pragma_Test_Case | | |
1478 | Pragma_Thread_Local_Storage | | |
1479 | Pragma_Time_Slice | | |
1480 | Pragma_Title | | |
577ee3a9 AC |
1481 | Pragma_Type_Invariant | |
1482 | Pragma_Type_Invariant_Class | | |
12b4d338 | 1483 | Pragma_Unchecked_Union | |
96e90ac1 | 1484 | Pragma_Unevaluated_Use_Of_Old | |
12b4d338 AC |
1485 | Pragma_Unimplemented_Unit | |
1486 | Pragma_Universal_Aliasing | | |
1487 | Pragma_Universal_Data | | |
1488 | Pragma_Unmodified | | |
1489 | Pragma_Unreferenced | | |
1490 | Pragma_Unreferenced_Objects | | |
1491 | Pragma_Unreserve_All_Interrupts | | |
1492 | Pragma_Unsuppress | | |
9d1d00ca | 1493 | Pragma_Unused | |
12b4d338 AC |
1494 | Pragma_Use_VADS_Size | |
1495 | Pragma_Volatile | | |
1496 | Pragma_Volatile_Components | | |
c8d3b4ff | 1497 | Pragma_Volatile_Full_Access | |
847d950d | 1498 | Pragma_Volatile_Function | |
0c3985a9 | 1499 | Pragma_Warning_As_Error | |
12b4d338 AC |
1500 | Pragma_Weak_External | |
1501 | Pragma_Validity_Checks => | |
19235870 RK |
1502 | null; |
1503 | ||
fbf5a39b AC |
1504 | -------------------- |
1505 | -- Unknown_Pragma -- | |
1506 | -------------------- | |
1507 | ||
1508 | -- Should be impossible, since we excluded this case earlier on | |
1509 | ||
1510 | when Unknown_Pragma => | |
1511 | raise Program_Error; | |
1512 | ||
19235870 RK |
1513 | end case; |
1514 | ||
1515 | return Pragma_Node; | |
1516 | ||
1517 | -------------------- | |
1518 | -- Error Handling -- | |
1519 | -------------------- | |
1520 | ||
1521 | exception | |
1522 | when Error_Resync => | |
1523 | return Error; | |
1524 | ||
1525 | end Prag; |