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