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