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