]>
Commit | Line | Data |
---|---|---|
19235870 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- P A R . C H 1 0 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1992-2020, 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. -- | |
19235870 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. -- |
19235870 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | pragma Style_Checks (All_Checks); | |
27 | -- Turn off subprogram body ordering check. Subprograms are in order | |
28 | -- by RM section rather than alphabetical | |
29 | ||
19235870 | 30 | with Fname.UF; use Fname.UF; |
19235870 RK |
31 | with Uname; use Uname; |
32 | ||
33 | separate (Par) | |
34 | package body Ch10 is | |
35 | ||
36 | -- Local functions, used only in this chapter | |
37 | ||
38 | function P_Context_Clause return List_Id; | |
39 | function P_Subunit return Node_Id; | |
40 | ||
41 | function Set_Location return Source_Ptr; | |
42 | -- The current compilation unit starts with Token at Token_Ptr. This | |
43 | -- function determines the corresponding source location for the start | |
44 | -- of the unit, including any preceding comment lines. | |
45 | ||
46 | procedure Unit_Display | |
47 | (Cunit : Node_Id; | |
48 | Loc : Source_Ptr; | |
49 | SR_Present : Boolean); | |
dec55d76 | 50 | -- This procedure is used to generate a line of output for a unit in |
19235870 RK |
51 | -- the source program. Cunit is the node for the compilation unit, and |
52 | -- Loc is the source location for the start of the unit in the source | |
53 | -- file (which is not necessarily the Sloc of the Cunit node). This | |
54 | -- output is written to the standard output file for use by gnatchop. | |
55 | ||
56 | procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr); | |
57 | -- This routine has the same calling sequence as Unit_Display, but | |
58 | -- it outputs only the line number and offset of the location, Loc, | |
59 | -- using Cunit to obtain the proper source file index. | |
60 | ||
61 | ------------------------- | |
62 | -- 10.1.1 Compilation -- | |
63 | ------------------------- | |
64 | ||
65 | -- COMPILATION ::= {COMPILATION_UNIT} | |
66 | ||
67 | -- There is no specific parsing routine for a compilation, since we only | |
68 | -- permit a single compilation in a source file, so there is no explicit | |
69 | -- occurrence of compilations as such (our representation of a compilation | |
70 | -- is a series of separate source files). | |
71 | ||
72 | ------------------------------ | |
73 | -- 10.1.1 Compilation unit -- | |
74 | ------------------------------ | |
75 | ||
76 | -- COMPILATION_UNIT ::= | |
77 | -- CONTEXT_CLAUSE LIBRARY_ITEM | |
78 | -- | CONTEXT_CLAUSE SUBUNIT | |
79 | ||
80 | -- LIBRARY_ITEM ::= | |
81 | -- private LIBRARY_UNIT_DECLARATION | |
82 | -- | LIBRARY_UNIT_BODY | |
83 | -- | [private] LIBRARY_UNIT_RENAMING_DECLARATION | |
84 | ||
85 | -- LIBRARY_UNIT_DECLARATION ::= | |
86 | -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION | |
87 | -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION | |
88 | ||
89 | -- LIBRARY_UNIT_RENAMING_DECLARATION ::= | |
90 | -- PACKAGE_RENAMING_DECLARATION | |
91 | -- | GENERIC_RENAMING_DECLARATION | |
92 | -- | SUBPROGRAM_RENAMING_DECLARATION | |
93 | ||
94 | -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY | |
95 | ||
96 | -- Error recovery: cannot raise Error_Resync. If an error occurs, tokens | |
97 | -- are skipped up to the next possible beginning of a compilation unit. | |
98 | ||
99 | -- Note: if only configuration pragmas are found, Empty is returned | |
100 | ||
101 | -- Note: in syntax-only mode, it is possible for P_Compilation_Unit | |
102 | -- to return strange things that are not really compilation units. | |
103 | -- This is done to help out gnatchop when it is faced with nonsense. | |
104 | ||
105 | function P_Compilation_Unit return Node_Id is | |
106 | Scan_State : Saved_Scan_State; | |
107 | Body_Node : Node_Id; | |
108 | Specification_Node : Node_Id; | |
109 | Unit_Node : Node_Id; | |
110 | Comp_Unit_Node : Node_Id; | |
111 | Name_Node : Node_Id; | |
112 | Item : Node_Id; | |
113 | Private_Sloc : Source_Ptr := No_Location; | |
114 | Config_Pragmas : List_Id; | |
115 | P : Node_Id; | |
116 | SR_Present : Boolean; | |
1f250383 | 117 | No_Body : Boolean; |
19235870 | 118 | |
fbe0e1ad | 119 | Cunit_Error_Flag : Boolean := False; |
19235870 RK |
120 | -- This flag is set True if we have to scan for a compilation unit |
121 | -- token. It is used to ensure clean termination in such cases by | |
dec55d76 | 122 | -- not insisting on being at the end of file, and, in the syntax only |
19235870 RK |
123 | -- case by not scanning for additional compilation units. |
124 | ||
125 | Cunit_Location : Source_Ptr; | |
126 | -- Location of unit for unit identification output (List_Unit option) | |
127 | ||
128 | begin | |
129 | Num_Library_Units := Num_Library_Units + 1; | |
130 | ||
131 | -- Set location of the compilation unit if unit list option set | |
132 | -- and we are in syntax check only mode | |
133 | ||
134 | if List_Units and then Operating_Mode = Check_Syntax then | |
135 | Cunit_Location := Set_Location; | |
136 | else | |
137 | Cunit_Location := No_Location; | |
138 | end if; | |
139 | ||
140 | -- Deal with initial pragmas | |
141 | ||
142 | Config_Pragmas := No_List; | |
143 | ||
fbe0e1ad RD |
144 | -- If we have an initial Source_Reference pragma, then remember the fact |
145 | -- to generate an NR parameter in the output line. | |
19235870 RK |
146 | |
147 | SR_Present := False; | |
148 | ||
1f250383 AC |
149 | -- If we see a pragma No_Body, remember not to complain about no body |
150 | ||
151 | No_Body := False; | |
152 | ||
19235870 RK |
153 | if Token = Tok_Pragma then |
154 | Save_Scan_State (Scan_State); | |
155 | Item := P_Pragma; | |
156 | ||
157 | if Item = Error | |
6e759c2a | 158 | or else Pragma_Name_Unmapped (Item) /= Name_Source_Reference |
19235870 RK |
159 | then |
160 | Restore_Scan_State (Scan_State); | |
161 | ||
162 | else | |
163 | SR_Present := True; | |
164 | ||
165 | -- If first unit, record the file name for gnatchop use | |
166 | ||
167 | if Operating_Mode = Check_Syntax | |
168 | and then List_Units | |
169 | and then Num_Library_Units = 1 | |
170 | then | |
171 | Write_Str ("Source_Reference pragma for file """); | |
172 | Write_Name (Full_Ref_Name (Current_Source_File)); | |
173 | Write_Char ('"'); | |
174 | Write_Eol; | |
175 | end if; | |
176 | ||
177 | Config_Pragmas := New_List (Item); | |
178 | end if; | |
179 | end if; | |
180 | ||
181 | -- Scan out any configuration pragmas | |
182 | ||
183 | while Token = Tok_Pragma loop | |
184 | Save_Scan_State (Scan_State); | |
185 | Item := P_Pragma; | |
186 | ||
6e759c2a BD |
187 | if Item /= Error and then Pragma_Name_Unmapped (Item) = Name_No_Body |
188 | then | |
1f250383 AC |
189 | No_Body := True; |
190 | end if; | |
191 | ||
19235870 | 192 | if Item = Error |
6e759c2a BD |
193 | or else |
194 | not Is_Configuration_Pragma_Name (Pragma_Name_Unmapped (Item)) | |
19235870 RK |
195 | then |
196 | Restore_Scan_State (Scan_State); | |
197 | exit; | |
198 | end if; | |
199 | ||
200 | if Config_Pragmas = No_List then | |
201 | Config_Pragmas := Empty_List; | |
202 | ||
203 | if Operating_Mode = Check_Syntax and then List_Units then | |
204 | Write_Str ("Configuration pragmas at"); | |
205 | Unit_Location (Current_Source_File, Cunit_Location); | |
206 | Write_Eol; | |
207 | end if; | |
208 | end if; | |
209 | ||
210 | Append (Item, Config_Pragmas); | |
211 | Cunit_Location := Set_Location; | |
212 | end loop; | |
213 | ||
214 | -- Establish compilation unit node and scan context items | |
215 | ||
216 | Comp_Unit_Node := New_Node (N_Compilation_Unit, No_Location); | |
217 | Set_Cunit (Current_Source_Unit, Comp_Unit_Node); | |
218 | Set_Context_Items (Comp_Unit_Node, P_Context_Clause); | |
219 | Set_Aux_Decls_Node | |
220 | (Comp_Unit_Node, New_Node (N_Compilation_Unit_Aux, No_Location)); | |
221 | ||
222 | if Present (Config_Pragmas) then | |
223 | ||
224 | -- Check for case of only configuration pragmas present | |
225 | ||
226 | if Token = Tok_EOF | |
227 | and then Is_Empty_List (Context_Items (Comp_Unit_Node)) | |
228 | then | |
229 | if Operating_Mode = Check_Syntax then | |
230 | return Empty; | |
231 | ||
232 | else | |
233 | Item := First (Config_Pragmas); | |
234 | Error_Msg_N | |
aae02e6a | 235 | ("cannot compile configuration pragmas with gcc!", Item); |
19235870 | 236 | Error_Msg_N |
aae02e6a | 237 | ("\use gnatchop -c to process configuration pragmas!", Item); |
19235870 RK |
238 | raise Unrecoverable_Error; |
239 | end if; | |
240 | ||
241 | -- Otherwise configuration pragmas are simply prepended to the | |
242 | -- context of the current unit. | |
243 | ||
244 | else | |
245 | Append_List (Context_Items (Comp_Unit_Node), Config_Pragmas); | |
246 | Set_Context_Items (Comp_Unit_Node, Config_Pragmas); | |
247 | end if; | |
248 | end if; | |
249 | ||
250 | -- Check for PRIVATE. Note that for the moment we allow this in | |
251 | -- Ada_83 mode, since we do not yet know if we are compiling a | |
252 | -- predefined unit, and if we are then it would be allowed anyway. | |
253 | ||
254 | if Token = Tok_Private then | |
255 | Private_Sloc := Token_Ptr; | |
256 | Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); | |
8aaeba8f | 257 | |
835d23b2 RD |
258 | if Style_Check then |
259 | Style.Check_Indentation; | |
260 | end if; | |
19235870 RK |
261 | |
262 | Save_Scan_State (Scan_State); -- at PRIVATE | |
263 | Scan; -- past PRIVATE | |
264 | ||
265 | if Token = Tok_Separate then | |
266 | Error_Msg_SP ("cannot have private subunits!"); | |
267 | ||
268 | elsif Token = Tok_Package then | |
269 | Scan; -- past PACKAGE | |
270 | ||
271 | if Token = Tok_Body then | |
272 | Restore_Scan_State (Scan_State); -- to PRIVATE | |
273 | Error_Msg_SC ("cannot have private package body!"); | |
274 | Scan; -- ignore PRIVATE | |
275 | ||
276 | else | |
277 | Restore_Scan_State (Scan_State); -- to PRIVATE | |
278 | Scan; -- past PRIVATE | |
279 | Set_Private_Present (Comp_Unit_Node, True); | |
280 | end if; | |
281 | ||
282 | elsif Token = Tok_Procedure | |
283 | or else Token = Tok_Function | |
284 | or else Token = Tok_Generic | |
285 | then | |
286 | Set_Private_Present (Comp_Unit_Node, True); | |
287 | end if; | |
288 | end if; | |
289 | ||
290 | -- Loop to find our way to a compilation unit token | |
291 | ||
292 | loop | |
293 | exit when Token in Token_Class_Cunit and then Token /= Tok_With; | |
294 | ||
295 | exit when Bad_Spelling_Of (Tok_Package) | |
296 | or else Bad_Spelling_Of (Tok_Function) | |
297 | or else Bad_Spelling_Of (Tok_Generic) | |
298 | or else Bad_Spelling_Of (Tok_Separate) | |
299 | or else Bad_Spelling_Of (Tok_Procedure); | |
300 | ||
301 | -- Allow task and protected for nice error recovery purposes | |
302 | ||
303 | exit when Token = Tok_Task | |
304 | or else Token = Tok_Protected; | |
305 | ||
306 | if Token = Tok_With then | |
307 | Error_Msg_SC ("misplaced WITH"); | |
308 | Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node)); | |
309 | ||
310 | elsif Bad_Spelling_Of (Tok_With) then | |
311 | Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node)); | |
312 | ||
313 | else | |
d05ef0ab | 314 | if Operating_Mode = Check_Syntax and then Token = Tok_EOF then |
1f250383 AC |
315 | |
316 | -- Do not complain if there is a pragma No_Body | |
317 | ||
318 | if not No_Body then | |
685bc70f | 319 | Error_Msg_SC ("??file contains no compilation units"); |
1f250383 | 320 | end if; |
685bc70f | 321 | |
d05ef0ab AC |
322 | else |
323 | Error_Msg_SC ("compilation unit expected"); | |
324 | Cunit_Error_Flag := True; | |
325 | Resync_Cunit; | |
326 | end if; | |
19235870 RK |
327 | |
328 | -- If we are at an end of file, then just quit, the above error | |
329 | -- message was complaint enough. | |
330 | ||
331 | if Token = Tok_EOF then | |
332 | return Error; | |
333 | end if; | |
334 | end if; | |
335 | end loop; | |
336 | ||
337 | -- We have a compilation unit token, so that's a reasonable choice for | |
338 | -- determining the standard casing convention used for keywords in case | |
339 | -- it hasn't already been done on seeing a WITH or PRIVATE. | |
340 | ||
341 | Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); | |
8aaeba8f | 342 | |
835d23b2 RD |
343 | if Style_Check then |
344 | Style.Check_Indentation; | |
345 | end if; | |
19235870 RK |
346 | |
347 | -- Remaining processing depends on particular type of compilation unit | |
348 | ||
349 | if Token = Tok_Package then | |
350 | ||
351 | -- A common error is to omit the body keyword after package. We can | |
352 | -- often diagnose this early on (before getting loads of errors from | |
16b05213 | 353 | -- contained subprogram bodies), by knowing that the file we |
19235870 RK |
354 | -- are compiling has a name that requires a body to be found. |
355 | ||
19235870 RK |
356 | Save_Scan_State (Scan_State); |
357 | Scan; -- past Package keyword | |
358 | ||
359 | if Token /= Tok_Body | |
19235870 RK |
360 | and then |
361 | Get_Expected_Unit_Type | |
362 | (File_Name (Current_Source_File)) = Expect_Body | |
363 | then | |
ed2233dc | 364 | Error_Msg_BC -- CODEFIX |
a736f6e6 | 365 | ("keyword BODY expected here '[see file name']"); |
19235870 | 366 | Restore_Scan_State (Scan_State); |
2e79de51 | 367 | Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod_Pexp)); |
19235870 RK |
368 | else |
369 | Restore_Scan_State (Scan_State); | |
2e79de51 | 370 | Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam_Pexp)); |
19235870 RK |
371 | end if; |
372 | ||
373 | elsif Token = Tok_Generic then | |
374 | Set_Unit (Comp_Unit_Node, P_Generic); | |
375 | ||
376 | elsif Token = Tok_Separate then | |
377 | Set_Unit (Comp_Unit_Node, P_Subunit); | |
378 | ||
edd63e9b ES |
379 | elsif Token = Tok_Function |
380 | or else Token = Tok_Not | |
381 | or else Token = Tok_Overriding | |
382 | or else Token = Tok_Procedure | |
19235870 | 383 | then |
2e79de51 | 384 | Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Pexp)); |
19235870 RK |
385 | |
386 | -- A little bit of an error recovery check here. If we just scanned | |
387 | -- a subprogram declaration (as indicated by an SIS entry being | |
388 | -- active), then if the following token is BEGIN or an identifier, | |
389 | -- or a token which can reasonably start a declaration but cannot | |
390 | -- start a compilation unit, then we assume that the semicolon in | |
391 | -- the declaration should have been IS. | |
392 | ||
393 | if SIS_Entry_Active then | |
394 | ||
395 | if Token = Tok_Begin | |
396 | or else Token = Tok_Identifier | |
397 | or else Token in Token_Class_Deckn | |
398 | then | |
399 | Push_Scope_Stack; | |
0bba838d BD |
400 | Scopes (Scope.Last).Etyp := E_Name; |
401 | Scopes (Scope.Last).Sloc := SIS_Sloc; | |
402 | Scopes (Scope.Last).Ecol := SIS_Ecol; | |
403 | Scopes (Scope.Last).Lreq := False; | |
19235870 RK |
404 | SIS_Entry_Active := False; |
405 | ||
406 | -- If we had a missing semicolon in the declaration, then | |
407 | -- change the message to from <missing ";"> to <missing "is"> | |
408 | ||
409 | if SIS_Missing_Semicolon_Message /= No_Error_Msg then | |
410 | Change_Error_Text -- Replace: "missing "";"" " | |
411 | (SIS_Missing_Semicolon_Message, "missing IS"); | |
412 | ||
413 | -- Otherwise we saved the semicolon position, so complain | |
414 | ||
415 | else | |
ed2233dc AC |
416 | Error_Msg -- CODEFIX |
417 | (""";"" should be IS", SIS_Semicolon_Sloc); | |
19235870 RK |
418 | end if; |
419 | ||
420 | Body_Node := Unit (Comp_Unit_Node); | |
421 | Specification_Node := Specification (Body_Node); | |
422 | Change_Node (Body_Node, N_Subprogram_Body); | |
423 | Set_Specification (Body_Node, Specification_Node); | |
424 | Parse_Decls_Begin_End (Body_Node); | |
425 | Set_Unit (Comp_Unit_Node, Body_Node); | |
426 | end if; | |
427 | ||
428 | -- If we scanned a subprogram body, make sure we did not have private | |
429 | ||
430 | elsif Private_Sloc /= No_Location | |
fbf5a39b | 431 | and then |
3c43f853 | 432 | Nkind (Unit (Comp_Unit_Node)) not in N_Subprogram_Instantiation |
fbf5a39b AC |
433 | and then |
434 | Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration | |
19235870 RK |
435 | then |
436 | Error_Msg ("cannot have private subprogram body", Private_Sloc); | |
437 | ||
438 | -- P_Subprogram can yield an abstract subprogram, but this cannot | |
439 | -- be a compilation unit. Treat as a subprogram declaration. | |
440 | ||
441 | elsif | |
442 | Nkind (Unit (Comp_Unit_Node)) = N_Abstract_Subprogram_Declaration | |
443 | then | |
444 | Error_Msg_N | |
445 | ("compilation unit cannot be abstract subprogram", | |
446 | Unit (Comp_Unit_Node)); | |
447 | ||
448 | Unit_Node := | |
449 | New_Node (N_Subprogram_Declaration, Sloc (Comp_Unit_Node)); | |
450 | Set_Specification (Unit_Node, | |
451 | Specification (Unit (Comp_Unit_Node))); | |
452 | Set_Unit (Comp_Unit_Node, Unit_Node); | |
453 | end if; | |
454 | ||
455 | -- Otherwise we have TASK. This is not really an acceptable token, | |
456 | -- but we accept it to improve error recovery. | |
457 | ||
458 | elsif Token = Tok_Task then | |
459 | Scan; -- Past TASK | |
460 | ||
461 | if Token = Tok_Type then | |
462 | Error_Msg_SP | |
463 | ("task type cannot be used as compilation unit"); | |
464 | else | |
465 | Error_Msg_SP | |
466 | ("task declaration cannot be used as compilation unit"); | |
467 | end if; | |
468 | ||
469 | -- If in check syntax mode, accept the task anyway. This is done | |
470 | -- particularly to improve the behavior of GNATCHOP in this case. | |
471 | ||
472 | if Operating_Mode = Check_Syntax then | |
473 | Set_Unit (Comp_Unit_Node, P_Task); | |
474 | ||
475 | -- If not in syntax only mode, treat this as horrible error | |
476 | ||
477 | else | |
478 | Cunit_Error_Flag := True; | |
479 | return Error; | |
480 | end if; | |
481 | ||
482 | else pragma Assert (Token = Tok_Protected); | |
483 | Scan; -- Past PROTECTED | |
484 | ||
485 | if Token = Tok_Type then | |
486 | Error_Msg_SP | |
487 | ("protected type cannot be used as compilation unit"); | |
488 | else | |
489 | Error_Msg_SP | |
490 | ("protected declaration cannot be used as compilation unit"); | |
491 | end if; | |
492 | ||
493 | -- If in check syntax mode, accept protected anyway. This is done | |
494 | -- particularly to improve the behavior of GNATCHOP in this case. | |
495 | ||
496 | if Operating_Mode = Check_Syntax then | |
497 | Set_Unit (Comp_Unit_Node, P_Protected); | |
498 | ||
499 | -- If not in syntax only mode, treat this as horrible error | |
500 | ||
501 | else | |
502 | Cunit_Error_Flag := True; | |
503 | return Error; | |
504 | end if; | |
505 | end if; | |
506 | ||
507 | -- Here is where locate the compilation unit entity. This is a little | |
508 | -- tricky, since it is buried in various places. | |
509 | ||
510 | Unit_Node := Unit (Comp_Unit_Node); | |
511 | ||
512 | -- Another error from which it is hard to recover | |
513 | ||
767bb4e8 | 514 | if Nkind_In (Unit_Node, N_Subprogram_Body_Stub, N_Package_Body_Stub) then |
19235870 RK |
515 | Cunit_Error_Flag := True; |
516 | return Error; | |
517 | end if; | |
518 | ||
a90bd866 | 519 | -- Only try this if we got an OK unit |
19235870 RK |
520 | |
521 | if Unit_Node /= Error then | |
522 | if Nkind (Unit_Node) = N_Subunit then | |
523 | Unit_Node := Proper_Body (Unit_Node); | |
524 | end if; | |
525 | ||
526 | if Nkind (Unit_Node) in N_Generic_Declaration then | |
527 | Unit_Node := Specification (Unit_Node); | |
528 | end if; | |
529 | ||
767bb4e8 AC |
530 | if Nkind_In (Unit_Node, N_Package_Declaration, |
531 | N_Subprogram_Declaration, | |
532 | N_Subprogram_Body, | |
533 | N_Subprogram_Renaming_Declaration) | |
19235870 RK |
534 | then |
535 | Unit_Node := Specification (Unit_Node); | |
536 | ||
537 | elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then | |
0ab80019 | 538 | if Ada_Version = Ada_83 then |
19235870 RK |
539 | Error_Msg_N |
540 | ("(Ada 83) library unit renaming not allowed", Unit_Node); | |
541 | end if; | |
542 | end if; | |
543 | ||
767bb4e8 AC |
544 | if Nkind_In (Unit_Node, N_Task_Body, |
545 | N_Protected_Body, | |
546 | N_Task_Type_Declaration, | |
547 | N_Protected_Type_Declaration, | |
548 | N_Single_Task_Declaration, | |
549 | N_Single_Protected_Declaration) | |
19235870 RK |
550 | then |
551 | Name_Node := Defining_Identifier (Unit_Node); | |
3c43f853 | 552 | |
767bb4e8 AC |
553 | elsif Nkind_In (Unit_Node, N_Function_Instantiation, |
554 | N_Function_Specification, | |
555 | N_Generic_Function_Renaming_Declaration, | |
556 | N_Generic_Package_Renaming_Declaration, | |
557 | N_Generic_Procedure_Renaming_Declaration) | |
558 | or else | |
559 | Nkind_In (Unit_Node, N_Package_Body, | |
560 | N_Package_Instantiation, | |
561 | N_Package_Renaming_Declaration, | |
562 | N_Package_Specification, | |
563 | N_Procedure_Instantiation, | |
564 | N_Procedure_Specification) | |
3c43f853 | 565 | then |
19235870 | 566 | Name_Node := Defining_Unit_Name (Unit_Node); |
3c43f853 | 567 | |
b0186f71 | 568 | elsif Nkind (Unit_Node) = N_Expression_Function then |
2010d078 | 569 | Error_Msg_SP |
b0186f71 | 570 | ("expression function cannot be used as compilation unit"); |
2010d078 AC |
571 | return Comp_Unit_Node; |
572 | ||
3c43f853 RD |
573 | -- Anything else is a serious error, abandon scan |
574 | ||
575 | else | |
576 | raise Error_Resync; | |
19235870 RK |
577 | end if; |
578 | ||
579 | Set_Sloc (Comp_Unit_Node, Sloc (Name_Node)); | |
580 | Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node)); | |
581 | ||
a90bd866 | 582 | -- Set Entity field in file table. Easier now that we have name. |
19235870 RK |
583 | -- Note that this is also skipped if we had a bad unit |
584 | ||
585 | if Nkind (Name_Node) = N_Defining_Program_Unit_Name then | |
586 | Set_Cunit_Entity | |
587 | (Current_Source_Unit, Defining_Identifier (Name_Node)); | |
588 | else | |
589 | Set_Cunit_Entity (Current_Source_Unit, Name_Node); | |
590 | end if; | |
591 | ||
592 | Set_Unit_Name | |
593 | (Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node))); | |
594 | ||
595 | -- If we had a bad unit, make sure the fatal flag is set in the file | |
596 | -- table entry, since this is surely a fatal error and also set our | |
597 | -- flag to inhibit the requirement that we be at end of file. | |
598 | ||
599 | else | |
600 | Cunit_Error_Flag := True; | |
ef2c20e7 | 601 | Set_Fatal_Error (Current_Source_Unit, Error_Detected); |
19235870 RK |
602 | end if; |
603 | ||
604 | -- Clear away any missing semicolon indication, we are done with that | |
605 | -- unit, so what's done is done, and we don't want anything hanging | |
a90bd866 | 606 | -- around from the attempt to parse it. |
19235870 RK |
607 | |
608 | SIS_Entry_Active := False; | |
609 | ||
610 | -- Scan out pragmas after unit | |
611 | ||
612 | while Token = Tok_Pragma loop | |
613 | Save_Scan_State (Scan_State); | |
614 | ||
470cd9e9 RD |
615 | -- If we are in syntax scan mode allowing multiple units, then start |
616 | -- the next unit if we encounter a configuration pragma, or a source | |
617 | -- reference pragma. We take care not to actually scan the pragma in | |
618 | -- this case (we don't want it to take effect for the current unit). | |
19235870 RK |
619 | |
620 | if Operating_Mode = Check_Syntax then | |
621 | Scan; -- past Pragma | |
622 | ||
623 | if Token = Tok_Identifier | |
624 | and then | |
470cd9e9 | 625 | (Is_Configuration_Pragma_Name (Token_Name) |
19235870 RK |
626 | or else Token_Name = Name_Source_Reference) |
627 | then | |
628 | Restore_Scan_State (Scan_State); -- to Pragma | |
629 | exit; | |
630 | end if; | |
631 | end if; | |
632 | ||
633 | -- Otherwise eat the pragma, it definitely belongs with the | |
634 | -- current unit, and not with the following unit. | |
635 | ||
636 | Restore_Scan_State (Scan_State); -- to Pragma | |
637 | P := P_Pragma; | |
638 | ||
639 | if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then | |
640 | Set_Pragmas_After | |
641 | (Aux_Decls_Node (Comp_Unit_Node), New_List); | |
642 | end if; | |
643 | ||
644 | Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))); | |
645 | end loop; | |
646 | ||
647 | -- Cancel effect of any outstanding pragma Warnings (Off) | |
648 | ||
649 | Set_Warnings_Mode_On (Scan_Ptr); | |
650 | ||
651 | -- Ada 83 error checks | |
652 | ||
0ab80019 | 653 | if Ada_Version = Ada_83 then |
19235870 RK |
654 | |
655 | -- Check we did not with any child units | |
656 | ||
657 | Item := First (Context_Items (Comp_Unit_Node)); | |
19235870 RK |
658 | while Present (Item) loop |
659 | if Nkind (Item) = N_With_Clause | |
660 | and then Nkind (Name (Item)) /= N_Identifier | |
661 | then | |
662 | Error_Msg_N ("(Ada 83) child units not allowed", Item); | |
663 | end if; | |
664 | ||
665 | Next (Item); | |
666 | end loop; | |
667 | ||
668 | -- Check that we did not have a PRIVATE keyword present | |
669 | ||
670 | if Private_Present (Comp_Unit_Node) then | |
671 | Error_Msg | |
672 | ("(Ada 83) private units not allowed", Private_Sloc); | |
673 | end if; | |
674 | end if; | |
675 | ||
676 | -- If no serious error, then output possible unit information line | |
677 | -- for gnatchop if we are in syntax only, list units mode. | |
678 | ||
679 | if not Cunit_Error_Flag | |
680 | and then List_Units | |
681 | and then Operating_Mode = Check_Syntax | |
682 | then | |
683 | Unit_Display (Comp_Unit_Node, Cunit_Location, SR_Present); | |
684 | end if; | |
685 | ||
686 | -- And now we should be at the end of file | |
687 | ||
688 | if Token /= Tok_EOF then | |
689 | ||
690 | -- If we already had to scan for a compilation unit, then don't | |
dec55d76 | 691 | -- give any further error message, since it just seems to make |
19235870 RK |
692 | -- things worse, and we already gave a serious error message. |
693 | ||
694 | if Cunit_Error_Flag then | |
695 | null; | |
696 | ||
697 | -- If we are in check syntax mode, then we allow multiple units | |
698 | -- so we just return with Token not set to Tok_EOF and no message. | |
699 | ||
700 | elsif Operating_Mode = Check_Syntax then | |
701 | return Comp_Unit_Node; | |
702 | ||
2820d220 AC |
703 | -- We also allow multiple units if we are in multiple unit mode |
704 | ||
705 | elsif Multiple_Unit_Index /= 0 then | |
706 | ||
707 | -- Skip tokens to end of file, so that the -gnatl listing | |
708 | -- will be complete in this situation, but no need to parse | |
6b6fcd3e | 709 | -- the remaining units; no style checking either. |
2820d220 | 710 | |
6b6fcd3e AC |
711 | declare |
712 | Save_Style_Check : constant Boolean := Style_Check; | |
30c20106 | 713 | |
6b6fcd3e AC |
714 | begin |
715 | Style_Check := False; | |
716 | ||
717 | while Token /= Tok_EOF loop | |
718 | Scan; | |
719 | end loop; | |
720 | ||
721 | Style_Check := Save_Style_Check; | |
722 | end; | |
2820d220 AC |
723 | |
724 | return Comp_Unit_Node; | |
725 | ||
19235870 RK |
726 | -- Otherwise we have an error. We suppress the error message |
727 | -- if we already had a fatal error, since this stops junk | |
728 | -- cascaded messages in some situations. | |
729 | ||
730 | else | |
ef2c20e7 | 731 | if Fatal_Error (Current_Source_Unit) /= Error_Detected then |
19235870 RK |
732 | if Token in Token_Class_Cunit then |
733 | Error_Msg_SC | |
734 | ("end of file expected, " & | |
735 | "file can have only one compilation unit"); | |
19235870 RK |
736 | else |
737 | Error_Msg_SC ("end of file expected"); | |
738 | end if; | |
739 | end if; | |
740 | end if; | |
741 | ||
742 | -- Skip tokens to end of file, so that the -gnatl listing | |
743 | -- will be complete in this situation, but no error checking | |
744 | -- other than that provided at the token level. | |
745 | ||
746 | while Token /= Tok_EOF loop | |
747 | Scan; | |
748 | end loop; | |
749 | ||
750 | return Error; | |
751 | ||
752 | -- Normal return (we were at the end of file as expected) | |
753 | ||
754 | else | |
755 | return Comp_Unit_Node; | |
756 | end if; | |
757 | ||
758 | exception | |
759 | ||
760 | -- An error resync is a serious bomb, so indicate result unit no good | |
761 | ||
762 | when Error_Resync => | |
ef2c20e7 | 763 | Set_Fatal_Error (Current_Source_Unit, Error_Detected); |
19235870 | 764 | return Error; |
19235870 RK |
765 | end P_Compilation_Unit; |
766 | ||
767 | -------------------------- | |
768 | -- 10.1.1 Library Item -- | |
769 | -------------------------- | |
770 | ||
771 | -- Parsed by P_Compilation_Unit (10.1.1) | |
772 | ||
773 | -------------------------------------- | |
774 | -- 10.1.1 Library Unit Declaration -- | |
775 | -------------------------------------- | |
776 | ||
777 | -- Parsed by P_Compilation_Unit (10.1.1) | |
778 | ||
779 | ------------------------------------------------ | |
780 | -- 10.1.1 Library Unit Renaming Declaration -- | |
781 | ------------------------------------------------ | |
782 | ||
783 | -- Parsed by P_Compilation_Unit (10.1.1) | |
784 | ||
785 | ------------------------------- | |
786 | -- 10.1.1 Library Unit Body -- | |
787 | ------------------------------- | |
788 | ||
789 | -- Parsed by P_Compilation_Unit (10.1.1) | |
790 | ||
791 | ------------------------------ | |
792 | -- 10.1.1 Parent Unit Name -- | |
793 | ------------------------------ | |
794 | ||
795 | -- Parsed (as a name) by its parent construct | |
796 | ||
797 | ---------------------------- | |
798 | -- 10.1.2 Context Clause -- | |
799 | ---------------------------- | |
800 | ||
801 | -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM} | |
802 | ||
803 | -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE | |
804 | ||
805 | -- WITH_CLAUSE ::= | |
8a6a52dc | 806 | -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME}; |
0ab80019 | 807 | -- Note: the two qualifiers are Ada 2005 extensions. |
19235870 RK |
808 | |
809 | -- WITH_TYPE_CLAUSE ::= | |
810 | -- with type type_NAME is access; | with type type_NAME is tagged; | |
8a6a52dc | 811 | -- Note: this form is obsolete (old GNAT extension). |
19235870 RK |
812 | |
813 | -- Error recovery: Cannot raise Error_Resync | |
814 | ||
815 | function P_Context_Clause return List_Id is | |
fbf5a39b AC |
816 | Item_List : List_Id; |
817 | Has_Limited : Boolean := False; | |
8a6a52dc AC |
818 | Has_Private : Boolean := False; |
819 | Scan_State : Saved_Scan_State; | |
fbf5a39b AC |
820 | With_Node : Node_Id; |
821 | First_Flag : Boolean; | |
19235870 RK |
822 | |
823 | begin | |
824 | Item_List := New_List; | |
825 | ||
826 | -- Get keyword casing from WITH keyword in case not set yet | |
827 | ||
828 | if Token = Tok_With then | |
829 | Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); | |
830 | end if; | |
831 | ||
832 | -- Loop through context items | |
833 | ||
834 | loop | |
835d23b2 RD |
835 | if Style_Check then |
836 | Style.Check_Indentation; | |
837 | end if; | |
19235870 RK |
838 | |
839 | -- Gather any pragmas appearing in the context clause | |
840 | ||
841 | P_Pragmas_Opt (Item_List); | |
842 | ||
843 | -- Processing for WITH clause | |
844 | ||
0ab80019 | 845 | -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH, |
9bc856dd | 846 | -- PRIVATE WITH, or both. |
fbf5a39b AC |
847 | |
848 | if Token = Tok_Limited then | |
849 | Has_Limited := True; | |
8a6a52dc | 850 | Has_Private := False; |
fbf5a39b AC |
851 | Scan; -- past LIMITED |
852 | ||
853 | -- In the context, LIMITED can only appear in a with_clause | |
854 | ||
8a6a52dc AC |
855 | if Token = Tok_Private then |
856 | Has_Private := True; | |
857 | Scan; -- past PRIVATE | |
858 | end if; | |
859 | ||
fbf5a39b | 860 | if Token /= Tok_With then |
ed2233dc AC |
861 | Error_Msg_SC -- CODEFIX |
862 | ("unexpected LIMITED ignored"); | |
fbf5a39b AC |
863 | end if; |
864 | ||
0791fbe9 | 865 | if Ada_Version < Ada_2005 then |
0ab80019 | 866 | Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension"); |
555360a5 | 867 | Error_Msg_SP |
0ab80019 | 868 | ("\unit must be compiled with -gnat05 switch"); |
fbf5a39b | 869 | end if; |
8a6a52dc AC |
870 | |
871 | elsif Token = Tok_Private then | |
872 | Has_Limited := False; | |
873 | Has_Private := True; | |
874 | Save_Scan_State (Scan_State); | |
875 | Scan; -- past PRIVATE | |
876 | ||
877 | if Token /= Tok_With then | |
878 | ||
30c20106 | 879 | -- Keyword is beginning of private child unit |
8a6a52dc AC |
880 | |
881 | Restore_Scan_State (Scan_State); -- to PRIVATE | |
882 | return Item_List; | |
883 | ||
0791fbe9 | 884 | elsif Ada_Version < Ada_2005 then |
aae02e6a | 885 | Error_Msg_SP ("`PRIVATE WITH` is an Ada 2005 extension"); |
8a6a52dc | 886 | Error_Msg_SP |
0ab80019 | 887 | ("\unit must be compiled with -gnat05 switch"); |
8a6a52dc AC |
888 | end if; |
889 | ||
fbf5a39b AC |
890 | else |
891 | Has_Limited := False; | |
8a6a52dc | 892 | Has_Private := False; |
fbf5a39b AC |
893 | end if; |
894 | ||
19235870 RK |
895 | if Token = Tok_With then |
896 | Scan; -- past WITH | |
897 | ||
898 | if Token = Tok_Type then | |
899 | ||
0712790c | 900 | -- WITH TYPE is an obsolete GNAT specific extension |
19235870 | 901 | |
ed2233dc | 902 | Error_Msg_SP ("`WITH TYPE` is an obsolete 'G'N'A'T extension"); |
0712790c | 903 | Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead"); |
19235870 RK |
904 | |
905 | Scan; -- past TYPE | |
19235870 RK |
906 | |
907 | T_Is; | |
908 | ||
909 | if Token = Tok_Tagged then | |
19235870 RK |
910 | Scan; |
911 | ||
912 | elsif Token = Tok_Access then | |
913 | Scan; | |
914 | ||
915 | else | |
916 | Error_Msg_SC ("expect tagged or access qualifier"); | |
917 | end if; | |
918 | ||
919 | TF_Semicolon; | |
920 | ||
921 | else | |
922 | First_Flag := True; | |
923 | ||
924 | -- Loop through names in one with clause, generating a separate | |
dec55d76 | 925 | -- N_With_Clause node for each name encountered. |
19235870 RK |
926 | |
927 | loop | |
928 | With_Node := New_Node (N_With_Clause, Token_Ptr); | |
929 | Append (With_Node, Item_List); | |
930 | ||
931 | -- Note that we allow with'ing of child units, even in | |
932 | -- Ada 83 mode, since presumably if this is not desired, | |
933 | -- then the compilation of the child unit itself is the | |
934 | -- place where such an "error" should be caught. | |
935 | ||
936 | Set_Name (With_Node, P_Qualified_Simple_Name); | |
c7532b2d AC |
937 | if Name (With_Node) = Error then |
938 | Remove (With_Node); | |
939 | end if; | |
940 | ||
19235870 | 941 | Set_First_Name (With_Node, First_Flag); |
fbf5a39b | 942 | Set_Limited_Present (With_Node, Has_Limited); |
8a6a52dc | 943 | Set_Private_Present (With_Node, Has_Private); |
19235870 | 944 | First_Flag := False; |
30c20106 AC |
945 | |
946 | -- All done if no comma | |
947 | ||
19235870 | 948 | exit when Token /= Tok_Comma; |
30c20106 AC |
949 | |
950 | -- If comma is followed by compilation unit token | |
951 | -- or by USE, or PRAGMA, then it should have been a | |
952 | -- semicolon after all | |
953 | ||
954 | Save_Scan_State (Scan_State); | |
19235870 | 955 | Scan; -- past comma |
30c20106 AC |
956 | |
957 | if Token in Token_Class_Cunit | |
958 | or else Token = Tok_Use | |
959 | or else Token = Tok_Pragma | |
960 | then | |
961 | Restore_Scan_State (Scan_State); | |
962 | exit; | |
963 | end if; | |
19235870 RK |
964 | end loop; |
965 | ||
966 | Set_Last_Name (With_Node, True); | |
967 | TF_Semicolon; | |
968 | end if; | |
969 | ||
970 | -- Processing for USE clause | |
971 | ||
972 | elsif Token = Tok_Use then | |
851e9f19 | 973 | P_Use_Clause (Item_List); |
19235870 RK |
974 | |
975 | -- Anything else is end of context clause | |
976 | ||
977 | else | |
978 | exit; | |
979 | end if; | |
980 | end loop; | |
981 | ||
982 | return Item_List; | |
983 | end P_Context_Clause; | |
984 | ||
985 | -------------------------- | |
986 | -- 10.1.2 Context Item -- | |
987 | -------------------------- | |
988 | ||
989 | -- Parsed by P_Context_Clause (10.1.2) | |
990 | ||
991 | ------------------------- | |
992 | -- 10.1.2 With Clause -- | |
993 | ------------------------- | |
994 | ||
995 | -- Parsed by P_Context_Clause (10.1.2) | |
996 | ||
997 | ----------------------- | |
998 | -- 10.1.3 Body Stub -- | |
999 | ----------------------- | |
1000 | ||
1001 | -- Subprogram stub parsed by P_Subprogram (6.1) | |
1002 | -- Package stub parsed by P_Package (7.1) | |
1003 | -- Task stub parsed by P_Task (9.1) | |
1004 | -- Protected stub parsed by P_Protected (9.4) | |
1005 | ||
1006 | ---------------------------------- | |
1007 | -- 10.1.3 Subprogram Body Stub -- | |
1008 | ---------------------------------- | |
1009 | ||
1010 | -- Parsed by P_Subprogram (6.1) | |
1011 | ||
1012 | ------------------------------- | |
1013 | -- 10.1.3 Package Body Stub -- | |
1014 | ------------------------------- | |
1015 | ||
1016 | -- Parsed by P_Package (7.1) | |
1017 | ||
1018 | ---------------------------- | |
1019 | -- 10.1.3 Task Body Stub -- | |
1020 | ---------------------------- | |
1021 | ||
1022 | -- Parsed by P_Task (9.1) | |
1023 | ||
1024 | --------------------------------- | |
1025 | -- 10.1.3 Protected Body Stub -- | |
1026 | --------------------------------- | |
1027 | ||
1028 | -- Parsed by P_Protected (9.4) | |
1029 | ||
1030 | --------------------- | |
1031 | -- 10.1.3 Subunit -- | |
1032 | --------------------- | |
1033 | ||
1034 | -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY | |
1035 | ||
1036 | -- PARENT_UNIT_NAME ::= NAME | |
1037 | ||
1038 | -- The caller has checked that the initial token is SEPARATE | |
1039 | ||
1040 | -- Error recovery: cannot raise Error_Resync | |
1041 | ||
1042 | function P_Subunit return Node_Id is | |
1043 | Subunit_Node : Node_Id; | |
1044 | Body_Node : Node_Id; | |
1045 | ||
1046 | begin | |
1047 | Subunit_Node := New_Node (N_Subunit, Token_Ptr); | |
1048 | Body_Node := Error; -- in case no good body found | |
1049 | Scan; -- past SEPARATE; | |
1050 | ||
470cd9e9 | 1051 | U_Left_Paren; |
19235870 | 1052 | Set_Name (Subunit_Node, P_Qualified_Simple_Name); |
470cd9e9 | 1053 | U_Right_Paren; |
19235870 | 1054 | |
3b8d33ef | 1055 | Ignore (Tok_Semicolon); |
19235870 | 1056 | |
5875f8d6 AC |
1057 | if Token = Tok_Function |
1058 | or else Token = Tok_Not | |
1059 | or else Token = Tok_Overriding | |
1060 | or else Token = Tok_Procedure | |
1061 | then | |
2e79de51 | 1062 | Body_Node := P_Subprogram (Pf_Pbod_Pexp); |
19235870 RK |
1063 | |
1064 | elsif Token = Tok_Package then | |
2e79de51 | 1065 | Body_Node := P_Package (Pf_Pbod_Pexp); |
19235870 RK |
1066 | |
1067 | elsif Token = Tok_Protected then | |
1068 | Scan; -- past PROTECTED | |
1069 | ||
1070 | if Token = Tok_Body then | |
1071 | Body_Node := P_Protected; | |
1072 | else | |
1073 | Error_Msg_AP ("BODY expected"); | |
1074 | return Error; | |
1075 | end if; | |
1076 | ||
1077 | elsif Token = Tok_Task then | |
1078 | Scan; -- past TASK | |
1079 | ||
1080 | if Token = Tok_Body then | |
1081 | Body_Node := P_Task; | |
1082 | else | |
1083 | Error_Msg_AP ("BODY expected"); | |
1084 | return Error; | |
1085 | end if; | |
1086 | ||
1087 | else | |
1088 | Error_Msg_SC ("proper body expected"); | |
1089 | return Error; | |
1090 | end if; | |
1091 | ||
1092 | Set_Proper_Body (Subunit_Node, Body_Node); | |
1093 | return Subunit_Node; | |
19235870 RK |
1094 | end P_Subunit; |
1095 | ||
1096 | ------------------ | |
1097 | -- Set_Location -- | |
1098 | ------------------ | |
1099 | ||
1100 | function Set_Location return Source_Ptr is | |
1101 | Physical : Boolean; | |
1102 | Loc : Source_Ptr; | |
1103 | Scan_State : Saved_Scan_State; | |
1104 | ||
1105 | begin | |
1106 | -- A special check. If the first token is pragma, and this is a | |
1107 | -- Source_Reference pragma, then do NOT eat previous comments, since | |
1108 | -- the Source_Reference pragma is required to be the first line in | |
1109 | -- the source file. | |
1110 | ||
1111 | if Token = Tok_Pragma then | |
1112 | Save_Scan_State (Scan_State); | |
1113 | Scan; -- past Pragma | |
1114 | ||
1115 | if Token = Tok_Identifier | |
1116 | and then Token_Name = Name_Source_Reference | |
1117 | then | |
1118 | Restore_Scan_State (Scan_State); | |
1119 | return Token_Ptr; | |
1120 | end if; | |
1121 | ||
1122 | Restore_Scan_State (Scan_State); | |
1123 | end if; | |
1124 | ||
1125 | -- Otherwise acquire previous comments and blank lines | |
1126 | ||
1127 | if Prev_Token = No_Token then | |
1128 | return Source_First (Current_Source_File); | |
1129 | ||
1130 | else | |
1131 | Loc := Prev_Token_Ptr; | |
1132 | loop | |
1133 | exit when Loc = Token_Ptr; | |
1134 | ||
debe0ab6 RD |
1135 | -- Should we worry about UTF_32 line terminators here |
1136 | ||
19235870 RK |
1137 | if Source (Loc) in Line_Terminator then |
1138 | Skip_Line_Terminators (Loc, Physical); | |
1139 | exit when Physical; | |
1140 | end if; | |
1141 | ||
1142 | Loc := Loc + 1; | |
1143 | end loop; | |
1144 | ||
1145 | return Loc; | |
1146 | end if; | |
1147 | end Set_Location; | |
1148 | ||
1149 | ------------------ | |
1150 | -- Unit_Display -- | |
1151 | ------------------ | |
1152 | ||
1153 | -- The format of the generated line, as expected by GNATCHOP is | |
1154 | ||
1155 | -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file} | |
1156 | ||
1157 | -- where | |
1158 | ||
1159 | -- {unit} unit name with terminating (spec) or (body) | |
1160 | -- {line} starting line number | |
1161 | -- {offs} offset to start of text in file | |
1162 | -- {file} source file name | |
1163 | ||
1164 | -- The SR parameter is present only if a source reference pragma was | |
1165 | -- scanned for this unit. The significance is that gnatchop should not | |
1166 | -- attempt to add another one. | |
1167 | ||
1168 | procedure Unit_Display | |
1169 | (Cunit : Node_Id; | |
1170 | Loc : Source_Ptr; | |
1171 | SR_Present : Boolean) | |
1172 | is | |
1173 | Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (Cunit); | |
1174 | Sind : constant Source_File_Index := Source_Index (Unum); | |
1175 | Unam : constant Unit_Name_Type := Unit_Name (Unum); | |
1176 | ||
1177 | begin | |
1178 | if List_Units then | |
1179 | Write_Str ("Unit "); | |
1180 | Write_Unit_Name (Unit_Name (Unum)); | |
1181 | Unit_Location (Sind, Loc); | |
1182 | ||
1183 | if SR_Present then | |
1184 | Write_Str (", SR"); | |
1185 | end if; | |
1186 | ||
1187 | Write_Str (", file name "); | |
1188 | Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit)); | |
1189 | Write_Eol; | |
1190 | end if; | |
1191 | end Unit_Display; | |
1192 | ||
1193 | ------------------- | |
1194 | -- Unit_Location -- | |
1195 | ------------------- | |
1196 | ||
1197 | procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is | |
1198 | Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc); | |
1199 | -- Should the above be the physical line number ??? | |
1200 | ||
1201 | begin | |
1202 | Write_Str (" line "); | |
1203 | Write_Int (Int (Line)); | |
1204 | ||
1205 | Write_Str (", file offset "); | |
1206 | Write_Int (Int (Loc) - Int (Source_First (Sind))); | |
1207 | end Unit_Location; | |
1208 | ||
1209 | end Ch10; |