?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
re PR fortran/30371 (kill suboutine accepts (invalid) array arguments.)
[official-gcc.git] / gcc / ada / prj-part.adb
blob938d394b42aeca836a882c12d487989b46f09eda
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . P A R T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with Err_Vars; use Err_Vars;
28 with Namet; use Namet;
29 with Opt; use Opt;
30 with Osint; use Osint;
31 with Output; use Output;
32 with Prj.Com; use Prj.Com;
33 with Prj.Dect;
34 with Prj.Err; use Prj.Err;
35 with Prj.Ext; use Prj.Ext;
36 with Sinput; use Sinput;
37 with Sinput.P; use Sinput.P;
38 with Snames;
39 with Table;
40
41 with Ada.Characters.Handling; use Ada.Characters.Handling;
42 with Ada.Exceptions; use Ada.Exceptions;
43
44 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
45
46 with System.HTable; use System.HTable;
47
48 package body Prj.Part is
49
50 Buffer : String_Access;
51 Buffer_Last : Natural := 0;
52
53 Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator;
54
55 type Extension_Origin is (None, Extending_Simple, Extending_All);
56 -- Type of parameter From_Extended for procedures Parse_Single_Project and
57 -- Post_Parse_Context_Clause. Extending_All means that we are parsing the
58 -- tree rooted at an extending all project.
59
60 ------------------------------------
61 -- Local Packages and Subprograms --
62 ------------------------------------
63
64 type With_Id is new Nat;
65 No_With : constant With_Id := 0;
66
67 type With_Record is record
68 Path : Name_Id;
69 Location : Source_Ptr;
70 Limited_With : Boolean;
71 Node : Project_Node_Id;
72 Next : With_Id;
73 end record;
74 -- Information about an imported project, to be put in table Withs below
75
76 package Withs is new Table.Table
77 (Table_Component_Type => With_Record,
78 Table_Index_Type => With_Id,
79 Table_Low_Bound => 1,
80 Table_Initial => 10,
81 Table_Increment => 100,
82 Table_Name => "Prj.Part.Withs");
83 -- Table used to store temporarily paths and locations of imported
84 -- projects. These imported projects will be effectively parsed after the
85 -- name of the current project has been extablished.
86
87 type Names_And_Id is record
88 Path_Name : Name_Id;
89 Canonical_Path_Name : Name_Id;
90 Id : Project_Node_Id;
91 end record;
92
93 package Project_Stack is new Table.Table
94 (Table_Component_Type => Names_And_Id,
95 Table_Index_Type => Nat,
96 Table_Low_Bound => 1,
97 Table_Initial => 10,
98 Table_Increment => 100,
99 Table_Name => "Prj.Part.Project_Stack");
100 -- This table is used to detect circular dependencies
101 -- for imported and extended projects and to get the project ids of
102 -- limited imported projects when there is a circularity with at least
103 -- one limited imported project file.
104
105 package Virtual_Hash is new System.HTable.Simple_HTable
106 (Header_Num => Header_Num,
107 Element => Project_Node_Id,
108 No_Element => Empty_Node,
109 Key => Project_Node_Id,
110 Hash => Prj.Tree.Hash,
111 Equal => "=");
112 -- Hash table to store the node id of the project for which a virtual
113 -- extending project need to be created.
114
115 package Processed_Hash is new System.HTable.Simple_HTable
116 (Header_Num => Header_Num,
117 Element => Boolean,
118 No_Element => False,
119 Key => Project_Node_Id,
120 Hash => Prj.Tree.Hash,
121 Equal => "=");
122 -- Hash table to store the project process when looking for project that
123 -- need to have a virtual extending project, to avoid processing the same
124 -- project twice.
125
126 procedure Create_Virtual_Extending_Project
127 (For_Project : Project_Node_Id;
128 Main_Project : Project_Node_Id;
129 In_Tree : Project_Node_Tree_Ref);
130 -- Create a virtual extending project of For_Project. Main_Project is
131 -- the extending all project.
132 --
133 -- The String_Value_Of is not set for the automatically added with
134 -- clause and keeps the default value of No_Name. This enables Prj.PP
135 -- to skip these automatically added with clauses to be processed.
136
137 procedure Look_For_Virtual_Projects_For
138 (Proj : Project_Node_Id;
139 In_Tree : Project_Node_Tree_Ref;
140 Potentially_Virtual : Boolean);
141 -- Look for projects that need to have a virtual extending project.
142 -- This procedure is recursive. If called with Potentially_Virtual set to
143 -- True, then Proj may need an virtual extending project; otherwise it
144 -- does not (because it is already extended), but other projects that it
145 -- imports may need to be virtually extended.
146
147 procedure Pre_Parse_Context_Clause
148 (In_Tree : Project_Node_Tree_Ref;
149 Context_Clause : out With_Id);
150 -- Parse the context clause of a project.
151 -- Store the paths and locations of the imported projects in table Withs.
152 -- Does nothing if there is no context clause (if the current
153 -- token is not "with" or "limited" followed by "with").
154
155 procedure Post_Parse_Context_Clause
156 (Context_Clause : With_Id;
157 In_Tree : Project_Node_Tree_Ref;
158 Imported_Projects : out Project_Node_Id;
159 Project_Directory : Name_Id;
160 From_Extended : Extension_Origin;
161 In_Limited : Boolean;
162 Packages_To_Check : String_List_Access);
163 -- Parse the imported projects that have been stored in table Withs,
164 -- if any. From_Extended is used for the call to Parse_Single_Project
165 -- below. When In_Limited is True, the importing path includes at least
166 -- one "limited with".
167
168 procedure Parse_Single_Project
169 (In_Tree : Project_Node_Tree_Ref;
170 Project : out Project_Node_Id;
171 Extends_All : out Boolean;
172 Path_Name : String;
173 Extended : Boolean;
174 From_Extended : Extension_Origin;
175 In_Limited : Boolean;
176 Packages_To_Check : String_List_Access);
177 -- Parse a project file.
178 -- Recursive procedure: it calls itself for imported and extended
179 -- projects. When From_Extended is not None, if the project has already
180 -- been parsed and is an extended project A, return the ultimate
181 -- (not extended) project that extends A. When In_Limited is True,
182 -- the importing path includes at least one "limited with".
183
184 function Project_Path_Name_Of
185 (Project_File_Name : String;
186 Directory : String) return String;
187 -- Returns the path name of a project file. Returns an empty string
188 -- if project file cannot be found.
189
190 function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id;
191 -- Get the directory of the file with the specified path name.
192 -- This includes the directory separator as the last character.
193 -- Returns "./" if Path_Name contains no directory separator.
194
195 function Project_Name_From (Path_Name : String) return Name_Id;
196 -- Returns the name of the project that corresponds to its path name.
197 -- Returns No_Name if the path name is invalid, because the corresponding
198 -- project name does not have the syntax of an ada identifier.
199
200 --------------------------------------
201 -- Create_Virtual_Extending_Project --
202 --------------------------------------
203
204 procedure Create_Virtual_Extending_Project
205 (For_Project : Project_Node_Id;
206 Main_Project : Project_Node_Id;
207 In_Tree : Project_Node_Tree_Ref)
208 is
209
210 Virtual_Name : constant String :=
211 Virtual_Prefix &
212 Get_Name_String (Name_Of (For_Project, In_Tree));
213 -- The name of the virtual extending project
214
215 Virtual_Name_Id : Name_Id;
216 -- Virtual extending project name id
217
218 Virtual_Path_Id : Name_Id;
219 -- Fake path name of the virtual extending project. The directory is
220 -- the same directory as the extending all project.
221
222 Virtual_Dir_Id : constant Name_Id :=
223 Immediate_Directory_Of (Path_Name_Of (Main_Project, In_Tree));
224 -- The directory of the extending all project
225
226 -- The source of the virtual extending project is something like:
227
228 -- project V$<project name> extends <project path> is
229
230 -- for Source_Dirs use ();
231
232 -- end V$<project name>;
233
234 -- The project directory cannot be specified during parsing; it will be
235 -- put directly in the virtual extending project data during processing.
236
237 -- Nodes that made up the virtual extending project
238
239 Virtual_Project : constant Project_Node_Id :=
240 Default_Project_Node
241 (In_Tree, N_Project);
242 With_Clause : constant Project_Node_Id :=
243 Default_Project_Node
244 (In_Tree, N_With_Clause);
245 Project_Declaration : constant Project_Node_Id :=
246 Default_Project_Node
247 (In_Tree, N_Project_Declaration);
248 Source_Dirs_Declaration : constant Project_Node_Id :=
249 Default_Project_Node
250 (In_Tree, N_Declarative_Item);
251 Source_Dirs_Attribute : constant Project_Node_Id :=
252 Default_Project_Node
253 (In_Tree, N_Attribute_Declaration, List);
254 Source_Dirs_Expression : constant Project_Node_Id :=
255 Default_Project_Node
256 (In_Tree, N_Expression, List);
257 Source_Dirs_Term : constant Project_Node_Id :=
258 Default_Project_Node
259 (In_Tree, N_Term, List);
260 Source_Dirs_List : constant Project_Node_Id :=
261 Default_Project_Node
262 (In_Tree, N_Literal_String_List, List);
263
264 begin
265 -- Get the virtual name id
266
267 Name_Len := Virtual_Name'Length;
268 Name_Buffer (1 .. Name_Len) := Virtual_Name;
269 Virtual_Name_Id := Name_Find;
270
271 -- Get the virtual path name
272
273 Get_Name_String (Path_Name_Of (Main_Project, In_Tree));
274
275 while Name_Len > 0
276 and then Name_Buffer (Name_Len) /= Directory_Separator
277 and then Name_Buffer (Name_Len) /= '/'
278 loop
279 Name_Len := Name_Len - 1;
280 end loop;
281
282 Name_Buffer (Name_Len + 1 .. Name_Len + Virtual_Name'Length) :=
283 Virtual_Name;
284 Name_Len := Name_Len + Virtual_Name'Length;
285 Virtual_Path_Id := Name_Find;
286
287 -- With clause
288
289 Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id);
290 Set_Path_Name_Of (With_Clause, In_Tree, Virtual_Path_Id);
291 Set_Project_Node_Of (With_Clause, In_Tree, Virtual_Project);
292 Set_Next_With_Clause_Of
293 (With_Clause, In_Tree, First_With_Clause_Of (Main_Project, In_Tree));
294 Set_First_With_Clause_Of (Main_Project, In_Tree, With_Clause);
295
296 -- Virtual project node
297
298 Set_Name_Of (Virtual_Project, In_Tree, Virtual_Name_Id);
299 Set_Path_Name_Of (Virtual_Project, In_Tree, Virtual_Path_Id);
300 Set_Location_Of
301 (Virtual_Project, In_Tree, Location_Of (Main_Project, In_Tree));
302 Set_Directory_Of (Virtual_Project, In_Tree, Virtual_Dir_Id);
303 Set_Project_Declaration_Of
304 (Virtual_Project, In_Tree, Project_Declaration);
305 Set_Extended_Project_Path_Of
306 (Virtual_Project, In_Tree, Path_Name_Of (For_Project, In_Tree));
307
308 -- Project declaration
309
310 Set_First_Declarative_Item_Of
311 (Project_Declaration, In_Tree, Source_Dirs_Declaration);
312 Set_Extended_Project_Of (Project_Declaration, In_Tree, For_Project);
313
314 -- Source_Dirs declaration
315
316 Set_Current_Item_Node
317 (Source_Dirs_Declaration, In_Tree, Source_Dirs_Attribute);
318
319 -- Source_Dirs attribute
320
321 Set_Name_Of (Source_Dirs_Attribute, In_Tree, Snames.Name_Source_Dirs);
322 Set_Expression_Of
323 (Source_Dirs_Attribute, In_Tree, Source_Dirs_Expression);
324
325 -- Source_Dirs expression
326
327 Set_First_Term (Source_Dirs_Expression, In_Tree, Source_Dirs_Term);
328
329 -- Source_Dirs term
330
331 Set_Current_Term (Source_Dirs_Term, In_Tree, Source_Dirs_List);
332
333 -- Source_Dirs empty list: nothing to do
334
335 -- Put virtual project into Projects_Htable
336
337 Prj.Tree.Tree_Private_Part.Projects_Htable.Set
338 (T => In_Tree.Projects_HT,
339 K => Virtual_Name_Id,
340 E => (Name => Virtual_Name_Id,
341 Node => Virtual_Project,
342 Canonical_Path => No_Name,
343 Extended => False));
344 end Create_Virtual_Extending_Project;
345
346 ----------------------------
347 -- Immediate_Directory_Of --
348 ----------------------------
349
350 function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id is
351 begin
352 Get_Name_String (Path_Name);
353
354 for Index in reverse 1 .. Name_Len loop
355 if Name_Buffer (Index) = '/'
356 or else Name_Buffer (Index) = Dir_Sep
357 then
358 -- Remove all chars after last directory separator from name
359
360 if Index > 1 then
361 Name_Len := Index - 1;
362
363 else
364 Name_Len := Index;
365 end if;
366
367 return Name_Find;
368 end if;
369 end loop;
370
371 -- There is no directory separator in name. Return "./" or ".\"
372
373 Name_Len := 2;
374 Name_Buffer (1) := '.';
375 Name_Buffer (2) := Dir_Sep;
376 return Name_Find;
377 end Immediate_Directory_Of;
378
379 -----------------------------------
380 -- Look_For_Virtual_Projects_For --
381 -----------------------------------
382
383 procedure Look_For_Virtual_Projects_For
384 (Proj : Project_Node_Id;
385 In_Tree : Project_Node_Tree_Ref;
386 Potentially_Virtual : Boolean)
387
388 is
389 Declaration : Project_Node_Id := Empty_Node;
390 -- Node for the project declaration of Proj
391
392 With_Clause : Project_Node_Id := Empty_Node;
393 -- Node for a with clause of Proj
394
395 Imported : Project_Node_Id := Empty_Node;
396 -- Node for a project imported by Proj
397
398 Extended : Project_Node_Id := Empty_Node;
399 -- Node for the eventual project extended by Proj
400
401 begin
402 -- Nothing to do if Proj is not defined or if it has already been
403 -- processed.
404
405 if Proj /= Empty_Node and then not Processed_Hash.Get (Proj) then
406 -- Make sure the project will not be processed again
407
408 Processed_Hash.Set (Proj, True);
409
410 Declaration := Project_Declaration_Of (Proj, In_Tree);
411
412 if Declaration /= Empty_Node then
413 Extended := Extended_Project_Of (Declaration, In_Tree);
414 end if;
415
416 -- If this is a project that may need a virtual extending project
417 -- and it is not itself an extending project, put it in the list.
418
419 if Potentially_Virtual and then Extended = Empty_Node then
420 Virtual_Hash.Set (Proj, Proj);
421 end if;
422
423 -- Now check the projects it imports
424
425 With_Clause := First_With_Clause_Of (Proj, In_Tree);
426
427 while With_Clause /= Empty_Node loop
428 Imported := Project_Node_Of (With_Clause, In_Tree);
429
430 if Imported /= Empty_Node then
431 Look_For_Virtual_Projects_For
432 (Imported, In_Tree, Potentially_Virtual => True);
433 end if;
434
435 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
436 end loop;
437
438 -- Check also the eventual project extended by Proj. As this project
439 -- is already extended, call recursively with Potentially_Virtual
440 -- being False.
441
442 Look_For_Virtual_Projects_For
443 (Extended, In_Tree, Potentially_Virtual => False);
444 end if;
445 end Look_For_Virtual_Projects_For;
446
447 -----------
448 -- Parse --
449 -----------
450
451 procedure Parse
452 (In_Tree : Project_Node_Tree_Ref;
453 Project : out Project_Node_Id;
454 Project_File_Name : String;
455 Always_Errout_Finalize : Boolean;
456 Packages_To_Check : String_List_Access := All_Packages;
457 Store_Comments : Boolean := False)
458 is
459 Current_Directory : constant String := Get_Current_Dir;
460 Dummy : Boolean;
461
462 Real_Project_File_Name : String_Access :=
463 Osint.To_Canonical_File_Spec
464 (Project_File_Name);
465
466 begin
467 if Real_Project_File_Name = null then
468 Real_Project_File_Name := new String'(Project_File_Name);
469 end if;
470
471 Project := Empty_Node;
472
473 if Current_Verbosity >= Medium then
474 Write_Str ("ADA_PROJECT_PATH=""");
475 Write_Str (Project_Path);
476 Write_Line ("""");
477 end if;
478
479 declare
480 Path_Name : constant String :=
481 Project_Path_Name_Of (Real_Project_File_Name.all,
482 Directory => Current_Directory);
483
484 begin
485 Free (Real_Project_File_Name);
486
487 Prj.Err.Initialize;
488 Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments);
489 Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments);
490
491 -- Parse the main project file
492
493 if Path_Name = "" then
494 Prj.Com.Fail
495 ("project file """, Project_File_Name, """ not found");
496 Project := Empty_Node;
497 return;
498 end if;
499
500 Parse_Single_Project
501 (In_Tree => In_Tree,
502 Project => Project,
503 Extends_All => Dummy,
504 Path_Name => Path_Name,
505 Extended => False,
506 From_Extended => None,
507 In_Limited => False,
508 Packages_To_Check => Packages_To_Check);
509
510 -- If Project is an extending-all project, create the eventual
511 -- virtual extending projects and check that there are no illegally
512 -- imported projects.
513
514 if Project /= Empty_Node
515 and then Is_Extending_All (Project, In_Tree)
516 then
517 -- First look for projects that potentially need a virtual
518 -- extending project.
519
520 Virtual_Hash.Reset;
521 Processed_Hash.Reset;
522
523 -- Mark the extending all project as processed, to avoid checking
524 -- the imported projects in case of a "limited with" on this
525 -- extending all project.
526
527 Processed_Hash.Set (Project, True);
528
529 declare
530 Declaration : constant Project_Node_Id :=
531 Project_Declaration_Of (Project, In_Tree);
532 begin
533 Look_For_Virtual_Projects_For
534 (Extended_Project_Of (Declaration, In_Tree), In_Tree,
535 Potentially_Virtual => False);
536 end;
537
538 -- Now, check the projects directly imported by the main project.
539 -- Remove from the potentially virtual any project extended by one
540 -- of these imported projects. For non extending imported
541 -- projects, check that they do not belong to the project tree of
542 -- the project being "extended-all" by the main project.
543
544 declare
545 With_Clause : Project_Node_Id;
546 Imported : Project_Node_Id := Empty_Node;
547 Declaration : Project_Node_Id := Empty_Node;
548
549 begin
550 With_Clause := First_With_Clause_Of (Project, In_Tree);
551 while With_Clause /= Empty_Node loop
552 Imported := Project_Node_Of (With_Clause, In_Tree);
553
554 if Imported /= Empty_Node then
555 Declaration := Project_Declaration_Of (Imported, In_Tree);
556
557 if Extended_Project_Of (Declaration, In_Tree) /=
558 Empty_Node
559 then
560 loop
561 Imported :=
562 Extended_Project_Of (Declaration, In_Tree);
563 exit when Imported = Empty_Node;
564 Virtual_Hash.Remove (Imported);
565 Declaration :=
566 Project_Declaration_Of (Imported, In_Tree);
567 end loop;
568 end if;
569 end if;
570
571 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
572 end loop;
573 end;
574
575 -- Now create all the virtual extending projects
576
577 declare
578 Proj : Project_Node_Id := Virtual_Hash.Get_First;
579 begin
580 while Proj /= Empty_Node loop
581 Create_Virtual_Extending_Project (Proj, Project, In_Tree);
582 Proj := Virtual_Hash.Get_Next;
583 end loop;
584 end;
585 end if;
586
587 -- If there were any kind of error during the parsing, serious
588 -- or not, then the parsing fails.
589
590 if Err_Vars.Total_Errors_Detected > 0 then
591 Project := Empty_Node;
592 end if;
593
594 if Project = Empty_Node or else Always_Errout_Finalize then
595 Prj.Err.Finalize;
596 end if;
597 end;
598
599 exception
600 when X : others =>
601
602 -- Internal error
603
604 Write_Line (Exception_Information (X));
605 Write_Str ("Exception ");
606 Write_Str (Exception_Name (X));
607 Write_Line (" raised, while processing project file");
608 Project := Empty_Node;
609 end Parse;
610
611 ------------------------------
612 -- Pre_Parse_Context_Clause --
613 ------------------------------
614
615 procedure Pre_Parse_Context_Clause
616 (In_Tree : Project_Node_Tree_Ref;
617 Context_Clause : out With_Id)
618 is
619 Current_With_Clause : With_Id := No_With;
620 Limited_With : Boolean := False;
621
622 Current_With : With_Record;
623
624 Current_With_Node : Project_Node_Id := Empty_Node;
625
626 begin
627 -- Assume no context clause
628
629 Context_Clause := No_With;
630 With_Loop :
631
632 -- If Token is not WITH or LIMITED, there is no context clause, or we
633 -- have exhausted the with clauses.
634
635 while Token = Tok_With or else Token = Tok_Limited loop
636 Current_With_Node :=
637 Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => In_Tree);
638 Limited_With := Token = Tok_Limited;
639
640 if Limited_With then
641 Scan (In_Tree); -- scan past LIMITED
642 Expect (Tok_With, "WITH");
643 exit With_Loop when Token /= Tok_With;
644 end if;
645
646 Comma_Loop :
647 loop
648 Scan (In_Tree); -- scan past WITH or ","
649
650 Expect (Tok_String_Literal, "literal string");
651
652 if Token /= Tok_String_Literal then
653 return;
654 end if;
655
656 -- Store path and location in table Withs
657
658 Current_With :=
659 (Path => Token_Name,
660 Location => Token_Ptr,
661 Limited_With => Limited_With,
662 Node => Current_With_Node,
663 Next => No_With);
664
665 Withs.Increment_Last;
666 Withs.Table (Withs.Last) := Current_With;
667
668 if Current_With_Clause = No_With then
669 Context_Clause := Withs.Last;
670
671 else
672 Withs.Table (Current_With_Clause).Next := Withs.Last;
673 end if;
674
675 Current_With_Clause := Withs.Last;
676
677 Scan (In_Tree);
678
679 if Token = Tok_Semicolon then
680 Set_End_Of_Line (Current_With_Node);
681 Set_Previous_Line_Node (Current_With_Node);
682
683 -- End of (possibly multiple) with clause;
684
685 Scan (In_Tree); -- scan past the semicolon.
686 exit Comma_Loop;
687
688 elsif Token = Tok_Comma then
689 Set_Is_Not_Last_In_List (Current_With_Node, In_Tree);
690
691 else
692 Error_Msg ("expected comma or semi colon", Token_Ptr);
693 exit Comma_Loop;
694 end if;
695
696 Current_With_Node :=
697 Default_Project_Node
698 (Of_Kind => N_With_Clause, In_Tree => In_Tree);
699 end loop Comma_Loop;
700 end loop With_Loop;
701 end Pre_Parse_Context_Clause;
702
703 -------------------------------
704 -- Post_Parse_Context_Clause --
705 -------------------------------
706
707 procedure Post_Parse_Context_Clause
708 (Context_Clause : With_Id;
709 In_Tree : Project_Node_Tree_Ref;
710 Imported_Projects : out Project_Node_Id;
711 Project_Directory : Name_Id;
712 From_Extended : Extension_Origin;
713 In_Limited : Boolean;
714 Packages_To_Check : String_List_Access)
715 is
716 Current_With_Clause : With_Id := Context_Clause;
717
718 Current_Project : Project_Node_Id := Empty_Node;
719 Previous_Project : Project_Node_Id := Empty_Node;
720 Next_Project : Project_Node_Id := Empty_Node;
721
722 Project_Directory_Path : constant String :=
723 Get_Name_String (Project_Directory);
724
725 Current_With : With_Record;
726 Limited_With : Boolean := False;
727 Extends_All : Boolean := False;
728
729 begin
730 Imported_Projects := Empty_Node;
731
732 while Current_With_Clause /= No_With loop
733 Current_With := Withs.Table (Current_With_Clause);
734 Current_With_Clause := Current_With.Next;
735
736 Limited_With := In_Limited or Current_With.Limited_With;
737
738 declare
739 Original_Path : constant String :=
740 Get_Name_String (Current_With.Path);
741
742 Imported_Path_Name : constant String :=
743 Project_Path_Name_Of
744 (Original_Path, Project_Directory_Path);
745
746 Resolved_Path : constant String :=
747 Normalize_Pathname
748 (Imported_Path_Name,
749 Resolve_Links => True,
750 Case_Sensitive => True);
751
752 Withed_Project : Project_Node_Id := Empty_Node;
753
754 begin
755 if Imported_Path_Name = "" then
756
757 -- The project file cannot be found
758
759 Error_Msg_Name_1 := Current_With.Path;
760
761 Error_Msg ("unknown project file: {", Current_With.Location);
762
763 -- If this is not imported by the main project file,
764 -- display the import path.
765
766 if Project_Stack.Last > 1 then
767 for Index in reverse 1 .. Project_Stack.Last loop
768 Error_Msg_Name_1 := Project_Stack.Table (Index).Path_Name;
769 Error_Msg ("\imported by {", Current_With.Location);
770 end loop;
771 end if;
772
773 else
774 -- New with clause
775
776 Previous_Project := Current_Project;
777
778 if Current_Project = Empty_Node then
779
780 -- First with clause of the context clause
781
782 Current_Project := Current_With.Node;
783 Imported_Projects := Current_Project;
784
785 else
786 Next_Project := Current_With.Node;
787 Set_Next_With_Clause_Of
788 (Current_Project, In_Tree, Next_Project);
789 Current_Project := Next_Project;
790 end if;
791
792 Set_String_Value_Of
793 (Current_Project, In_Tree, Current_With.Path);
794 Set_Location_Of
795 (Current_Project, In_Tree, Current_With.Location);
796
797 -- If this is a "limited with", check if we have a circularity.
798 -- If we have one, get the project id of the limited imported
799 -- project file, and do not parse it.
800
801 if Limited_With and then Project_Stack.Last > 1 then
802 declare
803 Canonical_Path_Name : Name_Id;
804
805 begin
806 Name_Len := Resolved_Path'Length;
807 Name_Buffer (1 .. Name_Len) := Resolved_Path;
808 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
809 Canonical_Path_Name := Name_Find;
810
811 for Index in 1 .. Project_Stack.Last loop
812 if Project_Stack.Table (Index).Canonical_Path_Name =
813 Canonical_Path_Name
814 then
815 -- We have found the limited imported project,
816 -- get its project id, and do not parse it.
817
818 Withed_Project := Project_Stack.Table (Index).Id;
819 exit;
820 end if;
821 end loop;
822 end;
823 end if;
824
825 -- Parse the imported project, if its project id is unknown
826
827 if Withed_Project = Empty_Node then
828 Parse_Single_Project
829 (In_Tree => In_Tree,
830 Project => Withed_Project,
831 Extends_All => Extends_All,
832 Path_Name => Imported_Path_Name,
833 Extended => False,
834 From_Extended => From_Extended,
835 In_Limited => Limited_With,
836 Packages_To_Check => Packages_To_Check);
837
838 else
839 Extends_All := Is_Extending_All (Withed_Project, In_Tree);
840 end if;
841
842 if Withed_Project = Empty_Node then
843 -- If parsing was not successful, remove the
844 -- context clause.
845
846 Current_Project := Previous_Project;
847
848 if Current_Project = Empty_Node then
849 Imported_Projects := Empty_Node;
850
851 else
852 Set_Next_With_Clause_Of
853 (Current_Project, In_Tree, Empty_Node);
854 end if;
855 else
856 -- If parsing was successful, record project name
857 -- and path name in with clause
858
859 Set_Project_Node_Of
860 (Node => Current_Project,
861 In_Tree => In_Tree,
862 To => Withed_Project,
863 Limited_With => Current_With.Limited_With);
864 Set_Name_Of
865 (Current_Project,
866 In_Tree,
867 Name_Of (Withed_Project, In_Tree));
868
869 Name_Len := Resolved_Path'Length;
870 Name_Buffer (1 .. Name_Len) := Resolved_Path;
871 Set_Path_Name_Of (Current_Project, In_Tree, Name_Find);
872
873 if Extends_All then
874 Set_Is_Extending_All (Current_Project, In_Tree);
875 end if;
876 end if;
877 end if;
878 end;
879 end loop;
880 end Post_Parse_Context_Clause;
881
882 --------------------------
883 -- Parse_Single_Project --
884 --------------------------
885
886 procedure Parse_Single_Project
887 (In_Tree : Project_Node_Tree_Ref;
888 Project : out Project_Node_Id;
889 Extends_All : out Boolean;
890 Path_Name : String;
891 Extended : Boolean;
892 From_Extended : Extension_Origin;
893 In_Limited : Boolean;
894 Packages_To_Check : String_List_Access)
895 is
896 Normed_Path_Name : Name_Id;
897 Canonical_Path_Name : Name_Id;
898 Project_Directory : Name_Id;
899 Project_Scan_State : Saved_Project_Scan_State;
900 Source_Index : Source_File_Index;
901
902 Extending : Boolean := False;
903
904 Extended_Project : Project_Node_Id := Empty_Node;
905
906 A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
907 Tree_Private_Part.Projects_Htable.Get_First
908 (In_Tree.Projects_HT);
909
910 Name_From_Path : constant Name_Id := Project_Name_From (Path_Name);
911
912 Name_Of_Project : Name_Id := No_Name;
913
914 First_With : With_Id;
915
916 use Tree_Private_Part;
917
918 Project_Comment_State : Tree.Comment_State;
919
920 begin
921 Extends_All := False;
922
923 declare
924 Normed_Path : constant String := Normalize_Pathname
925 (Path_Name, Resolve_Links => False,
926 Case_Sensitive => True);
927 Canonical_Path : constant String := Normalize_Pathname
928 (Normed_Path, Resolve_Links => True,
929 Case_Sensitive => False);
930
931 begin
932 Name_Len := Normed_Path'Length;
933 Name_Buffer (1 .. Name_Len) := Normed_Path;
934 Normed_Path_Name := Name_Find;
935 Name_Len := Canonical_Path'Length;
936 Name_Buffer (1 .. Name_Len) := Canonical_Path;
937 Canonical_Path_Name := Name_Find;
938 end;
939
940 -- Check for a circular dependency
941
942 for Index in 1 .. Project_Stack.Last loop
943 if Canonical_Path_Name =
944 Project_Stack.Table (Index).Canonical_Path_Name
945 then
946 Error_Msg ("circular dependency detected", Token_Ptr);
947 Error_Msg_Name_1 := Normed_Path_Name;
948 Error_Msg ("\ { is imported by", Token_Ptr);
949
950 for Current in reverse 1 .. Project_Stack.Last loop
951 Error_Msg_Name_1 := Project_Stack.Table (Current).Path_Name;
952
953 if Project_Stack.Table (Current).Canonical_Path_Name /=
954 Canonical_Path_Name
955 then
956 Error_Msg
957 ("\ { which itself is imported by", Token_Ptr);
958
959 else
960 Error_Msg ("\ {", Token_Ptr);
961 exit;
962 end if;
963 end loop;
964
965 Project := Empty_Node;
966 return;
967 end if;
968 end loop;
969
970 -- Put the new path name on the stack
971
972 Project_Stack.Increment_Last;
973 Project_Stack.Table (Project_Stack.Last).Path_Name := Normed_Path_Name;
974 Project_Stack.Table (Project_Stack.Last).Canonical_Path_Name :=
975 Canonical_Path_Name;
976
977 -- Check if the project file has already been parsed
978
979 while
980 A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node
981 loop
982 if A_Project_Name_And_Node.Canonical_Path = Canonical_Path_Name then
983 if Extended then
984
985 if A_Project_Name_And_Node.Extended then
986 Error_Msg
987 ("cannot extend the same project file several times",
988 Token_Ptr);
989 else
990 Error_Msg
991 ("cannot extend an already imported project file",
992 Token_Ptr);
993 end if;
994
995 elsif A_Project_Name_And_Node.Extended then
996 Extends_All :=
997 Is_Extending_All (A_Project_Name_And_Node.Node, In_Tree);
998
999 -- If the imported project is an extended project A,
1000 -- and we are in an extended project, replace A with the
1001 -- ultimate project extending A.
1002
1003 if From_Extended /= None then
1004 declare
1005 Decl : Project_Node_Id :=
1006 Project_Declaration_Of
1007 (A_Project_Name_And_Node.Node, In_Tree);
1008
1009 Prj : Project_Node_Id :=
1010 Extending_Project_Of (Decl, In_Tree);
1011
1012 begin
1013 loop
1014 Decl := Project_Declaration_Of (Prj, In_Tree);
1015 exit when Extending_Project_Of (Decl, In_Tree) =
1016 Empty_Node;
1017 Prj := Extending_Project_Of (Decl, In_Tree);
1018 end loop;
1019
1020 A_Project_Name_And_Node.Node := Prj;
1021 end;
1022 else
1023 Error_Msg
1024 ("cannot import an already extended project file",
1025 Token_Ptr);
1026 end if;
1027 end if;
1028
1029 Project := A_Project_Name_And_Node.Node;
1030 Project_Stack.Decrement_Last;
1031 return;
1032 end if;
1033
1034 A_Project_Name_And_Node :=
1035 Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT);
1036 end loop;
1037
1038 -- We never encountered this project file
1039 -- Save the scan state, load the project file and start to scan it.
1040
1041 Save_Project_Scan_State (Project_Scan_State);
1042 Source_Index := Load_Project_File (Path_Name);
1043 Tree.Save (Project_Comment_State);
1044
1045 -- If we cannot find it, we stop
1046
1047 if Source_Index = No_Source_File then
1048 Project := Empty_Node;
1049 Project_Stack.Decrement_Last;
1050 return;
1051 end if;
1052
1053 Prj.Err.Scanner.Initialize_Scanner (Source_Index);
1054 Tree.Reset_State;
1055 Scan (In_Tree);
1056
1057 if Name_From_Path = No_Name then
1058
1059 -- The project file name is not correct (no or bad extension,
1060 -- or not following Ada identifier's syntax).
1061
1062 Error_Msg_Name_1 := Canonical_Path_Name;
1063 Error_Msg ("?{ is not a valid path name for a project file",
1064 Token_Ptr);
1065 end if;
1066
1067 if Current_Verbosity >= Medium then
1068 Write_Str ("Parsing """);
1069 Write_Str (Path_Name);
1070 Write_Char ('"');
1071 Write_Eol;
1072 end if;
1073
1074 -- Is there any imported project?
1075
1076 Pre_Parse_Context_Clause (In_Tree, First_With);
1077
1078 Project_Directory := Immediate_Directory_Of (Normed_Path_Name);
1079 Project := Default_Project_Node
1080 (Of_Kind => N_Project, In_Tree => In_Tree);
1081 Project_Stack.Table (Project_Stack.Last).Id := Project;
1082 Set_Directory_Of (Project, In_Tree, Project_Directory);
1083 Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name);
1084 Set_Location_Of (Project, In_Tree, Token_Ptr);
1085
1086 Expect (Tok_Project, "PROJECT");
1087
1088 -- Mark location of PROJECT token if present
1089
1090 if Token = Tok_Project then
1091 Scan (In_Tree); -- scan past PROJECT
1092 Set_Location_Of (Project, In_Tree, Token_Ptr);
1093 end if;
1094
1095 -- Clear the Buffer
1096
1097 Buffer_Last := 0;
1098 loop
1099 Expect (Tok_Identifier, "identifier");
1100
1101 -- If the token is not an identifier, clear the buffer before
1102 -- exiting to indicate that the name of the project is ill-formed.
1103
1104 if Token /= Tok_Identifier then
1105 Buffer_Last := 0;
1106 exit;
1107 end if;
1108
1109 -- Add the identifier name to the buffer
1110
1111 Get_Name_String (Token_Name);
1112 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1113
1114 -- Scan past the identifier
1115
1116 Scan (In_Tree);
1117
1118 -- If we have a dot, add a dot the the Buffer and look for the next
1119 -- identifier.
1120
1121 exit when Token /= Tok_Dot;
1122 Add_To_Buffer (".", Buffer, Buffer_Last);
1123
1124 -- Scan past the dot
1125
1126 Scan (In_Tree);
1127 end loop;
1128
1129 -- See if this is an extending project
1130
1131 if Token = Tok_Extends then
1132
1133 -- Make sure that gnatmake will use mapping files
1134
1135 Create_Mapping_File := True;
1136
1137 -- We are extending another project
1138
1139 Extending := True;
1140
1141 Scan (In_Tree); -- scan past EXTENDS
1142
1143 if Token = Tok_All then
1144 Extends_All := True;
1145 Set_Is_Extending_All (Project, In_Tree);
1146 Scan (In_Tree); -- scan past ALL
1147 end if;
1148 end if;
1149
1150 -- If the name is well formed, Buffer_Last is > 0
1151
1152 if Buffer_Last > 0 then
1153
1154 -- The Buffer contains the name of the project
1155
1156 Name_Len := Buffer_Last;
1157 Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
1158 Name_Of_Project := Name_Find;
1159 Set_Name_Of (Project, In_Tree, Name_Of_Project);
1160
1161 -- To get expected name of the project file, replace dots by dashes
1162
1163 Name_Len := Buffer_Last;
1164 Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
1165
1166 for Index in 1 .. Name_Len loop
1167 if Name_Buffer (Index) = '.' then
1168 Name_Buffer (Index) := '-';
1169 end if;
1170 end loop;
1171
1172 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1173
1174 declare
1175 Expected_Name : constant Name_Id := Name_Find;
1176
1177 begin
1178 -- Output a warning if the actual name is not the expected name
1179
1180 if Name_From_Path /= No_Name
1181 and then Expected_Name /= Name_From_Path
1182 then
1183 Error_Msg_Name_1 := Expected_Name;
1184 Error_Msg ("?file name does not match unit name, " &
1185 "should be `{" & Project_File_Extension & "`",
1186 Token_Ptr);
1187 end if;
1188 end;
1189
1190 declare
1191 Imported_Projects : Project_Node_Id := Empty_Node;
1192 From_Ext : Extension_Origin := None;
1193
1194 begin
1195 -- Extending_All is always propagated
1196
1197 if From_Extended = Extending_All or else Extends_All then
1198 From_Ext := Extending_All;
1199
1200 -- Otherwise, From_Extended is set to Extending_Single if the
1201 -- current project is an extending project.
1202
1203 elsif Extended then
1204 From_Ext := Extending_Simple;
1205 end if;
1206
1207 Post_Parse_Context_Clause
1208 (In_Tree => In_Tree,
1209 Context_Clause => First_With,
1210 Imported_Projects => Imported_Projects,
1211 Project_Directory => Project_Directory,
1212 From_Extended => From_Ext,
1213 In_Limited => In_Limited,
1214 Packages_To_Check => Packages_To_Check);
1215 Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects);
1216 end;
1217
1218 declare
1219 Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
1220 Tree_Private_Part.Projects_Htable.Get_First
1221 (In_Tree.Projects_HT);
1222 Project_Name : Name_Id := Name_And_Node.Name;
1223
1224 begin
1225 -- Check if we already have a project with this name
1226
1227 while Project_Name /= No_Name
1228 and then Project_Name /= Name_Of_Project
1229 loop
1230 Name_And_Node :=
1231 Tree_Private_Part.Projects_Htable.Get_Next
1232 (In_Tree.Projects_HT);
1233 Project_Name := Name_And_Node.Name;
1234 end loop;
1235
1236 -- Report an error if we already have a project with this name
1237
1238 if Project_Name /= No_Name then
1239 Error_Msg_Name_1 := Project_Name;
1240 Error_Msg
1241 ("duplicate project name {", Location_Of (Project, In_Tree));
1242 Error_Msg_Name_1 :=
1243 Path_Name_Of (Name_And_Node.Node, In_Tree);
1244 Error_Msg
1245 ("\already in {", Location_Of (Project, In_Tree));
1246
1247 else
1248 -- Otherwise, add the name of the project to the hash table, so
1249 -- that we can check that no other subsequent project will have
1250 -- the same name.
1251
1252 Tree_Private_Part.Projects_Htable.Set
1253 (T => In_Tree.Projects_HT,
1254 K => Name_Of_Project,
1255 E => (Name => Name_Of_Project,
1256 Node => Project,
1257 Canonical_Path => Canonical_Path_Name,
1258 Extended => Extended));
1259 end if;
1260 end;
1261
1262 end if;
1263
1264 if Extending then
1265 Expect (Tok_String_Literal, "literal string");
1266
1267 if Token = Tok_String_Literal then
1268 Set_Extended_Project_Path_Of (Project, In_Tree, Token_Name);
1269
1270 declare
1271 Original_Path_Name : constant String :=
1272 Get_Name_String (Token_Name);
1273
1274 Extended_Project_Path_Name : constant String :=
1275 Project_Path_Name_Of
1276 (Original_Path_Name,
1277 Get_Name_String
1278 (Project_Directory));
1279
1280 begin
1281 if Extended_Project_Path_Name = "" then
1282
1283 -- We could not find the project file to extend
1284
1285 Error_Msg_Name_1 := Token_Name;
1286
1287 Error_Msg ("unknown project file: {", Token_Ptr);
1288
1289 -- If we are not in the main project file, display the
1290 -- import path.
1291
1292 if Project_Stack.Last > 1 then
1293 Error_Msg_Name_1 :=
1294 Project_Stack.Table (Project_Stack.Last).Path_Name;
1295 Error_Msg ("\extended by {", Token_Ptr);
1296
1297 for Index in reverse 1 .. Project_Stack.Last - 1 loop
1298 Error_Msg_Name_1 :=
1299 Project_Stack.Table (Index).Path_Name;
1300 Error_Msg ("\imported by {", Token_Ptr);
1301 end loop;
1302 end if;
1303
1304 else
1305 declare
1306 From_Ext : Extension_Origin := None;
1307
1308 begin
1309 if From_Extended = Extending_All or else Extends_All then
1310 From_Ext := Extending_All;
1311 end if;
1312
1313 Parse_Single_Project
1314 (In_Tree => In_Tree,
1315 Project => Extended_Project,
1316 Extends_All => Extends_All,
1317 Path_Name => Extended_Project_Path_Name,
1318 Extended => True,
1319 From_Extended => From_Ext,
1320 In_Limited => In_Limited,
1321 Packages_To_Check => Packages_To_Check);
1322 end;
1323
1324 -- A project that extends an extending-all project is also
1325 -- an extending-all project.
1326
1327 if Extended_Project /= Empty_Node
1328 and then Is_Extending_All (Extended_Project, In_Tree)
1329 then
1330 Set_Is_Extending_All (Project, In_Tree);
1331 end if;
1332 end if;
1333 end;
1334
1335 Scan (In_Tree); -- scan past the extended project path
1336 end if;
1337 end if;
1338
1339 -- Check that a non extending-all project does not import an
1340 -- extending-all project.
1341
1342 if not Is_Extending_All (Project, In_Tree) then
1343 declare
1344 With_Clause : Project_Node_Id :=
1345 First_With_Clause_Of (Project, In_Tree);
1346 Imported : Project_Node_Id := Empty_Node;
1347
1348 begin
1349 With_Clause_Loop :
1350 while With_Clause /= Empty_Node loop
1351 Imported := Project_Node_Of (With_Clause, In_Tree);
1352
1353 if Is_Extending_All (With_Clause, In_Tree) then
1354 Error_Msg_Name_1 := Name_Of (Imported, In_Tree);
1355 Error_Msg ("cannot import extending-all project {",
1356 Token_Ptr);
1357 exit With_Clause_Loop;
1358 end if;
1359
1360 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
1361 end loop With_Clause_Loop;
1362 end;
1363 end if;
1364
1365 -- Check that a project with a name including a dot either imports
1366 -- or extends the project whose name precedes the last dot.
1367
1368 if Name_Of_Project /= No_Name then
1369 Get_Name_String (Name_Of_Project);
1370
1371 else
1372 Name_Len := 0;
1373 end if;
1374
1375 -- Look for the last dot
1376
1377 while Name_Len > 0 and then Name_Buffer (Name_Len) /= '.' loop
1378 Name_Len := Name_Len - 1;
1379 end loop;
1380
1381 -- If a dot was find, check if the parent project is imported
1382 -- or extended.
1383
1384 if Name_Len > 0 then
1385 Name_Len := Name_Len - 1;
1386
1387 declare
1388 Parent_Name : constant Name_Id := Name_Find;
1389 Parent_Found : Boolean := False;
1390 With_Clause : Project_Node_Id :=
1391 First_With_Clause_Of (Project, In_Tree);
1392
1393 begin
1394 -- If there is an extended project, check its name
1395
1396 if Extended_Project /= Empty_Node then
1397 Parent_Found :=
1398 Name_Of (Extended_Project, In_Tree) = Parent_Name;
1399 end if;
1400
1401 -- If the parent project is not the extended project,
1402 -- check each imported project until we find the parent project.
1403
1404 while not Parent_Found and then With_Clause /= Empty_Node loop
1405 Parent_Found :=
1406 Name_Of (Project_Node_Of (With_Clause, In_Tree), In_Tree) =
1407 Parent_Name;
1408 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
1409 end loop;
1410
1411 -- If the parent project was not found, report an error
1412
1413 if not Parent_Found then
1414 Error_Msg_Name_1 := Name_Of_Project;
1415 Error_Msg_Name_2 := Parent_Name;
1416 Error_Msg ("project { does not import or extend project {",
1417 Location_Of (Project, In_Tree));
1418 end if;
1419 end;
1420 end if;
1421
1422 Expect (Tok_Is, "IS");
1423 Set_End_Of_Line (Project);
1424 Set_Previous_Line_Node (Project);
1425 Set_Next_End_Node (Project);
1426
1427 declare
1428 Project_Declaration : Project_Node_Id := Empty_Node;
1429
1430 begin
1431 -- No need to Scan past "is", Prj.Dect.Parse will do it
1432
1433 Prj.Dect.Parse
1434 (In_Tree => In_Tree,
1435 Declarations => Project_Declaration,
1436 Current_Project => Project,
1437 Extends => Extended_Project,
1438 Packages_To_Check => Packages_To_Check);
1439 Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration);
1440
1441 if Extended_Project /= Empty_Node then
1442 Set_Extending_Project_Of
1443 (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree,
1444 To => Project);
1445 end if;
1446 end;
1447
1448 Expect (Tok_End, "END");
1449 Remove_Next_End_Node;
1450
1451 -- Skip "end" if present
1452
1453 if Token = Tok_End then
1454 Scan (In_Tree);
1455 end if;
1456
1457 -- Clear the Buffer
1458
1459 Buffer_Last := 0;
1460
1461 -- Store the name following "end" in the Buffer. The name may be made of
1462 -- several simple names.
1463
1464 loop
1465 Expect (Tok_Identifier, "identifier");
1466
1467 -- If we don't have an identifier, clear the buffer before exiting to
1468 -- avoid checking the name.
1469
1470 if Token /= Tok_Identifier then
1471 Buffer_Last := 0;
1472 exit;
1473 end if;
1474
1475 -- Add the identifier to the Buffer
1476 Get_Name_String (Token_Name);
1477 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1478
1479 -- Scan past the identifier
1480
1481 Scan (In_Tree);
1482 exit when Token /= Tok_Dot;
1483 Add_To_Buffer (".", Buffer, Buffer_Last);
1484 Scan (In_Tree);
1485 end loop;
1486
1487 -- If we have a valid name, check if it is the name of the project
1488
1489 if Name_Of_Project /= No_Name and then Buffer_Last > 0 then
1490 if To_Lower (Buffer (1 .. Buffer_Last)) /=
1491 Get_Name_String (Name_Of (Project, In_Tree))
1492 then
1493 -- Invalid name: report an error
1494
1495 Error_Msg ("expected """ &
1496 Get_Name_String (Name_Of (Project, In_Tree)) & """",
1497 Token_Ptr);
1498 end if;
1499 end if;
1500
1501 Expect (Tok_Semicolon, "`;`");
1502
1503 -- Check that there is no more text following the end of the project
1504 -- source.
1505
1506 if Token = Tok_Semicolon then
1507 Set_Previous_End_Node (Project);
1508 Scan (In_Tree);
1509
1510 if Token /= Tok_EOF then
1511 Error_Msg
1512 ("unexpected text following end of project", Token_Ptr);
1513 end if;
1514 end if;
1515
1516 -- Restore the scan state, in case we are not the main project
1517
1518 Restore_Project_Scan_State (Project_Scan_State);
1519
1520 -- And remove the project from the project stack
1521
1522 Project_Stack.Decrement_Last;
1523
1524 -- Indicate if there are unkept comments
1525
1526 Tree.Set_Project_File_Includes_Unkept_Comments
1527 (Node => Project,
1528 In_Tree => In_Tree,
1529 To => Tree.There_Are_Unkept_Comments);
1530
1531 -- And restore the comment state that was saved
1532
1533 Tree.Restore (Project_Comment_State);
1534 end Parse_Single_Project;
1535
1536 -----------------------
1537 -- Project_Name_From --
1538 -----------------------
1539
1540 function Project_Name_From (Path_Name : String) return Name_Id is
1541 Canonical : String (1 .. Path_Name'Length) := Path_Name;
1542 First : Natural := Canonical'Last;
1543 Last : Natural := First;
1544 Index : Positive;
1545
1546 begin
1547 if Current_Verbosity = High then
1548 Write_Str ("Project_Name_From (""");
1549 Write_Str (Canonical);
1550 Write_Line (""")");
1551 end if;
1552
1553 -- If the path name is empty, return No_Name to indicate failure
1554
1555 if First = 0 then
1556 return No_Name;
1557 end if;
1558
1559 Canonical_Case_File_Name (Canonical);
1560
1561 -- Look for the last dot in the path name
1562
1563 while First > 0
1564 and then
1565 Canonical (First) /= '.'
1566 loop
1567 First := First - 1;
1568 end loop;
1569
1570 -- If we have a dot, check that it is followed by the correct extension
1571
1572 if First > 0 and then Canonical (First) = '.' then
1573 if Canonical (First .. Last) = Project_File_Extension
1574 and then First /= 1
1575 then
1576 -- Look for the last directory separator, if any
1577
1578 First := First - 1;
1579 Last := First;
1580
1581 while First > 0
1582 and then Canonical (First) /= '/'
1583 and then Canonical (First) /= Dir_Sep
1584 loop
1585 First := First - 1;
1586 end loop;
1587
1588 else
1589 -- Not the correct extension, return No_Name to indicate failure
1590
1591 return No_Name;
1592 end if;
1593
1594 -- If no dot in the path name, return No_Name to indicate failure
1595
1596 else
1597 return No_Name;
1598 end if;
1599
1600 First := First + 1;
1601
1602 -- If the extension is the file name, return No_Name to indicate failure
1603
1604 if First > Last then
1605 return No_Name;
1606 end if;
1607
1608 -- Put the name in lower case into Name_Buffer
1609
1610 Name_Len := Last - First + 1;
1611 Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last));
1612
1613 Index := 1;
1614
1615 -- Check if it is a well formed project name. Return No_Name if it is
1616 -- ill formed.
1617
1618 loop
1619 if not Is_Letter (Name_Buffer (Index)) then
1620 return No_Name;
1621
1622 else
1623 loop
1624 Index := Index + 1;
1625
1626 exit when Index >= Name_Len;
1627
1628 if Name_Buffer (Index) = '_' then
1629 if Name_Buffer (Index + 1) = '_' then
1630 return No_Name;
1631 end if;
1632 end if;
1633
1634 exit when Name_Buffer (Index) = '-';
1635
1636 if Name_Buffer (Index) /= '_'
1637 and then not Is_Alphanumeric (Name_Buffer (Index))
1638 then
1639 return No_Name;
1640 end if;
1641
1642 end loop;
1643 end if;
1644
1645 if Index >= Name_Len then
1646 if Is_Alphanumeric (Name_Buffer (Name_Len)) then
1647
1648 -- All checks have succeeded. Return name in Name_Buffer
1649
1650 return Name_Find;
1651
1652 else
1653 return No_Name;
1654 end if;
1655
1656 elsif Name_Buffer (Index) = '-' then
1657 Index := Index + 1;
1658 end if;
1659 end loop;
1660 end Project_Name_From;
1661
1662 --------------------------
1663 -- Project_Path_Name_Of --
1664 --------------------------
1665
1666 function Project_Path_Name_Of
1667 (Project_File_Name : String;
1668 Directory : String) return String
1669 is
1670 Result : String_Access;
1671
1672 begin
1673 if Current_Verbosity = High then
1674 Write_Str ("Project_Path_Name_Of (""");
1675 Write_Str (Project_File_Name);
1676 Write_Str (""", """);
1677 Write_Str (Directory);
1678 Write_Line (""");");
1679 end if;
1680
1681 if not Is_Absolute_Path (Project_File_Name) then
1682 -- First we try <directory>/<file_name>.<extension>
1683
1684 if Current_Verbosity = High then
1685 Write_Str (" Trying ");
1686 Write_Str (Directory);
1687 Write_Char (Directory_Separator);
1688 Write_Str (Project_File_Name);
1689 Write_Line (Project_File_Extension);
1690 end if;
1691
1692 Result :=
1693 Locate_Regular_File
1694 (File_Name => Directory & Directory_Separator &
1695 Project_File_Name & Project_File_Extension,
1696 Path => Project_Path);
1697
1698 -- Then we try <directory>/<file_name>
1699
1700 if Result = null then
1701 if Current_Verbosity = High then
1702 Write_Str (" Trying ");
1703 Write_Str (Directory);
1704 Write_Char (Directory_Separator);
1705 Write_Line (Project_File_Name);
1706 end if;
1707
1708 Result :=
1709 Locate_Regular_File
1710 (File_Name => Directory & Directory_Separator &
1711 Project_File_Name,
1712 Path => Project_Path);
1713 end if;
1714 end if;
1715
1716 if Result = null then
1717
1718 -- Then we try <file_name>.<extension>
1719
1720 if Current_Verbosity = High then
1721 Write_Str (" Trying ");
1722 Write_Str (Project_File_Name);
1723 Write_Line (Project_File_Extension);
1724 end if;
1725
1726 Result :=
1727 Locate_Regular_File
1728 (File_Name => Project_File_Name & Project_File_Extension,
1729 Path => Project_Path);
1730 end if;
1731
1732 if Result = null then
1733
1734 -- Then we try <file_name>
1735
1736 if Current_Verbosity = High then
1737 Write_Str (" Trying ");
1738 Write_Line (Project_File_Name);
1739 end if;
1740
1741 Result :=
1742 Locate_Regular_File
1743 (File_Name => Project_File_Name,
1744 Path => Project_Path);
1745 end if;
1746
1747 -- If we cannot find the project file, we return an empty string
1748
1749 if Result = null then
1750 return "";
1751
1752 else
1753 declare
1754 Final_Result : constant String :=
1755 GNAT.OS_Lib.Normalize_Pathname
1756 (Result.all,
1757 Resolve_Links => False,
1758 Case_Sensitive => True);
1759 begin
1760 Free (Result);
1761 return Final_Result;
1762 end;
1763 end if;
1764 end Project_Path_Name_Of;
1765
1766 end Prj.Part;
Mirror of the offical gcc git repository hosted at gcc.gnu.org