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