?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
PR tree-optimization/43833
[official-gcc/alias-decl.git] / gcc / ada / prj-part.adb
blobc733f38365c7f2507bf0d6c260160bb63e6e872d
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-2009, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Err_Vars; use Err_Vars;
27 with Opt; use Opt;
28 with Osint; use Osint;
29 with Output; use Output;
30 with Prj.Com; use Prj.Com;
31 with Prj.Dect;
32 with Prj.Err; use Prj.Err;
33 with Prj.Ext; use Prj.Ext;
34 with Sinput; use Sinput;
35 with Sinput.P; use Sinput.P;
36 with Snames;
37 with Table;
38
39 with Ada.Characters.Handling; use Ada.Characters.Handling;
40 with Ada.Exceptions; use Ada.Exceptions;
41
42 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
43
44 with System.HTable; use System.HTable;
45
46 package body Prj.Part is
47
48 Buffer : String_Access;
49 Buffer_Last : Natural := 0;
50
51 Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator;
52
53 ------------------------------------
54 -- Local Packages and Subprograms --
55 ------------------------------------
56
57 type With_Id is new Nat;
58 No_With : constant With_Id := 0;
59
60 type With_Record is record
61 Path : Path_Name_Type;
62 Location : Source_Ptr;
63 Limited_With : Boolean;
64 Node : Project_Node_Id;
65 Next : With_Id;
66 end record;
67 -- Information about an imported project, to be put in table Withs below
68
69 package Withs is new Table.Table
70 (Table_Component_Type => With_Record,
71 Table_Index_Type => With_Id,
72 Table_Low_Bound => 1,
73 Table_Initial => 10,
74 Table_Increment => 100,
75 Table_Name => "Prj.Part.Withs");
76 -- Table used to store temporarily paths and locations of imported
77 -- projects. These imported projects will be effectively parsed later: just
78 -- before parsing the current project for the non limited withed projects,
79 -- after getting its name; after complete parsing of the current project
80 -- for the limited withed projects.
81
82 type Names_And_Id is record
83 Path_Name : Path_Name_Type;
84 Canonical_Path_Name : Path_Name_Type;
85 Id : Project_Node_Id;
86 Limited_With : Boolean;
87 end record;
88
89 package Project_Stack is new Table.Table
90 (Table_Component_Type => Names_And_Id,
91 Table_Index_Type => Nat,
92 Table_Low_Bound => 1,
93 Table_Initial => 10,
94 Table_Increment => 100,
95 Table_Name => "Prj.Part.Project_Stack");
96 -- This table is used to detect circular dependencies
97 -- for imported and extended projects and to get the project ids of
98 -- limited imported projects when there is a circularity with at least
99 -- one limited imported project file.
100
101 package Virtual_Hash is new System.HTable.Simple_HTable
102 (Header_Num => Header_Num,
103 Element => Project_Node_Id,
104 No_Element => Empty_Node,
105 Key => Project_Node_Id,
106 Hash => Prj.Tree.Hash,
107 Equal => "=");
108 -- Hash table to store the node id of the project for which a virtual
109 -- extending project need to be created.
110
111 package Processed_Hash is new System.HTable.Simple_HTable
112 (Header_Num => Header_Num,
113 Element => Boolean,
114 No_Element => False,
115 Key => Project_Node_Id,
116 Hash => Prj.Tree.Hash,
117 Equal => "=");
118 -- Hash table to store the project process when looking for project that
119 -- need to have a virtual extending project, to avoid processing the same
120 -- project twice.
121
122 package Projects_Paths is new System.HTable.Simple_HTable
123 (Header_Num => Header_Num,
124 Element => Path_Name_Type,
125 No_Element => No_Path,
126 Key => Name_Id,
127 Hash => Hash,
128 Equal => "=");
129 -- Hash table to cache project path to avoid looking for them on the path
130
131 procedure Create_Virtual_Extending_Project
132 (For_Project : Project_Node_Id;
133 Main_Project : Project_Node_Id;
134 In_Tree : Project_Node_Tree_Ref);
135 -- Create a virtual extending project of For_Project. Main_Project is
136 -- the extending all project.
137 --
138 -- The String_Value_Of is not set for the automatically added with
139 -- clause and keeps the default value of No_Name. This enables Prj.PP
140 -- to skip these automatically added with clauses to be processed.
141
142 procedure Look_For_Virtual_Projects_For
143 (Proj : Project_Node_Id;
144 In_Tree : Project_Node_Tree_Ref;
145 Potentially_Virtual : Boolean);
146 -- Look for projects that need to have a virtual extending project.
147 -- This procedure is recursive. If called with Potentially_Virtual set to
148 -- True, then Proj may need an virtual extending project; otherwise it
149 -- does not (because it is already extended), but other projects that it
150 -- imports may need to be virtually extended.
151
152 type Extension_Origin is (None, Extending_Simple, Extending_All);
153 -- Type of parameter From_Extended for procedures Parse_Single_Project and
154 -- Post_Parse_Context_Clause. Extending_All means that we are parsing the
155 -- tree rooted at an extending all project.
156
157 procedure Parse_Single_Project
158 (In_Tree : Project_Node_Tree_Ref;
159 Project : out Project_Node_Id;
160 Extends_All : out Boolean;
161 Path_Name : String;
162 Extended : Boolean;
163 From_Extended : Extension_Origin;
164 In_Limited : Boolean;
165 Packages_To_Check : String_List_Access;
166 Depth : Natural;
167 Current_Dir : String;
168 Is_Config_File : Boolean;
169 Flags : Processing_Flags);
170 -- Parse a project file. This is a recursive procedure: it calls itself for
171 -- imported and extended projects. When From_Extended is not None, if the
172 -- project has already been parsed and is an extended project A, return the
173 -- ultimate (not extended) project that extends A. When In_Limited is True,
174 -- the importing path includes at least one "limited with". When parsing
175 -- configuration projects, do not allow a depth > 1.
176 --
177 -- Is_Config_File should be set to True if the project represents a config
178 -- file (.cgpr) since some specific checks apply.
179
180 procedure Pre_Parse_Context_Clause
181 (In_Tree : Project_Node_Tree_Ref;
182 Context_Clause : out With_Id;
183 Is_Config_File : Boolean;
184 Flags : Processing_Flags);
185 -- Parse the context clause of a project. Store the paths and locations of
186 -- the imported projects in table Withs. Does nothing if there is no
187 -- context clause (if the current token is not "with" or "limited" followed
188 -- by "with").
189 -- Is_Config_File should be set to True if the project represents a config
190 -- file (.cgpr) since some specific checks apply.
191
192 procedure Post_Parse_Context_Clause
193 (Context_Clause : With_Id;
194 In_Tree : Project_Node_Tree_Ref;
195 Limited_Withs : Boolean;
196 Imported_Projects : in out Project_Node_Id;
197 Project_Directory : Path_Name_Type;
198 From_Extended : Extension_Origin;
199 In_Limited : Boolean;
200 Packages_To_Check : String_List_Access;
201 Depth : Natural;
202 Current_Dir : String;
203 Is_Config_File : Boolean;
204 Flags : Processing_Flags);
205 -- Parse the imported projects that have been stored in table Withs, if
206 -- any. From_Extended is used for the call to Parse_Single_Project below.
207 -- When In_Limited is True, the importing path includes at least one
208 -- "limited with". When Limited_Withs is False, only non limited withed
209 -- projects are parsed. When Limited_Withs is True, only limited withed
210 -- projects are parsed.
211 -- Is_Config_File should be set to True if the project represents a config
212 -- file (.cgpr) since some specific checks apply.
213
214 function Project_Path_Name_Of
215 (In_Tree : Project_Node_Tree_Ref;
216 Project_File_Name : String;
217 Directory : String) return String;
218 -- Returns the path name of a project file. Returns an empty string
219 -- if project file cannot be found.
220
221 function Project_Name_From
222 (Path_Name : String;
223 Is_Config_File : Boolean) return Name_Id;
224 -- Returns the name of the project that corresponds to its path name.
225 -- Returns No_Name if the path name is invalid, because the corresponding
226 -- project name does not have the syntax of an ada identifier.
227
228 --------------------------------------
229 -- Create_Virtual_Extending_Project --
230 --------------------------------------
231
232 procedure Create_Virtual_Extending_Project
233 (For_Project : Project_Node_Id;
234 Main_Project : Project_Node_Id;
235 In_Tree : Project_Node_Tree_Ref)
236 is
237
238 Virtual_Name : constant String :=
239 Virtual_Prefix &
240 Get_Name_String (Name_Of (For_Project, In_Tree));
241 -- The name of the virtual extending project
242
243 Virtual_Name_Id : Name_Id;
244 -- Virtual extending project name id
245
246 Virtual_Path_Id : Path_Name_Type;
247 -- Fake path name of the virtual extending project. The directory is
248 -- the same directory as the extending all project.
249
250 -- The source of the virtual extending project is something like:
251
252 -- project V$<project name> extends <project path> is
253
254 -- for Source_Dirs use ();
255
256 -- end V$<project name>;
257
258 -- The project directory cannot be specified during parsing; it will be
259 -- put directly in the virtual extending project data during processing.
260
261 -- Nodes that made up the virtual extending project
262
263 Virtual_Project : Project_Node_Id;
264 With_Clause : constant Project_Node_Id :=
265 Default_Project_Node
266 (In_Tree, N_With_Clause);
267 Project_Declaration : Project_Node_Id;
268 Source_Dirs_Declaration : constant Project_Node_Id :=
269 Default_Project_Node
270 (In_Tree, N_Declarative_Item);
271 Source_Dirs_Attribute : constant Project_Node_Id :=
272 Default_Project_Node
273 (In_Tree, N_Attribute_Declaration, List);
274 Source_Dirs_Expression : constant Project_Node_Id :=
275 Default_Project_Node
276 (In_Tree, N_Expression, List);
277 Source_Dirs_Term : constant Project_Node_Id :=
278 Default_Project_Node
279 (In_Tree, N_Term, List);
280 Source_Dirs_List : constant Project_Node_Id :=
281 Default_Project_Node
282 (In_Tree, N_Literal_String_List, List);
283
284 begin
285 -- Get the virtual path name
286
287 Get_Name_String (Path_Name_Of (Main_Project, In_Tree));
288
289 while Name_Len > 0
290 and then Name_Buffer (Name_Len) /= Directory_Separator
291 and then Name_Buffer (Name_Len) /= '/'
292 loop
293 Name_Len := Name_Len - 1;
294 end loop;
295
296 Name_Buffer (Name_Len + 1 .. Name_Len + Virtual_Name'Length) :=
297 Virtual_Name;
298 Name_Len := Name_Len + Virtual_Name'Length;
299 Virtual_Path_Id := Name_Find;
300
301 -- Get the virtual name id
302
303 Name_Len := Virtual_Name'Length;
304 Name_Buffer (1 .. Name_Len) := Virtual_Name;
305 Virtual_Name_Id := Name_Find;
306
307 Virtual_Project := Create_Project
308 (In_Tree => In_Tree,
309 Name => Virtual_Name_Id,
310 Full_Path => Virtual_Path_Id,
311 Is_Config_File => False);
312
313 Project_Declaration := Project_Declaration_Of (Virtual_Project, In_Tree);
314
315 -- With clause
316
317 Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id);
318 Set_Path_Name_Of (With_Clause, In_Tree, Virtual_Path_Id);
319 Set_Project_Node_Of (With_Clause, In_Tree, Virtual_Project);
320 Set_Next_With_Clause_Of
321 (With_Clause, In_Tree, First_With_Clause_Of (Main_Project, In_Tree));
322 Set_First_With_Clause_Of (Main_Project, In_Tree, With_Clause);
323
324 -- Virtual project node
325
326 Set_Location_Of
327 (Virtual_Project, In_Tree, Location_Of (Main_Project, In_Tree));
328 Set_Extended_Project_Path_Of
329 (Virtual_Project, In_Tree, Path_Name_Of (For_Project, In_Tree));
330
331 -- Project declaration
332
333 Set_First_Declarative_Item_Of
334 (Project_Declaration, In_Tree, Source_Dirs_Declaration);
335 Set_Extended_Project_Of (Project_Declaration, In_Tree, For_Project);
336
337 -- Source_Dirs declaration
338
339 Set_Current_Item_Node
340 (Source_Dirs_Declaration, In_Tree, Source_Dirs_Attribute);
341
342 -- Source_Dirs attribute
343
344 Set_Name_Of (Source_Dirs_Attribute, In_Tree, Snames.Name_Source_Dirs);
345 Set_Expression_Of
346 (Source_Dirs_Attribute, In_Tree, Source_Dirs_Expression);
347
348 -- Source_Dirs expression
349
350 Set_First_Term (Source_Dirs_Expression, In_Tree, Source_Dirs_Term);
351
352 -- Source_Dirs term
353
354 Set_Current_Term (Source_Dirs_Term, In_Tree, Source_Dirs_List);
355
356 -- Source_Dirs empty list: nothing to do
357 end Create_Virtual_Extending_Project;
358
359 -----------------------------------
360 -- Look_For_Virtual_Projects_For --
361 -----------------------------------
362
363 procedure Look_For_Virtual_Projects_For
364 (Proj : Project_Node_Id;
365 In_Tree : Project_Node_Tree_Ref;
366 Potentially_Virtual : Boolean)
367 is
368 Declaration : Project_Node_Id := Empty_Node;
369 -- Node for the project declaration of Proj
370
371 With_Clause : Project_Node_Id := Empty_Node;
372 -- Node for a with clause of Proj
373
374 Imported : Project_Node_Id := Empty_Node;
375 -- Node for a project imported by Proj
376
377 Extended : Project_Node_Id := Empty_Node;
378 -- Node for the eventual project extended by Proj
379
380 begin
381 -- Nothing to do if Proj is not defined or if it has already been
382 -- processed.
383
384 if Present (Proj) and then not Processed_Hash.Get (Proj) then
385 -- Make sure the project will not be processed again
386
387 Processed_Hash.Set (Proj, True);
388
389 Declaration := Project_Declaration_Of (Proj, In_Tree);
390
391 if Present (Declaration) then
392 Extended := Extended_Project_Of (Declaration, In_Tree);
393 end if;
394
395 -- If this is a project that may need a virtual extending project
396 -- and it is not itself an extending project, put it in the list.
397
398 if Potentially_Virtual and then No (Extended) then
399 Virtual_Hash.Set (Proj, Proj);
400 end if;
401
402 -- Now check the projects it imports
403
404 With_Clause := First_With_Clause_Of (Proj, In_Tree);
405
406 while Present (With_Clause) loop
407 Imported := Project_Node_Of (With_Clause, In_Tree);
408
409 if Present (Imported) then
410 Look_For_Virtual_Projects_For
411 (Imported, In_Tree, Potentially_Virtual => True);
412 end if;
413
414 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
415 end loop;
416
417 -- Check also the eventual project extended by Proj. As this project
418 -- is already extended, call recursively with Potentially_Virtual
419 -- being False.
420
421 Look_For_Virtual_Projects_For
422 (Extended, In_Tree, Potentially_Virtual => False);
423 end if;
424 end Look_For_Virtual_Projects_For;
425
426 -----------
427 -- Parse --
428 -----------
429
430 procedure Parse
431 (In_Tree : Project_Node_Tree_Ref;
432 Project : out Project_Node_Id;
433 Project_File_Name : String;
434 Always_Errout_Finalize : Boolean;
435 Packages_To_Check : String_List_Access := All_Packages;
436 Store_Comments : Boolean := False;
437 Current_Directory : String := "";
438 Is_Config_File : Boolean;
439 Flags : Processing_Flags)
440 is
441 Dummy : Boolean;
442 pragma Warnings (Off, Dummy);
443
444 Real_Project_File_Name : String_Access :=
445 Osint.To_Canonical_File_Spec
446 (Project_File_Name);
447
448 begin
449 if Real_Project_File_Name = null then
450 Real_Project_File_Name := new String'(Project_File_Name);
451 end if;
452
453 Project := Empty_Node;
454
455 Projects_Paths.Reset;
456
457 if Current_Verbosity >= Medium then
458 Write_Str ("GPR_PROJECT_PATH=""");
459 Write_Str (Project_Path (In_Tree));
460 Write_Line ("""");
461 end if;
462
463 declare
464 Path_Name : constant String :=
465 Project_Path_Name_Of (In_Tree,
466 Real_Project_File_Name.all,
467 Directory => Current_Directory);
468
469 begin
470 Free (Real_Project_File_Name);
471
472 Prj.Err.Initialize;
473 Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments);
474 Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments);
475
476 -- Parse the main project file
477
478 if Path_Name = "" then
479 Prj.Com.Fail
480 ("project file """
481 & Project_File_Name
482 & """ not found in "
483 & Project_Path (In_Tree));
484 Project := Empty_Node;
485 return;
486 end if;
487
488 begin
489 Parse_Single_Project
490 (In_Tree => In_Tree,
491 Project => Project,
492 Extends_All => Dummy,
493 Path_Name => Path_Name,
494 Extended => False,
495 From_Extended => None,
496 In_Limited => False,
497 Packages_To_Check => Packages_To_Check,
498 Depth => 0,
499 Current_Dir => Current_Directory,
500 Is_Config_File => Is_Config_File,
501 Flags => Flags);
502
503 exception
504 when Types.Unrecoverable_Error =>
505 -- Unrecoverable_Error is raised when a line is too long.
506 -- A meaningful error message will be displayed later.
507 Project := Empty_Node;
508 end;
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 Present (Project)
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 Present (With_Clause) loop
552 Imported := Project_Node_Of (With_Clause, In_Tree);
553
554 if Present (Imported) 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 No (Imported);
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 Present (Proj) 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 No (Project) or else Always_Errout_Finalize then
595 Prj.Err.Finalize;
596
597 -- Reinitialize to avoid duplicate warnings later on
598
599 Prj.Err.Initialize;
600 end if;
601 end;
602
603 exception
604 when X : others =>
605
606 -- Internal error
607
608 Write_Line (Exception_Information (X));
609 Write_Str ("Exception ");
610 Write_Str (Exception_Name (X));
611 Write_Line (" raised, while processing project file");
612 Project := Empty_Node;
613 end Parse;
614
615 ------------------------------
616 -- Pre_Parse_Context_Clause --
617 ------------------------------
618
619 procedure Pre_Parse_Context_Clause
620 (In_Tree : Project_Node_Tree_Ref;
621 Context_Clause : out With_Id;
622 Is_Config_File : Boolean;
623 Flags : Processing_Flags)
624 is
625 Current_With_Clause : With_Id := No_With;
626 Limited_With : Boolean := False;
627 Current_With : With_Record;
628 Current_With_Node : Project_Node_Id := Empty_Node;
629
630 begin
631 -- Assume no context clause
632
633 Context_Clause := No_With;
634 With_Loop :
635
636 -- If Token is not WITH or LIMITED, there is no context clause, or we
637 -- have exhausted the with clauses.
638
639 while Token = Tok_With or else Token = Tok_Limited loop
640 Current_With_Node :=
641 Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => In_Tree);
642 Limited_With := Token = Tok_Limited;
643
644 if Is_Config_File then
645 Error_Msg
646 (Flags,
647 "configuration project cannot import " &
648 "other configuration projects",
649 Token_Ptr);
650 end if;
651
652 if Limited_With then
653 Scan (In_Tree); -- scan past LIMITED
654 Expect (Tok_With, "WITH");
655 exit With_Loop when Token /= Tok_With;
656 end if;
657
658 Comma_Loop :
659 loop
660 Scan (In_Tree); -- past WITH or ","
661
662 Expect (Tok_String_Literal, "literal string");
663
664 if Token /= Tok_String_Literal then
665 return;
666 end if;
667
668 -- Store path and location in table Withs
669
670 Current_With :=
671 (Path => Path_Name_Type (Token_Name),
672 Location => Token_Ptr,
673 Limited_With => Limited_With,
674 Node => Current_With_Node,
675 Next => No_With);
676
677 Withs.Increment_Last;
678 Withs.Table (Withs.Last) := Current_With;
679
680 if Current_With_Clause = No_With then
681 Context_Clause := Withs.Last;
682
683 else
684 Withs.Table (Current_With_Clause).Next := Withs.Last;
685 end if;
686
687 Current_With_Clause := Withs.Last;
688
689 Scan (In_Tree);
690
691 if Token = Tok_Semicolon then
692 Set_End_Of_Line (Current_With_Node);
693 Set_Previous_Line_Node (Current_With_Node);
694
695 -- End of (possibly multiple) with clause;
696
697 Scan (In_Tree); -- past the semicolon
698 exit Comma_Loop;
699
700 elsif Token = Tok_Comma then
701 Set_Is_Not_Last_In_List (Current_With_Node, In_Tree);
702
703 else
704 Error_Msg (Flags, "expected comma or semi colon", Token_Ptr);
705 exit Comma_Loop;
706 end if;
707
708 Current_With_Node :=
709 Default_Project_Node
710 (Of_Kind => N_With_Clause, In_Tree => In_Tree);
711 end loop Comma_Loop;
712 end loop With_Loop;
713 end Pre_Parse_Context_Clause;
714
715 -------------------------------
716 -- Post_Parse_Context_Clause --
717 -------------------------------
718
719 procedure Post_Parse_Context_Clause
720 (Context_Clause : With_Id;
721 In_Tree : Project_Node_Tree_Ref;
722 Limited_Withs : Boolean;
723 Imported_Projects : in out Project_Node_Id;
724 Project_Directory : Path_Name_Type;
725 From_Extended : Extension_Origin;
726 In_Limited : Boolean;
727 Packages_To_Check : String_List_Access;
728 Depth : Natural;
729 Current_Dir : String;
730 Is_Config_File : Boolean;
731 Flags : Processing_Flags)
732 is
733 Current_With_Clause : With_Id := Context_Clause;
734
735 Current_Project : Project_Node_Id := Imported_Projects;
736 Previous_Project : Project_Node_Id := Empty_Node;
737 Next_Project : Project_Node_Id := Empty_Node;
738
739 Project_Directory_Path : constant String :=
740 Get_Name_String (Project_Directory);
741
742 Current_With : With_Record;
743 Extends_All : Boolean := False;
744
745 begin
746 -- Set Current_Project to the last project in the current list, if the
747 -- list is not empty.
748
749 if Present (Current_Project) then
750 while
751 Present (Next_With_Clause_Of (Current_Project, In_Tree))
752 loop
753 Current_Project := Next_With_Clause_Of (Current_Project, In_Tree);
754 end loop;
755 end if;
756
757 while Current_With_Clause /= No_With loop
758 Current_With := Withs.Table (Current_With_Clause);
759 Current_With_Clause := Current_With.Next;
760
761 if Limited_Withs = Current_With.Limited_With then
762 declare
763 Original_Path : constant String :=
764 Get_Name_String (Current_With.Path);
765
766 Imported_Path_Name : constant String :=
767 Project_Path_Name_Of
768 (In_Tree,
769 Original_Path,
770 Project_Directory_Path);
771
772 Resolved_Path : constant String :=
773 Normalize_Pathname
774 (Imported_Path_Name,
775 Directory => Current_Dir,
776 Resolve_Links =>
777 Opt.Follow_Links_For_Files,
778 Case_Sensitive => True);
779
780 Withed_Project : Project_Node_Id := Empty_Node;
781
782 begin
783 if Imported_Path_Name = "" then
784
785 -- The project file cannot be found
786
787 Error_Msg_File_1 := File_Name_Type (Current_With.Path);
788 Error_Msg
789 (Flags, "unknown project file: {", Current_With.Location);
790
791 -- If this is not imported by the main project file, display
792 -- the import path.
793
794 if Project_Stack.Last > 1 then
795 for Index in reverse 1 .. Project_Stack.Last loop
796 Error_Msg_File_1 :=
797 File_Name_Type
798 (Project_Stack.Table (Index).Path_Name);
799 Error_Msg
800 (Flags, "\imported by {", Current_With.Location);
801 end loop;
802 end if;
803
804 else
805 -- New with clause
806
807 Previous_Project := Current_Project;
808
809 if No (Current_Project) then
810
811 -- First with clause of the context clause
812
813 Current_Project := Current_With.Node;
814 Imported_Projects := Current_Project;
815
816 else
817 Next_Project := Current_With.Node;
818 Set_Next_With_Clause_Of
819 (Current_Project, In_Tree, Next_Project);
820 Current_Project := Next_Project;
821 end if;
822
823 Set_String_Value_Of
824 (Current_Project,
825 In_Tree,
826 Name_Id (Current_With.Path));
827 Set_Location_Of
828 (Current_Project, In_Tree, Current_With.Location);
829
830 -- If it is a limited with, check if we have a circularity.
831 -- If we have one, get the project id of the limited
832 -- imported project file, and do not parse it.
833
834 if Limited_Withs and then Project_Stack.Last > 1 then
835 declare
836 Canonical_Path_Name : Path_Name_Type;
837
838 begin
839 Name_Len := Resolved_Path'Length;
840 Name_Buffer (1 .. Name_Len) := Resolved_Path;
841 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
842 Canonical_Path_Name := Name_Find;
843
844 for Index in 1 .. Project_Stack.Last loop
845 if Project_Stack.Table (Index).Canonical_Path_Name =
846 Canonical_Path_Name
847 then
848 -- We have found the limited imported project,
849 -- get its project id, and do not parse it.
850
851 Withed_Project := Project_Stack.Table (Index).Id;
852 exit;
853 end if;
854 end loop;
855 end;
856 end if;
857
858 -- Parse the imported project, if its project id is unknown
859
860 if No (Withed_Project) then
861 Parse_Single_Project
862 (In_Tree => In_Tree,
863 Project => Withed_Project,
864 Extends_All => Extends_All,
865 Path_Name => Imported_Path_Name,
866 Extended => False,
867 From_Extended => From_Extended,
868 In_Limited => Limited_Withs,
869 Packages_To_Check => Packages_To_Check,
870 Depth => Depth,
871 Current_Dir => Current_Dir,
872 Is_Config_File => Is_Config_File,
873 Flags => Flags);
874
875 else
876 Extends_All := Is_Extending_All (Withed_Project, In_Tree);
877 end if;
878
879 if No (Withed_Project) then
880
881 -- If parsing unsuccessful, remove the context clause
882
883 Current_Project := Previous_Project;
884
885 if No (Current_Project) then
886 Imported_Projects := Empty_Node;
887
888 else
889 Set_Next_With_Clause_Of
890 (Current_Project, In_Tree, Empty_Node);
891 end if;
892 else
893 -- If parsing was successful, record project name and
894 -- path name in with clause
895
896 Set_Project_Node_Of
897 (Node => Current_Project,
898 In_Tree => In_Tree,
899 To => Withed_Project,
900 Limited_With => Current_With.Limited_With);
901 Set_Name_Of
902 (Current_Project,
903 In_Tree,
904 Name_Of (Withed_Project, In_Tree));
905
906 Name_Len := Resolved_Path'Length;
907 Name_Buffer (1 .. Name_Len) := Resolved_Path;
908 Set_Path_Name_Of (Current_Project, In_Tree, Name_Find);
909
910 if Extends_All then
911 Set_Is_Extending_All (Current_Project, In_Tree);
912 end if;
913 end if;
914 end if;
915 end;
916 end if;
917 end loop;
918 end Post_Parse_Context_Clause;
919
920 --------------------------
921 -- Parse_Single_Project --
922 --------------------------
923
924 procedure Parse_Single_Project
925 (In_Tree : Project_Node_Tree_Ref;
926 Project : out Project_Node_Id;
927 Extends_All : out Boolean;
928 Path_Name : String;
929 Extended : Boolean;
930 From_Extended : Extension_Origin;
931 In_Limited : Boolean;
932 Packages_To_Check : String_List_Access;
933 Depth : Natural;
934 Current_Dir : String;
935 Is_Config_File : Boolean;
936 Flags : Processing_Flags)
937 is
938 Normed_Path_Name : Path_Name_Type;
939 Canonical_Path_Name : Path_Name_Type;
940 Project_Directory : Path_Name_Type;
941 Project_Scan_State : Saved_Project_Scan_State;
942 Source_Index : Source_File_Index;
943
944 Extending : Boolean := False;
945
946 Extended_Project : Project_Node_Id := Empty_Node;
947
948 A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
949 Tree_Private_Part.Projects_Htable.Get_First
950 (In_Tree.Projects_HT);
951
952 Name_From_Path : constant Name_Id :=
953 Project_Name_From (Path_Name, Is_Config_File => Is_Config_File);
954 Name_Of_Project : Name_Id := No_Name;
955 Display_Name_Of_Project : Name_Id := No_Name;
956
957 Duplicated : Boolean := False;
958
959 First_With : With_Id;
960 Imported_Projects : Project_Node_Id := Empty_Node;
961
962 use Tree_Private_Part;
963
964 Project_Comment_State : Tree.Comment_State;
965
966 Proj_Qualifier : Project_Qualifier := Unspecified;
967 Qualifier_Location : Source_Ptr;
968
969 begin
970 Extends_All := False;
971
972 declare
973 Normed_Path : constant String := Normalize_Pathname
974 (Path_Name,
975 Directory => Current_Dir,
976 Resolve_Links => False,
977 Case_Sensitive => True);
978 Canonical_Path : constant String := Normalize_Pathname
979 (Normed_Path,
980 Directory => Current_Dir,
981 Resolve_Links => Opt.Follow_Links_For_Files,
982 Case_Sensitive => False);
983 begin
984 Name_Len := Normed_Path'Length;
985 Name_Buffer (1 .. Name_Len) := Normed_Path;
986 Normed_Path_Name := Name_Find;
987 Name_Len := Canonical_Path'Length;
988 Name_Buffer (1 .. Name_Len) := Canonical_Path;
989 Canonical_Path_Name := Name_Find;
990 end;
991
992 -- Check for a circular dependency
993
994 for Index in reverse 1 .. Project_Stack.Last loop
995 exit when Project_Stack.Table (Index).Limited_With;
996
997 if Canonical_Path_Name =
998 Project_Stack.Table (Index).Canonical_Path_Name
999 then
1000 Error_Msg (Flags, "circular dependency detected", Token_Ptr);
1001 Error_Msg_Name_1 := Name_Id (Normed_Path_Name);
1002 Error_Msg (Flags, "\ %% is imported by", Token_Ptr);
1003
1004 for Current in reverse 1 .. Project_Stack.Last loop
1005 Error_Msg_Name_1 :=
1006 Name_Id (Project_Stack.Table (Current).Path_Name);
1007
1008 if Project_Stack.Table (Current).Canonical_Path_Name /=
1009 Canonical_Path_Name
1010 then
1011 Error_Msg
1012 (Flags, "\ %% which itself is imported by", Token_Ptr);
1013
1014 else
1015 Error_Msg (Flags, "\ %%", Token_Ptr);
1016 exit;
1017 end if;
1018 end loop;
1019
1020 Project := Empty_Node;
1021 return;
1022 end if;
1023 end loop;
1024
1025 -- Put the new path name on the stack
1026
1027 Project_Stack.Append
1028 ((Path_Name => Normed_Path_Name,
1029 Canonical_Path_Name => Canonical_Path_Name,
1030 Id => Empty_Node,
1031 Limited_With => In_Limited));
1032
1033 -- Check if the project file has already been parsed
1034
1035 while
1036 A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node
1037 loop
1038 if A_Project_Name_And_Node.Canonical_Path = Canonical_Path_Name then
1039 if Extended then
1040
1041 if A_Project_Name_And_Node.Extended then
1042 if A_Project_Name_And_Node.Proj_Qualifier /= Dry then
1043 Error_Msg
1044 (Flags,
1045 "cannot extend the same project file several times",
1046 Token_Ptr);
1047 end if;
1048 else
1049 Error_Msg
1050 (Flags,
1051 "cannot extend an already imported project file",
1052 Token_Ptr);
1053 end if;
1054
1055 elsif A_Project_Name_And_Node.Extended then
1056 Extends_All :=
1057 Is_Extending_All (A_Project_Name_And_Node.Node, In_Tree);
1058
1059 -- If the imported project is an extended project A, and we are
1060 -- in an extended project, replace A with the ultimate project
1061 -- extending A.
1062
1063 if From_Extended /= None then
1064 declare
1065 Decl : Project_Node_Id :=
1066 Project_Declaration_Of
1067 (A_Project_Name_And_Node.Node, In_Tree);
1068
1069 Prj : Project_Node_Id :=
1070 A_Project_Name_And_Node.Node;
1071
1072 begin
1073 -- Loop through extending projects to find the ultimate
1074 -- extending project, that is the one that is not
1075 -- extended. For an abstract project, as it can be
1076 -- extended several times, there is no extending project
1077 -- registered, so the loop does not execute and the
1078 -- resulting project is the abstract project.
1079
1080 while
1081 Extending_Project_Of (Decl, In_Tree) /= Empty_Node
1082 loop
1083 Prj := Extending_Project_Of (Decl, In_Tree);
1084 Decl := Project_Declaration_Of (Prj, In_Tree);
1085 end loop;
1086
1087 A_Project_Name_And_Node.Node := Prj;
1088 end;
1089 else
1090 Error_Msg
1091 (Flags,
1092 "cannot import an already extended project file",
1093 Token_Ptr);
1094 end if;
1095 end if;
1096
1097 Project := A_Project_Name_And_Node.Node;
1098 Project_Stack.Decrement_Last;
1099 return;
1100 end if;
1101
1102 A_Project_Name_And_Node :=
1103 Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT);
1104 end loop;
1105
1106 -- We never encountered this project file. Save the scan state, load the
1107 -- project file and start to scan it.
1108
1109 Save_Project_Scan_State (Project_Scan_State);
1110 Source_Index := Load_Project_File (Path_Name);
1111 Tree.Save (Project_Comment_State);
1112
1113 -- If we cannot find it, we stop
1114
1115 if Source_Index = No_Source_File then
1116 Project := Empty_Node;
1117 Project_Stack.Decrement_Last;
1118 return;
1119 end if;
1120
1121 Prj.Err.Scanner.Initialize_Scanner (Source_Index);
1122 Tree.Reset_State;
1123 Scan (In_Tree);
1124
1125 if not Is_Config_File and then Name_From_Path = No_Name then
1126
1127 -- The project file name is not correct (no or bad extension, or not
1128 -- following Ada identifier's syntax).
1129
1130 Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name);
1131 Error_Msg (Flags,
1132 "?{ is not a valid path name for a project file",
1133 Token_Ptr);
1134 end if;
1135
1136 if Current_Verbosity >= Medium then
1137 Write_Str ("Parsing """);
1138 Write_Str (Path_Name);
1139 Write_Char ('"');
1140 Write_Eol;
1141 end if;
1142
1143 Project_Directory :=
1144 Path_Name_Type (Get_Directory (File_Name_Type (Normed_Path_Name)));
1145
1146 -- Is there any imported project?
1147
1148 Pre_Parse_Context_Clause
1149 (In_Tree => In_Tree,
1150 Is_Config_File => Is_Config_File,
1151 Context_Clause => First_With,
1152 Flags => Flags);
1153
1154 Project := Default_Project_Node
1155 (Of_Kind => N_Project, In_Tree => In_Tree);
1156 Project_Stack.Table (Project_Stack.Last).Id := Project;
1157 Set_Directory_Of (Project, In_Tree, Project_Directory);
1158 Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name);
1159
1160 -- Check if there is a qualifier before the reserved word "project"
1161
1162 Qualifier_Location := Token_Ptr;
1163
1164 if Token = Tok_Abstract then
1165 Proj_Qualifier := Dry;
1166 Scan (In_Tree);
1167
1168 elsif Token = Tok_Identifier then
1169 case Token_Name is
1170 when Snames.Name_Standard =>
1171 Proj_Qualifier := Standard;
1172 Scan (In_Tree);
1173
1174 when Snames.Name_Aggregate =>
1175 Proj_Qualifier := Aggregate;
1176 Scan (In_Tree);
1177
1178 if Token = Tok_Identifier and then
1179 Token_Name = Snames.Name_Library
1180 then
1181 Proj_Qualifier := Aggregate_Library;
1182 Scan (In_Tree);
1183 end if;
1184
1185 when Snames.Name_Library =>
1186 Proj_Qualifier := Library;
1187 Scan (In_Tree);
1188
1189 when Snames.Name_Configuration =>
1190 if not Is_Config_File then
1191 Error_Msg
1192 (Flags,
1193 "configuration projects cannot belong to a user" &
1194 " project tree",
1195 Token_Ptr);
1196 end if;
1197
1198 Proj_Qualifier := Configuration;
1199 Scan (In_Tree);
1200
1201 when others =>
1202 null;
1203 end case;
1204 end if;
1205
1206 if Is_Config_File and then Proj_Qualifier = Unspecified then
1207
1208 -- Set the qualifier to Configuration, even if the token doesn't
1209 -- exist in the source file itself, so that we can differentiate
1210 -- project files and configuration files later on.
1211
1212 Proj_Qualifier := Configuration;
1213 end if;
1214
1215 if Proj_Qualifier /= Unspecified then
1216 if Is_Config_File
1217 and then Proj_Qualifier /= Configuration
1218 then
1219 Error_Msg (Flags,
1220 "a configuration project cannot be qualified except " &
1221 "as configuration project",
1222 Qualifier_Location);
1223 end if;
1224
1225 Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier);
1226 end if;
1227
1228 Set_Location_Of (Project, In_Tree, Token_Ptr);
1229
1230 Expect (Tok_Project, "PROJECT");
1231
1232 -- Mark location of PROJECT token if present
1233
1234 if Token = Tok_Project then
1235 Scan (In_Tree); -- past PROJECT
1236 Set_Location_Of (Project, In_Tree, Token_Ptr);
1237 end if;
1238
1239 -- Clear the Buffer
1240
1241 Buffer_Last := 0;
1242 loop
1243 Expect (Tok_Identifier, "identifier");
1244
1245 -- If the token is not an identifier, clear the buffer before
1246 -- exiting to indicate that the name of the project is ill-formed.
1247
1248 if Token /= Tok_Identifier then
1249 Buffer_Last := 0;
1250 exit;
1251 end if;
1252
1253 -- Add the identifier name to the buffer
1254
1255 Get_Name_String (Token_Name);
1256 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1257
1258 -- Scan past the identifier
1259
1260 Scan (In_Tree);
1261
1262 -- If we have a dot, add a dot to the Buffer and look for the next
1263 -- identifier.
1264
1265 exit when Token /= Tok_Dot;
1266 Add_To_Buffer (".", Buffer, Buffer_Last);
1267
1268 -- Scan past the dot
1269
1270 Scan (In_Tree);
1271 end loop;
1272
1273 -- See if this is an extending project
1274
1275 if Token = Tok_Extends then
1276
1277 if Is_Config_File then
1278 Error_Msg
1279 (Flags,
1280 "extending configuration project not allowed", Token_Ptr);
1281 end if;
1282
1283 -- Make sure that gnatmake will use mapping files
1284
1285 Create_Mapping_File := True;
1286
1287 -- We are extending another project
1288
1289 Extending := True;
1290
1291 Scan (In_Tree); -- past EXTENDS
1292
1293 if Token = Tok_All then
1294 Extends_All := True;
1295 Set_Is_Extending_All (Project, In_Tree);
1296 Scan (In_Tree); -- scan past ALL
1297 end if;
1298 end if;
1299
1300 -- If the name is well formed, Buffer_Last is > 0
1301
1302 if Buffer_Last > 0 then
1303
1304 -- The Buffer contains the name of the project
1305
1306 Name_Len := Buffer_Last;
1307 Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
1308 Name_Of_Project := Name_Find;
1309 Set_Name_Of (Project, In_Tree, Name_Of_Project);
1310
1311 -- To get expected name of the project file, replace dots by dashes
1312
1313 for Index in 1 .. Name_Len loop
1314 if Name_Buffer (Index) = '.' then
1315 Name_Buffer (Index) := '-';
1316 end if;
1317 end loop;
1318
1319 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1320
1321 declare
1322 Expected_Name : constant Name_Id := Name_Find;
1323 Extension : String_Access;
1324
1325 begin
1326 -- Output a warning if the actual name is not the expected name
1327
1328 if not Is_Config_File
1329 and then (Name_From_Path /= No_Name)
1330 and then Expected_Name /= Name_From_Path
1331 then
1332 Error_Msg_Name_1 := Expected_Name;
1333
1334 if Is_Config_File then
1335 Extension := new String'(Config_Project_File_Extension);
1336
1337 else
1338 Extension := new String'(Project_File_Extension);
1339 end if;
1340
1341 Error_Msg
1342 (Flags,
1343 "?file name does not match project name, should be `%%"
1344 & Extension.all & "`",
1345 Token_Ptr);
1346 end if;
1347 end;
1348
1349 -- Read the original casing of the project name
1350
1351 declare
1352 Loc : Source_Ptr;
1353
1354 begin
1355 Loc := Location_Of (Project, In_Tree);
1356 for J in 1 .. Name_Len loop
1357 Name_Buffer (J) := Sinput.Source (Loc);
1358 Loc := Loc + 1;
1359 end loop;
1360
1361 Display_Name_Of_Project := Name_Find;
1362 end;
1363
1364 declare
1365 From_Ext : Extension_Origin := None;
1366
1367 begin
1368 -- Extending_All is always propagated
1369
1370 if From_Extended = Extending_All or else Extends_All then
1371 From_Ext := Extending_All;
1372
1373 -- Otherwise, From_Extended is set to Extending_Single if the
1374 -- current project is an extending project.
1375
1376 elsif Extended then
1377 From_Ext := Extending_Simple;
1378 end if;
1379
1380 Post_Parse_Context_Clause
1381 (In_Tree => In_Tree,
1382 Context_Clause => First_With,
1383 Limited_Withs => False,
1384 Imported_Projects => Imported_Projects,
1385 Project_Directory => Project_Directory,
1386 From_Extended => From_Ext,
1387 In_Limited => In_Limited,
1388 Packages_To_Check => Packages_To_Check,
1389 Depth => Depth + 1,
1390 Current_Dir => Current_Dir,
1391 Is_Config_File => Is_Config_File,
1392 Flags => Flags);
1393 Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects);
1394 end;
1395
1396 if not Is_Config_File then
1397 declare
1398 Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
1399 Tree_Private_Part.Projects_Htable.Get_First
1400 (In_Tree.Projects_HT);
1401 Project_Name : Name_Id := Name_And_Node.Name;
1402
1403 begin
1404 -- Check if we already have a project with this name
1405
1406 while Project_Name /= No_Name
1407 and then Project_Name /= Name_Of_Project
1408 loop
1409 Name_And_Node :=
1410 Tree_Private_Part.Projects_Htable.Get_Next
1411 (In_Tree.Projects_HT);
1412 Project_Name := Name_And_Node.Name;
1413 end loop;
1414
1415 -- Report an error if we already have a project with this name
1416
1417 if Project_Name /= No_Name then
1418 Duplicated := True;
1419 Error_Msg_Name_1 := Project_Name;
1420 Error_Msg
1421 (Flags, "duplicate project name %%",
1422 Location_Of (Project, In_Tree));
1423 Error_Msg_Name_1 :=
1424 Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree));
1425 Error_Msg
1426 (Flags, "\already in %%", Location_Of (Project, In_Tree));
1427 end if;
1428 end;
1429 end if;
1430
1431 end if;
1432
1433 if Extending then
1434 Expect (Tok_String_Literal, "literal string");
1435
1436 if Token = Tok_String_Literal then
1437 Set_Extended_Project_Path_Of
1438 (Project,
1439 In_Tree,
1440 Path_Name_Type (Token_Name));
1441
1442 declare
1443 Original_Path_Name : constant String :=
1444 Get_Name_String (Token_Name);
1445
1446 Extended_Project_Path_Name : constant String :=
1447 Project_Path_Name_Of
1448 (In_Tree,
1449 Original_Path_Name,
1450 Get_Name_String
1451 (Project_Directory));
1452
1453 begin
1454 if Extended_Project_Path_Name = "" then
1455
1456 -- We could not find the project file to extend
1457
1458 Error_Msg_Name_1 := Token_Name;
1459
1460 Error_Msg (Flags, "unknown project file: %%", Token_Ptr);
1461
1462 -- If we are not in the main project file, display the
1463 -- import path.
1464
1465 if Project_Stack.Last > 1 then
1466 Error_Msg_Name_1 :=
1467 Name_Id
1468 (Project_Stack.Table (Project_Stack.Last).Path_Name);
1469 Error_Msg (Flags, "\extended by %%", Token_Ptr);
1470
1471 for Index in reverse 1 .. Project_Stack.Last - 1 loop
1472 Error_Msg_Name_1 :=
1473 Name_Id
1474 (Project_Stack.Table (Index).Path_Name);
1475 Error_Msg (Flags, "\imported by %%", Token_Ptr);
1476 end loop;
1477 end if;
1478
1479 else
1480 declare
1481 From_Ext : Extension_Origin := None;
1482
1483 begin
1484 if From_Extended = Extending_All or else Extends_All then
1485 From_Ext := Extending_All;
1486 end if;
1487
1488 Parse_Single_Project
1489 (In_Tree => In_Tree,
1490 Project => Extended_Project,
1491 Extends_All => Extends_All,
1492 Path_Name => Extended_Project_Path_Name,
1493 Extended => True,
1494 From_Extended => From_Ext,
1495 In_Limited => In_Limited,
1496 Packages_To_Check => Packages_To_Check,
1497 Depth => Depth + 1,
1498 Current_Dir => Current_Dir,
1499 Is_Config_File => Is_Config_File,
1500 Flags => Flags);
1501 end;
1502
1503 if Present (Extended_Project) then
1504
1505 -- A project that extends an extending-all project is
1506 -- also an extending-all project.
1507
1508 if Is_Extending_All (Extended_Project, In_Tree) then
1509 Set_Is_Extending_All (Project, In_Tree);
1510 end if;
1511
1512 -- An abstract project can only extend an abstract
1513 -- project, otherwise we may have an abstract project
1514 -- with sources, if it inherits sources from the project
1515 -- it extends.
1516
1517 if Proj_Qualifier = Dry and then
1518 Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry
1519 then
1520 Error_Msg
1521 (Flags, "an abstract project can only extend " &
1522 "another abstract project",
1523 Qualifier_Location);
1524 end if;
1525 end if;
1526 end if;
1527 end;
1528
1529 Scan (In_Tree); -- past the extended project path
1530 end if;
1531 end if;
1532
1533 -- Check that a non extending-all project does not import an
1534 -- extending-all project.
1535
1536 if not Is_Extending_All (Project, In_Tree) then
1537 declare
1538 With_Clause : Project_Node_Id :=
1539 First_With_Clause_Of (Project, In_Tree);
1540 Imported : Project_Node_Id := Empty_Node;
1541
1542 begin
1543 With_Clause_Loop :
1544 while Present (With_Clause) loop
1545 Imported := Project_Node_Of (With_Clause, In_Tree);
1546
1547 if Is_Extending_All (With_Clause, In_Tree) then
1548 Error_Msg_Name_1 := Name_Of (Imported, In_Tree);
1549 Error_Msg (Flags, "cannot import extending-all project %%",
1550 Token_Ptr);
1551 exit With_Clause_Loop;
1552 end if;
1553
1554 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
1555 end loop With_Clause_Loop;
1556 end;
1557 end if;
1558
1559 -- Check that a project with a name including a dot either imports
1560 -- or extends the project whose name precedes the last dot.
1561
1562 if Name_Of_Project /= No_Name then
1563 Get_Name_String (Name_Of_Project);
1564
1565 else
1566 Name_Len := 0;
1567 end if;
1568
1569 -- Look for the last dot
1570
1571 while Name_Len > 0 and then Name_Buffer (Name_Len) /= '.' loop
1572 Name_Len := Name_Len - 1;
1573 end loop;
1574
1575 -- If a dot was find, check if the parent project is imported
1576 -- or extended.
1577
1578 if Name_Len > 0 then
1579 Name_Len := Name_Len - 1;
1580
1581 declare
1582 Parent_Name : constant Name_Id := Name_Find;
1583 Parent_Found : Boolean := False;
1584 Parent_Node : Project_Node_Id := Empty_Node;
1585 With_Clause : Project_Node_Id :=
1586 First_With_Clause_Of (Project, In_Tree);
1587
1588 begin
1589 -- If there is an extended project, check its name
1590
1591 if Present (Extended_Project) then
1592 Parent_Node := Extended_Project;
1593 Parent_Found :=
1594 Name_Of (Extended_Project, In_Tree) = Parent_Name;
1595 end if;
1596
1597 -- If the parent project is not the extended project,
1598 -- check each imported project until we find the parent project.
1599
1600 while not Parent_Found and then Present (With_Clause) loop
1601 Parent_Node := Project_Node_Of (With_Clause, In_Tree);
1602 Parent_Found := Name_Of (Parent_Node, In_Tree) = Parent_Name;
1603 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
1604 end loop;
1605
1606 if Parent_Found then
1607 Set_Parent_Project_Of (Project, In_Tree, To => Parent_Node);
1608
1609 else
1610 -- If the parent project was not found, report an error
1611
1612 Error_Msg_Name_1 := Name_Of_Project;
1613 Error_Msg_Name_2 := Parent_Name;
1614 Error_Msg (Flags,
1615 "project %% does not import or extend project %%",
1616 Location_Of (Project, In_Tree));
1617 end if;
1618 end;
1619 end if;
1620
1621 Expect (Tok_Is, "IS");
1622 Set_End_Of_Line (Project);
1623 Set_Previous_Line_Node (Project);
1624 Set_Next_End_Node (Project);
1625
1626 declare
1627 Project_Declaration : Project_Node_Id := Empty_Node;
1628
1629 begin
1630 -- No need to Scan past "is", Prj.Dect.Parse will do it
1631
1632 Prj.Dect.Parse
1633 (In_Tree => In_Tree,
1634 Declarations => Project_Declaration,
1635 Current_Project => Project,
1636 Extends => Extended_Project,
1637 Packages_To_Check => Packages_To_Check,
1638 Is_Config_File => Is_Config_File,
1639 Flags => Flags);
1640 Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration);
1641
1642 if Present (Extended_Project)
1643 and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry
1644 then
1645 Set_Extending_Project_Of
1646 (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree,
1647 To => Project);
1648 end if;
1649 end;
1650
1651 Expect (Tok_End, "END");
1652 Remove_Next_End_Node;
1653
1654 -- Skip "end" if present
1655
1656 if Token = Tok_End then
1657 Scan (In_Tree);
1658 end if;
1659
1660 -- Clear the Buffer
1661
1662 Buffer_Last := 0;
1663
1664 -- Store the name following "end" in the Buffer. The name may be made of
1665 -- several simple names.
1666
1667 loop
1668 Expect (Tok_Identifier, "identifier");
1669
1670 -- If we don't have an identifier, clear the buffer before exiting to
1671 -- avoid checking the name.
1672
1673 if Token /= Tok_Identifier then
1674 Buffer_Last := 0;
1675 exit;
1676 end if;
1677
1678 -- Add the identifier to the Buffer
1679 Get_Name_String (Token_Name);
1680 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1681
1682 -- Scan past the identifier
1683
1684 Scan (In_Tree);
1685 exit when Token /= Tok_Dot;
1686 Add_To_Buffer (".", Buffer, Buffer_Last);
1687 Scan (In_Tree);
1688 end loop;
1689
1690 -- If we have a valid name, check if it is the name of the project
1691
1692 if Name_Of_Project /= No_Name and then Buffer_Last > 0 then
1693 if To_Lower (Buffer (1 .. Buffer_Last)) /=
1694 Get_Name_String (Name_Of (Project, In_Tree))
1695 then
1696 -- Invalid name: report an error
1697
1698 Error_Msg (Flags, "expected """ &
1699 Get_Name_String (Name_Of (Project, In_Tree)) & """",
1700 Token_Ptr);
1701 end if;
1702 end if;
1703
1704 Expect (Tok_Semicolon, "`;`");
1705
1706 -- Check that there is no more text following the end of the project
1707 -- source.
1708
1709 if Token = Tok_Semicolon then
1710 Set_Previous_End_Node (Project);
1711 Scan (In_Tree);
1712
1713 if Token /= Tok_EOF then
1714 Error_Msg
1715 (Flags, "unexpected text following end of project", Token_Ptr);
1716 end if;
1717 end if;
1718
1719 if not Duplicated and then Name_Of_Project /= No_Name then
1720
1721 -- Add the name of the project to the hash table, so that we can
1722 -- check that no other subsequent project will have the same name.
1723
1724 Tree_Private_Part.Projects_Htable.Set
1725 (T => In_Tree.Projects_HT,
1726 K => Name_Of_Project,
1727 E => (Name => Name_Of_Project,
1728 Display_Name => Display_Name_Of_Project,
1729 Node => Project,
1730 Canonical_Path => Canonical_Path_Name,
1731 Extended => Extended,
1732 Proj_Qualifier => Proj_Qualifier));
1733 end if;
1734
1735 declare
1736 From_Ext : Extension_Origin := None;
1737
1738 begin
1739 -- Extending_All is always propagated
1740
1741 if From_Extended = Extending_All or else Extends_All then
1742 From_Ext := Extending_All;
1743
1744 -- Otherwise, From_Extended is set to Extending_Single if the
1745 -- current project is an extending project.
1746
1747 elsif Extended then
1748 From_Ext := Extending_Simple;
1749 end if;
1750
1751 Post_Parse_Context_Clause
1752 (In_Tree => In_Tree,
1753 Context_Clause => First_With,
1754 Limited_Withs => True,
1755 Imported_Projects => Imported_Projects,
1756 Project_Directory => Project_Directory,
1757 From_Extended => From_Ext,
1758 In_Limited => In_Limited,
1759 Packages_To_Check => Packages_To_Check,
1760 Depth => Depth + 1,
1761 Current_Dir => Current_Dir,
1762 Is_Config_File => Is_Config_File,
1763 Flags => Flags);
1764 Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects);
1765 end;
1766
1767 -- Restore the scan state, in case we are not the main project
1768
1769 Restore_Project_Scan_State (Project_Scan_State);
1770
1771 -- And remove the project from the project stack
1772
1773 Project_Stack.Decrement_Last;
1774
1775 -- Indicate if there are unkept comments
1776
1777 Tree.Set_Project_File_Includes_Unkept_Comments
1778 (Node => Project,
1779 In_Tree => In_Tree,
1780 To => Tree.There_Are_Unkept_Comments);
1781
1782 -- And restore the comment state that was saved
1783
1784 Tree.Restore_And_Free (Project_Comment_State);
1785 end Parse_Single_Project;
1786
1787 -----------------------
1788 -- Project_Name_From --
1789 -----------------------
1790
1791 function Project_Name_From
1792 (Path_Name : String;
1793 Is_Config_File : Boolean) return Name_Id
1794 is
1795 Canonical : String (1 .. Path_Name'Length) := Path_Name;
1796 First : Natural := Canonical'Last;
1797 Last : Natural := First;
1798 Index : Positive;
1799
1800 begin
1801 if Current_Verbosity = High then
1802 Write_Str ("Project_Name_From (""");
1803 Write_Str (Canonical);
1804 Write_Line (""")");
1805 end if;
1806
1807 -- If the path name is empty, return No_Name to indicate failure
1808
1809 if First = 0 then
1810 return No_Name;
1811 end if;
1812
1813 Canonical_Case_File_Name (Canonical);
1814
1815 -- Look for the last dot in the path name
1816
1817 while First > 0
1818 and then
1819 Canonical (First) /= '.'
1820 loop
1821 First := First - 1;
1822 end loop;
1823
1824 -- If we have a dot, check that it is followed by the correct extension
1825
1826 if First > 0 and then Canonical (First) = '.' then
1827 if (not Is_Config_File
1828 and then Canonical (First .. Last) = Project_File_Extension
1829 and then First /= 1)
1830 or else
1831 (Is_Config_File
1832 and then
1833 Canonical (First .. Last) = Config_Project_File_Extension
1834 and then First /= 1)
1835 then
1836 -- Look for the last directory separator, if any
1837
1838 First := First - 1;
1839 Last := First;
1840 while First > 0
1841 and then Canonical (First) /= '/'
1842 and then Canonical (First) /= Dir_Sep
1843 loop
1844 First := First - 1;
1845 end loop;
1846
1847 else
1848 -- Not the correct extension, return No_Name to indicate failure
1849
1850 return No_Name;
1851 end if;
1852
1853 -- If no dot in the path name, return No_Name to indicate failure
1854
1855 else
1856 return No_Name;
1857 end if;
1858
1859 First := First + 1;
1860
1861 -- If the extension is the file name, return No_Name to indicate failure
1862
1863 if First > Last then
1864 return No_Name;
1865 end if;
1866
1867 -- Put the name in lower case into Name_Buffer
1868
1869 Name_Len := Last - First + 1;
1870 Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last));
1871
1872 Index := 1;
1873
1874 -- Check if it is a well formed project name. Return No_Name if it is
1875 -- ill formed.
1876
1877 loop
1878 if not Is_Letter (Name_Buffer (Index)) then
1879 return No_Name;
1880
1881 else
1882 loop
1883 Index := Index + 1;
1884
1885 exit when Index >= Name_Len;
1886
1887 if Name_Buffer (Index) = '_' then
1888 if Name_Buffer (Index + 1) = '_' then
1889 return No_Name;
1890 end if;
1891 end if;
1892
1893 exit when Name_Buffer (Index) = '-';
1894
1895 if Name_Buffer (Index) /= '_'
1896 and then not Is_Alphanumeric (Name_Buffer (Index))
1897 then
1898 return No_Name;
1899 end if;
1900
1901 end loop;
1902 end if;
1903
1904 if Index >= Name_Len then
1905 if Is_Alphanumeric (Name_Buffer (Name_Len)) then
1906
1907 -- All checks have succeeded. Return name in Name_Buffer
1908
1909 return Name_Find;
1910
1911 else
1912 return No_Name;
1913 end if;
1914
1915 elsif Name_Buffer (Index) = '-' then
1916 Index := Index + 1;
1917 end if;
1918 end loop;
1919 end Project_Name_From;
1920
1921 --------------------------
1922 -- Project_Path_Name_Of --
1923 --------------------------
1924
1925 function Project_Path_Name_Of
1926 (In_Tree : Project_Node_Tree_Ref;
1927 Project_File_Name : String;
1928 Directory : String) return String
1929 is
1930
1931 function Try_Path_Name (Path : String) return String_Access;
1932 pragma Inline (Try_Path_Name);
1933 -- Try the specified Path
1934
1935 -------------------
1936 -- Try_Path_Name --
1937 -------------------
1938
1939 function Try_Path_Name (Path : String) return String_Access is
1940 Prj_Path : constant String := Project_Path (In_Tree);
1941 First : Natural;
1942 Last : Natural;
1943 Result : String_Access := null;
1944
1945 begin
1946 if Current_Verbosity = High then
1947 Write_Str (" Trying ");
1948 Write_Line (Path);
1949 end if;
1950
1951 if Is_Absolute_Path (Path) then
1952 if Is_Regular_File (Path) then
1953 Result := new String'(Path);
1954 end if;
1955
1956 else
1957 -- Because we don't want to resolve symbolic links, we cannot use
1958 -- Locate_Regular_File. So, we try each possible path
1959 -- successively.
1960
1961 First := Prj_Path'First;
1962 while First <= Prj_Path'Last loop
1963 while First <= Prj_Path'Last
1964 and then Prj_Path (First) = Path_Separator
1965 loop
1966 First := First + 1;
1967 end loop;
1968
1969 exit when First > Prj_Path'Last;
1970
1971 Last := First;
1972 while Last < Prj_Path'Last
1973 and then Prj_Path (Last + 1) /= Path_Separator
1974 loop
1975 Last := Last + 1;
1976 end loop;
1977
1978 Name_Len := 0;
1979
1980 if not Is_Absolute_Path (Prj_Path (First .. Last)) then
1981 Add_Str_To_Name_Buffer (Get_Current_Dir);
1982 Add_Char_To_Name_Buffer (Directory_Separator);
1983 end if;
1984
1985 Add_Str_To_Name_Buffer (Prj_Path (First .. Last));
1986 Add_Char_To_Name_Buffer (Directory_Separator);
1987 Add_Str_To_Name_Buffer (Path);
1988
1989 if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
1990 Result := new String'(Name_Buffer (1 .. Name_Len));
1991 exit;
1992 end if;
1993
1994 First := Last + 1;
1995 end loop;
1996 end if;
1997
1998 return Result;
1999 end Try_Path_Name;
2000
2001 -- Local Declarations
2002
2003 Result : String_Access;
2004 Result_Id : Path_Name_Type;
2005 Has_Dot : Boolean := False;
2006 Key : Name_Id;
2007
2008 -- Start of processing for Project_Path_Name_Of
2009
2010 begin
2011 if Current_Verbosity = High then
2012 Write_Str ("Project_Path_Name_Of (""");
2013 Write_Str (Project_File_Name);
2014 Write_Str (""", """);
2015 Write_Str (Directory);
2016 Write_Line (""");");
2017 end if;
2018
2019 -- Check the project cache
2020
2021 Name_Len := Project_File_Name'Length;
2022 Name_Buffer (1 .. Name_Len) := Project_File_Name;
2023 Key := Name_Find;
2024 Result_Id := Projects_Paths.Get (Key);
2025
2026 if Result_Id /= No_Path then
2027 return Get_Name_String (Result_Id);
2028 end if;
2029
2030 -- Check if Project_File_Name contains an extension (a dot before a
2031 -- directory separator). If it is the case we do not try project file
2032 -- with an added extension as it is not possible to have multiple dots
2033 -- on a project file name.
2034
2035 Check_Dot : for K in reverse Project_File_Name'Range loop
2036 if Project_File_Name (K) = '.' then
2037 Has_Dot := True;
2038 exit Check_Dot;
2039 end if;
2040
2041 exit Check_Dot when Project_File_Name (K) = Directory_Separator
2042 or else Project_File_Name (K) = '/';
2043 end loop Check_Dot;
2044
2045 if not Is_Absolute_Path (Project_File_Name) then
2046
2047 -- First we try <directory>/<file_name>.<extension>
2048
2049 if not Has_Dot then
2050 Result := Try_Path_Name
2051 (Directory & Directory_Separator &
2052 Project_File_Name & Project_File_Extension);
2053 end if;
2054
2055 -- Then we try <directory>/<file_name>
2056
2057 if Result = null then
2058 Result := Try_Path_Name
2059 (Directory & Directory_Separator & Project_File_Name);
2060 end if;
2061 end if;
2062
2063 -- Then we try <file_name>.<extension>
2064
2065 if Result = null and then not Has_Dot then
2066 Result := Try_Path_Name (Project_File_Name & Project_File_Extension);
2067 end if;
2068
2069 -- Then we try <file_name>
2070
2071 if Result = null then
2072 Result := Try_Path_Name (Project_File_Name);
2073 end if;
2074
2075 -- If we cannot find the project file, we return an empty string
2076
2077 if Result = null then
2078 return "";
2079
2080 else
2081 declare
2082 Final_Result : constant String :=
2083 GNAT.OS_Lib.Normalize_Pathname
2084 (Result.all,
2085 Directory => Directory,
2086 Resolve_Links => Opt.Follow_Links_For_Files,
2087 Case_Sensitive => True);
2088 begin
2089 Free (Result);
2090 Name_Len := Final_Result'Length;
2091 Name_Buffer (1 .. Name_Len) := Final_Result;
2092 Result_Id := Name_Find;
2093
2094 Projects_Paths.Set (Key, Result_Id);
2095 return Final_Result;
2096 end;
2097 end if;
2098 end Project_Path_Name_Of;
2099
2100 end Prj.Part;