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