| blob | 5d09dbe6010bb820681c3c954fa780eda9b84b64 |
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-2012, 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 ------------------------------------------------------------------------------
52 ------------------------------------
53 -- Local Packages and Subprograms --
54 ------------------------------------
66 -- Information about an imported project, to be put in table Withs below
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.
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.
107 -- Hash table to store the node ids of projects for which a virtual
108 -- extending project need to be created. The corresponding value is the
109 -- head of a list of WITH clauses corresponding to the context of the
110 -- enclosing EXTEND ALL projects. Note: Default_Element is Project_Node_
111 -- High_Bound because we want Empty_Node to be a possible value.
120 -- Hash table to store the project process when looking for project that
121 -- need to have a virtual extending project, to avoid processing the same
122 -- project twice.
124 function Has_Circular_Dependencies
128 -- Check for a circular dependency in the loaded project.
129 -- Generates an error message in such a case.
131 procedure Read_Project_Qualifier
137 -- Check if there is a qualifier before the reserved word "project"
139 -- Hash table to cache project path to avoid looking for them on the path
141 procedure Check_Extending_All_Imports
145 -- Check that a non extending-all project does not import an
146 -- extending-all project.
148 procedure Check_Aggregate_Imports
152 -- Check that an aggregate project only imports abstract projects
154 procedure Create_Virtual_Extending_Project
159 -- Create a virtual extending project of For_Project. Main_Project is
160 -- the extending all project. Extension_Withs is the head of a WITH clause
161 -- list to be added to the created virtual project.
162 --
163 -- The String_Value_Of is not set for the automatically added with
164 -- clause and keeps the default value of No_Name. This enables Prj.PP
165 -- to skip these automatically added with clauses to be processed.
167 procedure Look_For_Virtual_Projects_For
171 -- Look for projects that need to have a virtual extending project.
172 -- This procedure is recursive. If called with Potentially_Virtual set to
173 -- True, then Proj may need an virtual extending project; otherwise it
174 -- does not (because it is already extended), but other projects that it
175 -- imports may need to be virtually extended.
178 -- Type of parameter From_Extended for procedures Parse_Single_Project and
179 -- Post_Parse_Context_Clause. Extending_All means that we are parsing the
180 -- tree rooted at an extending all project.
182 procedure Parse_Single_Project
195 -- Parse a project file. This is a recursive procedure: it calls itself for
196 -- imported and extended projects. When From_Extended is not None, if the
197 -- project has already been parsed and is an extended project A, return the
198 -- ultimate (not extended) project that extends A. When In_Limited is True,
199 -- the importing path includes at least one "limited with". When parsing
200 -- configuration projects, do not allow a depth > 1.
201 --
202 -- Is_Config_File should be set to True if the project represents a config
203 -- file (.cgpr) since some specific checks apply.
205 procedure Pre_Parse_Context_Clause
210 -- Parse the context clause of a project. Store the paths and locations of
211 -- the imported projects in table Withs. Does nothing if there is no
212 -- context clause (if the current token is not "with" or "limited" followed
213 -- by "with").
214 -- Is_Config_File should be set to True if the project represents a config
215 -- file (.cgpr) since some specific checks apply.
217 procedure Post_Parse_Context_Clause
230 -- Parse the imported projects that have been stored in table Withs, if
231 -- any. From_Extended is used for the call to Parse_Single_Project below.
232 --
233 -- When In_Limited is True, the importing path includes at least one
234 -- "limited with". When Limited_Withs is False, only non limited withed
235 -- projects are parsed. When Limited_Withs is True, only limited withed
236 -- projects are parsed.
237 --
238 -- Is_Config_File should be set to True if the project represents a config
239 -- file (.cgpr) since some specific checks apply.
241 function Project_Name_From
244 -- Returns the name of the project that corresponds to its path name.
245 -- Returns No_Name if the path name is invalid, because the corresponding
246 -- project name does not have the syntax of an ada identifier.
248 function Copy_With_Clause
252 -- Return a copy of With_Clause in In_Tree, whose Next_With_Clause is the
253 -- indicated one.
255 ----------------------
256 -- Copy_With_Clause --
257 ----------------------
259 function Copy_With_Clause
263 is
266 begin
278 --------------------------------------
279 -- Create_Virtual_Extending_Project --
280 --------------------------------------
282 procedure Create_Virtual_Extending_Project
287 is
290 Virtual_Prefix &
292 -- The name of the virtual extending project
295 -- Virtual extending project name id
298 -- Fake path name of the virtual extending project. The directory is
299 -- the same directory as the extending all project.
301 -- The source of the virtual extending project is something like:
303 -- project V$<project name> extends <project path> is
305 -- for Source_Dirs use ();
307 -- end V$<project name>;
309 -- The project directory cannot be specified during parsing; it will be
310 -- put directly in the virtual extending project data during processing.
312 -- Nodes that made up the virtual extending project
316 Default_Project_Node
320 Default_Project_Node
323 Default_Project_Node
326 Default_Project_Node
329 Default_Project_Node
332 Default_Project_Node
335 begin
336 -- Get the virtual path name
343 loop
348 Virtual_Name;
352 -- Get the virtual name id
358 Virtual_Project := Create_Project
366 -- Add a WITH clause to the main project to import the newly created
367 -- virtual extending project.
372 Set_Next_With_Clause_Of
376 -- Copy with clauses for projects imported by the extending-all project
378 declare
382 begin
384 New_With_Clause :=
393 -- Virtual project node
395 Set_Location_Of
397 Set_Extended_Project_Path_Of
400 -- Project declaration
402 Set_First_Declarative_Item_Of
406 -- Source_Dirs declaration
408 Set_Current_Item_Node
411 -- Source_Dirs attribute
414 Set_Expression_Of
417 -- Source_Dirs expression
421 -- Source_Dirs term
425 -- Source_Dirs empty list: nothing to do
428 -----------------------------------
429 -- Look_For_Virtual_Projects_For --
430 -----------------------------------
433 -- Head of the current EXTENDS ALL imports list. When creating virtual
434 -- projects for an EXTENDS ALL, we import in each virtual project all
435 -- of the projects that appear in WITH clauses of the extending projects.
436 -- This ensures that virtual projects share a consistent environment (in
437 -- particular if a project imported by one of the extending projects
438 -- replaces some runtime units).
440 procedure Look_For_Virtual_Projects_For
444 is
446 -- Node for the project declaration of Proj
449 -- Node for a with clause of Proj
452 -- Node for a project imported by Proj
455 -- Node for the eventual project extended by Proj
458 -- Set True if Proj is an EXTENDS ALL project
462 begin
463 -- Nothing to do if Proj is undefined or has already been processed
467 -- Make sure the project will not be processed again
478 -- If this is a project that may need a virtual extending project
479 -- and it is not itself an extending project, put it in the list.
485 -- Now check the projects it imports
492 Look_For_Virtual_Projects_For
498 -- This is an EXTENDS ALL project: prepend each of its WITH
499 -- clauses to the currently active list of extension deps.
501 Extension_Withs :=
508 -- Check also the eventual project extended by Proj. As this project
509 -- is already extended, call recursively with Potentially_Virtual
510 -- being False.
512 Look_For_Virtual_Projects_For
519 -----------
520 -- Parse --
521 -----------
523 procedure Parse
534 is
539 Osint.To_Canonical_File_Spec
543 begin
553 end if;
555 Project := Empty_Node;
557 Find_Project (Env.Project_Path,
558 Project_File_Name => Real_Project_File_Name.all,
559 Directory => Current_Directory,
560 Path => Path_Name_Id);
561 Free (Real_Project_File_Name);
563 if Errout_Handling /= Never_Finalize then
564 Prj.Err.Initialize;
565 end if;
567 Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments);
568 Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments);
570 if Path_Name_Id = No_Path then
571 declare
572 P : String_Access;
573 begin
574 Get_Path (Env.Project_Path, Path => P);
576 Prj.Com.Fail
577 ("project file """
578 & Project_File_Name
579 & """ not found in "
580 & P.all);
581 Project := Empty_Node;
582 return;
583 end;
584 end if;
586 -- Parse the main project file
588 begin
589 Parse_Single_Project
590 (In_Tree => In_Tree,
591 Project => Project,
592 Extends_All => Dummy,
593 Path_Name_Id => Path_Name_Id,
594 Extended => False,
595 From_Extended => None,
596 In_Limited => False,
597 Packages_To_Check => Packages_To_Check,
598 Depth => 0,
599 Current_Dir => Current_Directory,
600 Is_Config_File => Is_Config_File,
601 Env => Env);
603 exception
604 when Types.Unrecoverable_Error =>
606 -- Unrecoverable_Error is raised when a line is too long.
607 -- A meaningful error message will be displayed later.
609 Project := Empty_Node;
610 end;
612 -- If Project is an extending-all project, create the eventual
613 -- virtual extending projects and check that there are no illegally
614 -- imported projects.
616 if Present (Project)
617 and then Is_Extending_All (Project, In_Tree)
618 then
619 -- First look for projects that potentially need a virtual
620 -- extending project.
622 Virtual_Hash.Reset;
623 Processed_Hash.Reset;
625 -- Mark the extending all project as processed, to avoid checking
626 -- the imported projects in case of a "limited with" on this
627 -- extending all project.
629 Processed_Hash.Set (Project, True);
631 declare
632 Declaration : constant Project_Node_Id :=
633 Project_Declaration_Of (Project, In_Tree);
634 begin
635 Extension_Withs := First_With_Clause_Of (Project, In_Tree);
636 Look_For_Virtual_Projects_For
637 (Extended_Project_Of (Declaration, In_Tree), In_Tree,
638 Potentially_Virtual => False);
639 end;
641 -- Now, check the projects directly imported by the main project.
642 -- Remove from the potentially virtual any project extended by one
643 -- of these imported projects.
645 declare
646 With_Clause : Project_Node_Id;
647 Imported : Project_Node_Id := Empty_Node;
648 Declaration : Project_Node_Id := Empty_Node;
650 begin
651 With_Clause := First_With_Clause_Of (Project, In_Tree);
652 while Present (With_Clause) loop
653 Imported := Project_Node_Of (With_Clause, In_Tree);
655 if Present (Imported) then
656 Declaration := Project_Declaration_Of (Imported, In_Tree);
658 if Extended_Project_Of (Declaration, In_Tree) /=
659 Empty_Node
660 then
661 loop
662 Imported :=
663 Extended_Project_Of (Declaration, In_Tree);
664 exit when No (Imported);
665 Virtual_Hash.Remove (Imported);
666 Declaration :=
667 Project_Declaration_Of (Imported, In_Tree);
668 end loop;
669 end if;
670 end if;
672 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
673 end loop;
674 end;
676 -- Now create all the virtual extending projects
678 declare
679 Proj : Project_Node_Id := Empty_Node;
680 Withs : Project_Node_Id;
681 begin
682 Virtual_Hash.Get_First (Proj, Withs);
683 while Withs /= Project_Node_High_Bound loop
684 Create_Virtual_Extending_Project
685 (Proj, Project, Withs, In_Tree);
686 Virtual_Hash.Get_Next (Proj, Withs);
687 end loop;
688 end;
689 end if;
691 -- If there were any kind of error during the parsing, serious
692 -- or not, then the parsing fails.
694 if Total_Errors_Detected > 0 then
695 Project := Empty_Node;
696 end if;
698 case Errout_Handling is
699 when Always_Finalize =>
700 Prj.Err.Finalize;
702 -- Reinitialize to avoid duplicate warnings later on
703 Prj.Err.Initialize;
705 when Finalize_If_Error =>
706 if No (Project) then
707 Prj.Err.Finalize;
708 Prj.Err.Initialize;
709 end if;
711 when Never_Finalize =>
712 null;
713 end case;
715 exception
716 when X : others =>
718 -- Internal error
720 Write_Line (Exception_Information (X));
721 Write_Str ("Exception ");
722 Write_Str (Exception_Name (X));
723 Write_Line (" raised, while processing project file");
724 Project := Empty_Node;
725 end Parse;
727 ------------------------------
728 -- Pre_Parse_Context_Clause --
729 ------------------------------
731 procedure Pre_Parse_Context_Clause
732 (In_Tree : Project_Node_Tree_Ref;
733 Context_Clause : out With_Id;
734 Is_Config_File : Boolean;
735 Flags : Processing_Flags)
736 is
737 Current_With_Clause : With_Id := No_With;
738 Limited_With : Boolean := False;
739 Current_With : With_Record;
740 Current_With_Node : Project_Node_Id := Empty_Node;
742 begin
743 -- Assume no context clause
745 Context_Clause := No_With;
746 With_Loop :
748 -- If Token is not WITH or LIMITED, there is no context clause, or we
749 -- have exhausted the with clauses.
751 while Token = Tok_With or else Token = Tok_Limited loop
752 Current_With_Node :=
753 Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => In_Tree);
754 Limited_With := Token = Tok_Limited;
756 if Is_Config_File then
757 Error_Msg
758 (Flags,
759 "configuration project cannot import " &
760 "other configuration projects",
761 Token_Ptr);
762 end if;
764 if Limited_With then
765 Scan (In_Tree); -- past LIMITED
766 Expect (Tok_With, "WITH");
767 exit With_Loop when Token /= Tok_With;
768 end if;
770 Comma_Loop :
771 loop
772 Scan (In_Tree); -- past WITH or ","
774 Expect (Tok_String_Literal, "literal string");
776 if Token /= Tok_String_Literal then
777 return;
778 end if;
780 -- Store path and location in table Withs
782 Current_With :=
783 (Path => Path_Name_Type (Token_Name),
784 Location => Token_Ptr,
785 Limited_With => Limited_With,
786 Node => Current_With_Node,
787 Next => No_With);
789 Withs.Increment_Last;
790 Withs.Table (Withs.Last) := Current_With;
792 if Current_With_Clause = No_With then
793 Context_Clause := Withs.Last;
795 else
796 Withs.Table (Current_With_Clause).Next := Withs.Last;
797 end if;
799 Current_With_Clause := Withs.Last;
801 Scan (In_Tree);
803 if Token = Tok_Semicolon then
804 Set_End_Of_Line (Current_With_Node);
805 Set_Previous_Line_Node (Current_With_Node);
807 -- End of (possibly multiple) with clause;
809 Scan (In_Tree); -- past semicolon
810 exit Comma_Loop;
812 elsif Token = Tok_Comma then
813 Set_Is_Not_Last_In_List (Current_With_Node, In_Tree);
815 else
816 Error_Msg (Flags, "expected comma or semi colon", Token_Ptr);
817 exit Comma_Loop;
818 end if;
820 Current_With_Node :=
821 Default_Project_Node
822 (Of_Kind => N_With_Clause, In_Tree => In_Tree);
823 end loop Comma_Loop;
824 end loop With_Loop;
825 end Pre_Parse_Context_Clause;
827 -------------------------------
828 -- Post_Parse_Context_Clause --
829 -------------------------------
831 procedure Post_Parse_Context_Clause
832 (Context_Clause : With_Id;
833 In_Tree : Project_Node_Tree_Ref;
834 In_Limited : Boolean;
835 Limited_Withs : Boolean;
836 Imported_Projects : in out Project_Node_Id;
837 Project_Directory : Path_Name_Type;
838 From_Extended : Extension_Origin;
839 Packages_To_Check : String_List_Access;
840 Depth : Natural;
841 Current_Dir : String;
842 Is_Config_File : Boolean;
843 Env : in out Environment)
844 is
845 Current_With_Clause : With_Id := Context_Clause;
847 Current_Project : Project_Node_Id := Imported_Projects;
848 Previous_Project : Project_Node_Id := Empty_Node;
849 Next_Project : Project_Node_Id := Empty_Node;
851 Project_Directory_Path : constant String :=
852 Get_Name_String (Project_Directory);
854 Current_With : With_Record;
855 Extends_All : Boolean := False;
856 Imported_Path_Name_Id : Path_Name_Type;
858 begin
859 -- Set Current_Project to the last project in the current list, if the
860 -- list is not empty.
862 if Present (Current_Project) then
863 while
864 Present (Next_With_Clause_Of (Current_Project, In_Tree))
865 loop
866 Current_Project := Next_With_Clause_Of (Current_Project, In_Tree);
867 end loop;
868 end if;
870 while Current_With_Clause /= No_With loop
871 Current_With := Withs.Table (Current_With_Clause);
872 Current_With_Clause := Current_With.Next;
874 if Limited_Withs = Current_With.Limited_With then
875 Find_Project
876 (Env.Project_Path,
877 Project_File_Name => Get_Name_String (Current_With.Path),
878 Directory => Project_Directory_Path,
879 Path => Imported_Path_Name_Id);
881 if Imported_Path_Name_Id = No_Path then
882 if Env.Flags.Ignore_Missing_With then
883 In_Tree.Incomplete_With := True;
885 else
886 -- The project file cannot be found
888 Error_Msg_File_1 := File_Name_Type (Current_With.Path);
889 Error_Msg
890 (Env.Flags, "unknown project file: {",
891 Current_With.Location);
893 -- If this is not imported by the main project file, display
894 -- the import path.
896 if Project_Stack.Last > 1 then
897 for Index in reverse 1 .. Project_Stack.Last loop
898 Error_Msg_File_1 :=
899 File_Name_Type
900 (Project_Stack.Table (Index).Path_Name);
901 Error_Msg
903 end loop;
904 end if;
905 end if;
907 else
908 -- New with clause
910 declare
911 Resolved_Path : constant String :=
912 Normalize_Pathname
913 (Get_Name_String (Imported_Path_Name_Id),
914 Directory => Current_Dir,
915 Resolve_Links =>
916 Opt.Follow_Links_For_Files,
917 Case_Sensitive => True);
919 Withed_Project : Project_Node_Id := Empty_Node;
921 begin
922 Previous_Project := Current_Project;
924 if No (Current_Project) then
926 -- First with clause of the context clause
928 Current_Project := Current_With.Node;
929 Imported_Projects := Current_Project;
931 else
932 Next_Project := Current_With.Node;
933 Set_Next_With_Clause_Of
934 (Current_Project, In_Tree, Next_Project);
935 Current_Project := Next_Project;
936 end if;
938 Set_String_Value_Of
939 (Current_Project,
940 In_Tree,
941 Name_Id (Current_With.Path));
942 Set_Location_Of
943 (Current_Project, In_Tree, Current_With.Location);
945 -- If it is a limited with, check if we have a circularity.
946 -- If we have one, get the project id of the limited
947 -- imported project file, and do not parse it.
949 if (In_Limited or Limited_Withs)
950 and then Project_Stack.Last > 1
951 then
952 declare
953 Canonical_Path_Name : Path_Name_Type;
955 begin
956 Name_Len := Resolved_Path'Length;
957 Name_Buffer (1 .. Name_Len) := Resolved_Path;
958 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
959 Canonical_Path_Name := Name_Find;
961 for Index in 1 .. Project_Stack.Last loop
962 if Project_Stack.Table (Index).Canonical_Path_Name =
963 Canonical_Path_Name
964 then
965 -- We have found the limited imported project,
966 -- get its project id, and do not parse it.
968 Withed_Project := Project_Stack.Table (Index).Id;
969 exit;
970 end if;
971 end loop;
972 end;
973 end if;
975 -- Parse the imported project if its project id is unknown
977 if No (Withed_Project) then
978 Parse_Single_Project
979 (In_Tree => In_Tree,
980 Project => Withed_Project,
981 Extends_All => Extends_All,
982 Path_Name_Id => Imported_Path_Name_Id,
983 Extended => False,
984 From_Extended => From_Extended,
985 In_Limited => In_Limited or Limited_Withs,
986 Packages_To_Check => Packages_To_Check,
987 Depth => Depth,
988 Current_Dir => Current_Dir,
989 Is_Config_File => Is_Config_File,
990 Env => Env);
992 else
993 Extends_All := Is_Extending_All (Withed_Project, In_Tree);
994 end if;
996 if No (Withed_Project) then
998 -- If parsing unsuccessful, remove the context clause
1000 Current_Project := Previous_Project;
1002 if No (Current_Project) then
1003 Imported_Projects := Empty_Node;
1005 else
1006 Set_Next_With_Clause_Of
1007 (Current_Project, In_Tree, Empty_Node);
1008 end if;
1009 else
1010 -- If parsing was successful, record project name and
1011 -- path name in with clause
1013 Set_Project_Node_Of
1014 (Node => Current_Project,
1015 In_Tree => In_Tree,
1016 To => Withed_Project,
1017 Limited_With => Current_With.Limited_With);
1018 Set_Name_Of
1019 (Current_Project,
1020 In_Tree,
1021 Name_Of (Withed_Project, In_Tree));
1023 Name_Len := Resolved_Path'Length;
1024 Name_Buffer (1 .. Name_Len) := Resolved_Path;
1025 Set_Path_Name_Of (Current_Project, In_Tree, Name_Find);
1027 if Extends_All then
1028 Set_Is_Extending_All (Current_Project, In_Tree);
1029 end if;
1030 end if;
1031 end;
1032 end if;
1033 end if;
1034 end loop;
1035 end Post_Parse_Context_Clause;
1037 ---------------------------------
1038 -- Check_Extending_All_Imports --
1039 ---------------------------------
1041 procedure Check_Extending_All_Imports
1042 (Flags : Processing_Flags;
1043 In_Tree : Project_Node_Tree_Ref;
1044 Project : Project_Node_Id)
1045 is
1046 With_Clause : Project_Node_Id;
1047 Imported : Project_Node_Id;
1049 begin
1050 if not Is_Extending_All (Project, In_Tree) then
1051 With_Clause := First_With_Clause_Of (Project, In_Tree);
1052 while Present (With_Clause) loop
1053 Imported := Project_Node_Of (With_Clause, In_Tree);
1055 if Is_Extending_All (With_Clause, In_Tree) then
1056 Error_Msg_Name_1 := Name_Of (Imported, In_Tree);
1057 Error_Msg (Flags, "cannot import extending-all project %%",
1058 Token_Ptr);
1059 exit;
1060 end if;
1062 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
1063 end loop;
1064 end if;
1065 end Check_Extending_All_Imports;
1067 -----------------------------
1068 -- Check_Aggregate_Imports --
1069 -----------------------------
1071 procedure Check_Aggregate_Imports
1072 (Flags : Processing_Flags;
1073 In_Tree : Project_Node_Tree_Ref;
1074 Project : Project_Node_Id)
1075 is
1076 With_Clause, Imported : Project_Node_Id;
1077 begin
1078 if Project_Qualifier_Of (Project, In_Tree) = Aggregate then
1079 With_Clause := First_With_Clause_Of (Project, In_Tree);
1081 while Present (With_Clause) loop
1082 Imported := Project_Node_Of (With_Clause, In_Tree);
1084 if Project_Qualifier_Of (Imported, In_Tree) /= Dry then
1085 Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree));
1086 Error_Msg (Flags, "can only import abstract projects, not %%",
1087 Token_Ptr);
1088 exit;
1089 end if;
1091 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
1092 end loop;
1093 end if;
1094 end Check_Aggregate_Imports;
1096 ----------------------------
1097 -- Read_Project_Qualifier --
1098 ----------------------------
1100 procedure Read_Project_Qualifier
1101 (Flags : Processing_Flags;
1102 In_Tree : Project_Node_Tree_Ref;
1103 Is_Config_File : Boolean;
1104 Qualifier_Location : out Source_Ptr;
1105 Project : Project_Node_Id)
1106 is
1107 Proj_Qualifier : Project_Qualifier := Unspecified;
1108 begin
1109 Qualifier_Location := Token_Ptr;
1111 if Token = Tok_Abstract then
1112 Proj_Qualifier := Dry;
1113 Scan (In_Tree);
1115 elsif Token = Tok_Identifier then
1116 case Token_Name is
1117 when Snames.Name_Standard =>
1118 Proj_Qualifier := Standard;
1119 Scan (In_Tree);
1121 when Snames.Name_Aggregate =>
1122 Proj_Qualifier := Aggregate;
1123 Scan (In_Tree);
1125 if Token = Tok_Identifier
1126 and then Token_Name = Snames.Name_Library
1127 then
1128 Proj_Qualifier := Aggregate_Library;
1129 Scan (In_Tree);
1130 end if;
1132 when Snames.Name_Library =>
1133 Proj_Qualifier := Library;
1134 Scan (In_Tree);
1136 when Snames.Name_Configuration =>
1137 if not Is_Config_File then
1138 Error_Msg
1139 (Flags,
1140 "configuration projects cannot belong to a user" &
1141 " project tree",
1142 Token_Ptr);
1143 end if;
1145 Proj_Qualifier := Configuration;
1146 Scan (In_Tree);
1148 when others =>
1149 null;
1150 end case;
1151 end if;
1153 if Is_Config_File and then Proj_Qualifier = Unspecified then
1155 -- Set the qualifier to Configuration, even if the token doesn't
1156 -- exist in the source file itself, so that we can differentiate
1157 -- project files and configuration files later on.
1159 Proj_Qualifier := Configuration;
1160 end if;
1162 if Proj_Qualifier /= Unspecified then
1163 if Is_Config_File
1164 and then Proj_Qualifier /= Configuration
1165 then
1166 Error_Msg (Flags,
1167 "a configuration project cannot be qualified except " &
1168 "as configuration project",
1169 Qualifier_Location);
1170 end if;
1172 Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier);
1173 end if;
1174 end Read_Project_Qualifier;
1176 -------------------------------
1177 -- Has_Circular_Dependencies --
1178 -------------------------------
1180 function Has_Circular_Dependencies
1181 (Flags : Processing_Flags;
1182 Normed_Path_Name : Path_Name_Type;
1183 Canonical_Path_Name : Path_Name_Type) return Boolean is
1184 begin
1185 for Index in reverse 1 .. Project_Stack.Last loop
1186 exit when Project_Stack.Table (Index).Limited_With;
1188 if Canonical_Path_Name =
1189 Project_Stack.Table (Index).Canonical_Path_Name
1190 then
1191 Error_Msg (Flags, "circular dependency detected", Token_Ptr);
1192 Error_Msg_Name_1 := Name_Id (Normed_Path_Name);
1195 for Current in reverse 1 .. Project_Stack.Last loop
1196 Error_Msg_Name_1 :=
1197 Name_Id (Project_Stack.Table (Current).Path_Name);
1199 if Project_Stack.Table (Current).Canonical_Path_Name /=
1200 Canonical_Path_Name
1201 then
1202 Error_Msg
1205 else
1207 exit;
1208 end if;
1209 end loop;
1211 return True;
1212 end if;
1213 end loop;
1214 return False;
1215 end Has_Circular_Dependencies;
1217 --------------------------
1218 -- Parse_Single_Project --
1219 --------------------------
1221 procedure Parse_Single_Project
1222 (In_Tree : Project_Node_Tree_Ref;
1223 Project : out Project_Node_Id;
1224 Extends_All : out Boolean;
1225 Path_Name_Id : Path_Name_Type;
1226 Extended : Boolean;
1227 From_Extended : Extension_Origin;
1228 In_Limited : Boolean;
1229 Packages_To_Check : String_List_Access;
1230 Depth : Natural;
1231 Current_Dir : String;
1232 Is_Config_File : Boolean;
1233 Env : in out Environment)
1234 is
1235 Path_Name : constant String := Get_Name_String (Path_Name_Id);
1237 Normed_Path_Name : Path_Name_Type;
1238 Canonical_Path_Name : Path_Name_Type;
1239 Project_Directory : Path_Name_Type;
1240 Project_Scan_State : Saved_Project_Scan_State;
1241 Source_Index : Source_File_Index;
1243 Extending : Boolean := False;
1245 Extended_Project : Project_Node_Id := Empty_Node;
1247 A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
1248 Tree_Private_Part.Projects_Htable.Get_First
1249 (In_Tree.Projects_HT);
1251 Name_From_Path : constant Name_Id :=
1252 Project_Name_From (Path_Name, Is_Config_File => Is_Config_File);
1253 Name_Of_Project : Name_Id := No_Name;
1254 Display_Name_Of_Project : Name_Id := No_Name;
1256 Duplicated : Boolean := False;
1258 First_With : With_Id;
1259 Imported_Projects : Project_Node_Id := Empty_Node;
1261 use Tree_Private_Part;
1263 Project_Comment_State : Tree.Comment_State;
1265 Qualifier_Location : Source_Ptr;
1267 begin
1268 Extends_All := False;
1270 declare
1271 Normed_Path : constant String := Normalize_Pathname
1272 (Path_Name,
1273 Directory => Current_Dir,
1274 Resolve_Links => False,
1275 Case_Sensitive => True);
1276 Canonical_Path : constant String := Normalize_Pathname
1277 (Normed_Path,
1278 Directory => Current_Dir,
1279 Resolve_Links => Opt.Follow_Links_For_Files,
1280 Case_Sensitive => False);
1281 begin
1282 Name_Len := Normed_Path'Length;
1283 Name_Buffer (1 .. Name_Len) := Normed_Path;
1284 Normed_Path_Name := Name_Find;
1285 Name_Len := Canonical_Path'Length;
1286 Name_Buffer (1 .. Name_Len) := Canonical_Path;
1287 Canonical_Path_Name := Name_Find;
1288 end;
1290 if Has_Circular_Dependencies
1291 (Env.Flags, Normed_Path_Name, Canonical_Path_Name)
1292 then
1293 Project := Empty_Node;
1294 return;
1295 end if;
1297 -- Put the new path name on the stack
1299 Project_Stack.Append
1300 ((Path_Name => Normed_Path_Name,
1301 Canonical_Path_Name => Canonical_Path_Name,
1302 Id => Empty_Node,
1303 Limited_With => In_Limited));
1305 -- Check if the project file has already been parsed
1307 while
1308 A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node
1309 loop
1310 if A_Project_Name_And_Node.Canonical_Path = Canonical_Path_Name then
1311 if Extended then
1313 if A_Project_Name_And_Node.Extended then
1314 if A_Project_Name_And_Node.Proj_Qualifier /= Dry then
1315 Error_Msg
1316 (Env.Flags,
1317 "cannot extend the same project file several times",
1318 Token_Ptr);
1319 end if;
1320 else
1321 Error_Msg
1322 (Env.Flags,
1323 "cannot extend an already imported project file",
1324 Token_Ptr);
1325 end if;
1327 elsif A_Project_Name_And_Node.Extended then
1328 Extends_All :=
1329 Is_Extending_All (A_Project_Name_And_Node.Node, In_Tree);
1331 -- If the imported project is an extended project A, and we are
1332 -- in an extended project, replace A with the ultimate project
1333 -- extending A.
1335 if From_Extended /= None then
1336 declare
1337 Decl : Project_Node_Id :=
1338 Project_Declaration_Of
1339 (A_Project_Name_And_Node.Node, In_Tree);
1341 Prj : Project_Node_Id :=
1342 A_Project_Name_And_Node.Node;
1344 begin
1345 -- Loop through extending projects to find the ultimate
1346 -- extending project, that is the one that is not
1347 -- extended. For an abstract project, as it can be
1348 -- extended several times, there is no extending project
1349 -- registered, so the loop does not execute and the
1350 -- resulting project is the abstract project.
1352 while
1353 Extending_Project_Of (Decl, In_Tree) /= Empty_Node
1354 loop
1355 Prj := Extending_Project_Of (Decl, In_Tree);
1356 Decl := Project_Declaration_Of (Prj, In_Tree);
1357 end loop;
1359 A_Project_Name_And_Node.Node := Prj;
1360 end;
1361 else
1362 Error_Msg
1363 (Env.Flags,
1364 "cannot import an already extended project file",
1365 Token_Ptr);
1366 end if;
1367 end if;
1369 Project := A_Project_Name_And_Node.Node;
1370 Project_Stack.Decrement_Last;
1371 return;
1372 end if;
1374 A_Project_Name_And_Node :=
1375 Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT);
1376 end loop;
1378 -- We never encountered this project file. Save the scan state, load the
1379 -- project file and start to scan it.
1381 Save_Project_Scan_State (Project_Scan_State);
1382 Source_Index := Load_Project_File (Path_Name);
1383 Tree.Save (Project_Comment_State);
1385 -- If we cannot find it, we stop
1387 if Source_Index = No_Source_File then
1388 Project := Empty_Node;
1389 Project_Stack.Decrement_Last;
1390 return;
1391 end if;
1393 Prj.Err.Scanner.Initialize_Scanner (Source_Index);
1394 Tree.Reset_State;
1395 Scan (In_Tree);
1397 if not Is_Config_File and then Name_From_Path = No_Name then
1399 -- The project file name is not correct (no or bad extension, or not
1400 -- following Ada identifier's syntax).
1402 Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name);
1403 Error_Msg (Env.Flags,
1404 "?{ is not a valid path name for a project file",
1405 Token_Ptr);
1406 end if;
1408 if Current_Verbosity >= Medium then
1410 end if;
1412 Project_Directory :=
1413 Path_Name_Type (Get_Directory (File_Name_Type (Normed_Path_Name)));
1415 -- Is there any imported project?
1417 Pre_Parse_Context_Clause
1418 (In_Tree => In_Tree,
1419 Is_Config_File => Is_Config_File,
1420 Context_Clause => First_With,
1421 Flags => Env.Flags);
1423 Project := Default_Project_Node
1424 (Of_Kind => N_Project, In_Tree => In_Tree);
1425 Project_Stack.Table (Project_Stack.Last).Id := Project;
1426 Set_Directory_Of (Project, In_Tree, Project_Directory);
1427 Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name);
1429 Read_Project_Qualifier
1430 (Env.Flags, In_Tree, Is_Config_File, Qualifier_Location, Project);
1432 Set_Location_Of (Project, In_Tree, Token_Ptr);
1436 -- Mark location of PROJECT token if present
1438 if Token = Tok_Project then
1439 Scan (In_Tree); -- past PROJECT
1440 Set_Location_Of (Project, In_Tree, Token_Ptr);
1441 end if;
1443 -- Clear the Buffer
1445 Buffer_Last := 0;
1446 loop
1449 -- If the token is not an identifier, clear the buffer before
1450 -- exiting to indicate that the name of the project is ill-formed.
1452 if Token /= Tok_Identifier then
1453 Buffer_Last := 0;
1454 exit;
1455 end if;
1457 -- Add the identifier name to the buffer
1459 Get_Name_String (Token_Name);
1460 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1462 -- Scan past the identifier
1464 Scan (In_Tree);
1466 -- If we have a dot, add a dot to the Buffer and look for the next
1467 -- identifier.
1469 exit when Token /= Tok_Dot;
1472 -- Scan past the dot
1474 Scan (In_Tree);
1475 end loop;
1477 -- See if this is an extending project
1479 if Token = Tok_Extends then
1481 if Is_Config_File then
1482 Error_Msg
1483 (Env.Flags,
1485 end if;
1487 -- Make sure that gnatmake will use mapping files
1489 Opt.Create_Mapping_File := True;
1491 -- We are extending another project
1493 Extending := True;
1495 Scan (In_Tree); -- past EXTENDS
1497 if Token = Tok_All then
1498 Extends_All := True;
1499 Set_Is_Extending_All (Project, In_Tree);
1500 Scan (In_Tree); -- scan past ALL
1501 end if;
1502 end if;
1504 -- If the name is well formed, Buffer_Last is > 0
1506 if Buffer_Last > 0 then
1508 -- The Buffer contains the name of the project
1510 Name_Len := Buffer_Last;
1511 Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
1512 Name_Of_Project := Name_Find;
1513 Set_Name_Of (Project, In_Tree, Name_Of_Project);
1515 -- To get expected name of the project file, replace dots by dashes
1517 for Index in 1 .. Name_Len loop
1518 if Name_Buffer (Index) = '.' then
1519 Name_Buffer (Index) := '-';
1520 end if;
1521 end loop;
1523 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1525 declare
1526 Expected_Name : constant Name_Id := Name_Find;
1527 Extension : String_Access;
1529 begin
1530 -- Output a warning if the actual name is not the expected name
1532 if not Is_Config_File
1533 and then (Name_From_Path /= No_Name)
1534 and then Expected_Name /= Name_From_Path
1535 then
1536 Error_Msg_Name_1 := Expected_Name;
1538 if Is_Config_File then
1539 Extension := new String'(Config_Project_File_Extension);
1541 else
1542 Extension := new String'(Project_File_Extension);
1543 end if;
1545 Error_Msg
1546 (Env.Flags,
1549 Token_Ptr);
1550 end if;
1551 end;
1553 -- Read the original casing of the project name
1555 declare
1556 Loc : Source_Ptr;
1558 begin
1559 Loc := Location_Of (Project, In_Tree);
1560 for J in 1 .. Name_Len loop
1561 Name_Buffer (J) := Sinput.Source (Loc);
1562 Loc := Loc + 1;
1563 end loop;
1565 Display_Name_Of_Project := Name_Find;
1566 end;
1568 declare
1569 From_Ext : Extension_Origin := None;
1571 begin
1572 -- Extending_All is always propagated
1574 if From_Extended = Extending_All or else Extends_All then
1575 From_Ext := Extending_All;
1577 -- Otherwise, From_Extended is set to Extending_Single if the
1578 -- current project is an extending project.
1580 elsif Extended then
1581 From_Ext := Extending_Simple;
1582 end if;
1584 Post_Parse_Context_Clause
1585 (In_Tree => In_Tree,
1586 Context_Clause => First_With,
1587 In_Limited => In_Limited,
1588 Limited_Withs => False,
1589 Imported_Projects => Imported_Projects,
1590 Project_Directory => Project_Directory,
1591 From_Extended => From_Ext,
1592 Packages_To_Check => Packages_To_Check,
1593 Depth => Depth + 1,
1594 Current_Dir => Current_Dir,
1595 Is_Config_File => Is_Config_File,
1596 Env => Env);
1597 Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects);
1598 end;
1600 if not Is_Config_File then
1601 declare
1602 Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
1603 Tree_Private_Part.Projects_Htable.Get_First
1604 (In_Tree.Projects_HT);
1605 Project_Name : Name_Id := Name_And_Node.Name;
1607 begin
1608 -- Check if we already have a project with this name
1610 while Project_Name /= No_Name
1611 and then Project_Name /= Name_Of_Project
1612 loop
1613 Name_And_Node :=
1614 Tree_Private_Part.Projects_Htable.Get_Next
1615 (In_Tree.Projects_HT);
1616 Project_Name := Name_And_Node.Name;
1617 end loop;
1619 -- Report an error if we already have a project with this name
1621 if Project_Name /= No_Name then
1622 Duplicated := True;
1623 Error_Msg_Name_1 := Project_Name;
1624 Error_Msg
1626 Location_Of (Project, In_Tree));
1627 Error_Msg_Name_1 :=
1628 Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree));
1629 Error_Msg
1630 (Env.Flags,
1632 end if;
1633 end;
1634 end if;
1636 end if;
1638 if Extending then
1641 if Token = Tok_String_Literal then
1642 Set_Extended_Project_Path_Of
1643 (Project,
1644 In_Tree,
1645 Path_Name_Type (Token_Name));
1647 declare
1648 Original_Path_Name : constant String :=
1649 Get_Name_String (Token_Name);
1651 Extended_Project_Path_Name_Id : Path_Name_Type;
1653 begin
1654 Find_Project
1655 (Env.Project_Path,
1656 Project_File_Name => Original_Path_Name,
1657 Directory => Get_Name_String (Project_Directory),
1658 Path => Extended_Project_Path_Name_Id);
1660 if Extended_Project_Path_Name_Id = No_Path then
1662 -- We could not find the project file to extend
1664 Error_Msg_Name_1 := Token_Name;
1668 -- If not in the main project file, display the import path
1670 if Project_Stack.Last > 1 then
1671 Error_Msg_Name_1 :=
1672 Name_Id
1673 (Project_Stack.Table (Project_Stack.Last).Path_Name);
1676 for Index in reverse 1 .. Project_Stack.Last - 1 loop
1677 Error_Msg_Name_1 :=
1678 Name_Id
1679 (Project_Stack.Table (Index).Path_Name);
1681 end loop;
1682 end if;
1684 else
1685 declare
1686 From_Ext : Extension_Origin := None;
1688 begin
1689 if From_Extended = Extending_All or else Extends_All then
1690 From_Ext := Extending_All;
1691 end if;
1693 Parse_Single_Project
1694 (In_Tree => In_Tree,
1695 Project => Extended_Project,
1696 Extends_All => Extends_All,
1697 Path_Name_Id => Extended_Project_Path_Name_Id,
1698 Extended => True,
1699 From_Extended => From_Ext,
1700 In_Limited => In_Limited,
1701 Packages_To_Check => Packages_To_Check,
1702 Depth => Depth + 1,
1703 Current_Dir => Current_Dir,
1704 Is_Config_File => Is_Config_File,
1705 Env => Env);
1706 end;
1708 if Present (Extended_Project) then
1710 -- A project that extends an extending-all project is
1711 -- also an extending-all project.
1713 if Is_Extending_All (Extended_Project, In_Tree) then
1714 Set_Is_Extending_All (Project, In_Tree);
1715 end if;
1717 -- An abstract project can only extend an abstract
1718 -- project. Otherwise we may have an abstract project
1719 -- with sources if it inherits sources from the project
1720 -- it extends.
1722 if Project_Qualifier_Of (Project, In_Tree) = Dry and then
1723 Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry
1724 then
1725 Error_Msg
1728 Qualifier_Location);
1729 end if;
1730 end if;
1731 end if;
1732 end;
1734 Scan (In_Tree); -- past the extended project path
1735 end if;
1736 end if;
1738 Check_Extending_All_Imports (Env.Flags, In_Tree, Project);
1739 Check_Aggregate_Imports (Env.Flags, In_Tree, Project);
1741 -- Check that a project with a name including a dot either imports
1742 -- or extends the project whose name precedes the last dot.
1744 if Name_Of_Project /= No_Name then
1745 Get_Name_String (Name_Of_Project);
1747 else
1748 Name_Len := 0;
1749 end if;
1751 -- Look for the last dot
1753 while Name_Len > 0 and then Name_Buffer (Name_Len) /= '.' loop
1754 Name_Len := Name_Len - 1;
1755 end loop;
1757 -- If a dot was found, check if parent project is imported or extended
1759 if Name_Len > 0 then
1760 Name_Len := Name_Len - 1;
1762 declare
1763 Parent_Name : constant Name_Id := Name_Find;
1764 Parent_Found : Boolean := False;
1765 Parent_Node : Project_Node_Id := Empty_Node;
1766 With_Clause : Project_Node_Id :=
1767 First_With_Clause_Of (Project, In_Tree);
1768 Imp_Proj_Name : Name_Id;
1770 begin
1771 -- If there is an extended project, check its name
1773 if Present (Extended_Project) then
1774 Parent_Node := Extended_Project;
1775 Parent_Found :=
1776 Name_Of (Extended_Project, In_Tree) = Parent_Name;
1777 end if;
1779 -- If the parent project is not the extended project,
1780 -- check each imported project until we find the parent project.
1782 Imported_Loop :
1783 while not Parent_Found and then Present (With_Clause) loop
1784 Parent_Node := Project_Node_Of (With_Clause, In_Tree);
1785 Extension_Loop : while Present (Parent_Node) loop
1786 Imp_Proj_Name := Name_Of (Parent_Node, In_Tree);
1787 Parent_Found := Imp_Proj_Name = Parent_Name;
1788 exit Imported_Loop when Parent_Found;
1789 Parent_Node :=
1790 Extended_Project_Of
1791 (Project_Declaration_Of (Parent_Node, In_Tree),
1792 In_Tree);
1793 end loop Extension_Loop;
1795 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
1796 end loop Imported_Loop;
1798 if Parent_Found then
1799 Set_Parent_Project_Of (Project, In_Tree, To => Parent_Node);
1801 else
1802 -- If the parent project was not found, report an error
1804 Error_Msg_Name_1 := Name_Of_Project;
1805 Error_Msg_Name_2 := Parent_Name;
1806 Error_Msg (Env.Flags,
1808 Location_Of (Project, In_Tree));
1809 end if;
1810 end;
1811 end if;
1814 Set_End_Of_Line (Project);
1815 Set_Previous_Line_Node (Project);
1816 Set_Next_End_Node (Project);
1818 declare
1819 Project_Declaration : Project_Node_Id := Empty_Node;
1821 begin
1824 Prj.Dect.Parse
1825 (In_Tree => In_Tree,
1826 Declarations => Project_Declaration,
1827 Current_Project => Project,
1828 Extends => Extended_Project,
1829 Packages_To_Check => Packages_To_Check,
1830 Is_Config_File => Is_Config_File,
1831 Flags => Env.Flags);
1832 Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration);
1834 if Present (Extended_Project)
1835 and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry
1836 then
1837 Set_Extending_Project_Of
1838 (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree,
1839 To => Project);
1840 end if;
1841 end;
1844 Remove_Next_End_Node;
1848 if Token = Tok_End then
1849 Scan (In_Tree);
1850 end if;
1852 -- Clear the Buffer
1854 Buffer_Last := 0;
1857 -- several simple names.
1859 loop
1862 -- If we don't have an identifier, clear the buffer before exiting to
1863 -- avoid checking the name.
1865 if Token /= Tok_Identifier then
1866 Buffer_Last := 0;
1867 exit;
1868 end if;
1870 -- Add the identifier to the Buffer
1871 Get_Name_String (Token_Name);
1872 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1874 -- Scan past the identifier
1876 Scan (In_Tree);
1877 exit when Token /= Tok_Dot;
1879 Scan (In_Tree);
1880 end loop;
1882 -- If we have a valid name, check if it is the name of the project
1884 if Name_Of_Project /= No_Name and then Buffer_Last > 0 then
1885 if To_Lower (Buffer (1 .. Buffer_Last)) /=
1886 Get_Name_String (Name_Of (Project, In_Tree))
1887 then
1888 -- Invalid name: report an error
1892 Token_Ptr);
1893 end if;
1894 end if;
1898 -- Check that there is no more text following the end of the project
1899 -- source.
1901 if Token = Tok_Semicolon then
1902 Set_Previous_End_Node (Project);
1903 Scan (In_Tree);
1905 if Token /= Tok_EOF then
1906 Error_Msg
1907 (Env.Flags,
1909 end if;
1910 end if;
1912 if not Duplicated and then Name_Of_Project /= No_Name then
1914 -- Add the name of the project to the hash table, so that we can
1915 -- check that no other subsequent project will have the same name.
1917 Tree_Private_Part.Projects_Htable.Set
1918 (T => In_Tree.Projects_HT,
1919 K => Name_Of_Project,
1920 E => (Name => Name_Of_Project,
1921 Display_Name => Display_Name_Of_Project,
1922 Node => Project,
1923 Canonical_Path => Canonical_Path_Name,
1924 Extended => Extended,
1925 Proj_Qualifier => Project_Qualifier_Of (Project, In_Tree)));
1926 end if;
1928 declare
1929 From_Ext : Extension_Origin := None;
1931 begin
1932 -- Extending_All is always propagated
1934 if From_Extended = Extending_All or else Extends_All then
1935 From_Ext := Extending_All;
1937 -- Otherwise, From_Extended is set to Extending_Single if the
1938 -- current project is an extending project.
1940 elsif Extended then
1941 From_Ext := Extending_Simple;
1942 end if;
1944 Post_Parse_Context_Clause
1945 (In_Tree => In_Tree,
1946 Context_Clause => First_With,
1947 In_Limited => In_Limited,
1948 Limited_Withs => True,
1949 Imported_Projects => Imported_Projects,
1950 Project_Directory => Project_Directory,
1951 From_Extended => From_Ext,
1952 Packages_To_Check => Packages_To_Check,
1953 Depth => Depth + 1,
1954 Current_Dir => Current_Dir,
1955 Is_Config_File => Is_Config_File,
1956 Env => Env);
1957 Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects);
1958 end;
1960 -- Restore the scan state, in case we are not the main project
1962 Restore_Project_Scan_State (Project_Scan_State);
1964 -- And remove the project from the project stack
1966 Project_Stack.Decrement_Last;
1968 -- Indicate if there are unkept comments
1970 Tree.Set_Project_File_Includes_Unkept_Comments
1971 (Node => Project,
1972 In_Tree => In_Tree,
1973 To => Tree.There_Are_Unkept_Comments);
1975 -- And restore the comment state that was saved
1977 Tree.Restore_And_Free (Project_Comment_State);
1979 Debug_Decrease_Indent;
1980 end Parse_Single_Project;
1982 -----------------------
1983 -- Project_Name_From --
1984 -----------------------
1986 function Project_Name_From
1987 (Path_Name : String;
1988 Is_Config_File : Boolean) return Name_Id
1989 is
1990 Canonical : String (1 .. Path_Name'Length) := Path_Name;
1991 First : Natural := Canonical'Last;
1992 Last : Natural := First;
1993 Index : Positive;
1995 begin
1996 if Current_Verbosity = High then
1998 end if;
2000 -- If the path name is empty, return No_Name to indicate failure
2002 if First = 0 then
2003 return No_Name;
2004 end if;
2006 Canonical_Case_File_Name (Canonical);
2008 -- Look for the last dot in the path name
2010 while First > 0
2011 and then
2012 Canonical (First) /= '.'
2013 loop
2014 First := First - 1;
2015 end loop;
2017 -- If we have a dot, check that it is followed by the correct extension
2019 if First > 0 and then Canonical (First) = '.' then
2020 if (not Is_Config_File
2021 and then Canonical (First .. Last) = Project_File_Extension
2022 and then First /= 1)
2023 or else
2024 (Is_Config_File
2025 and then
2026 Canonical (First .. Last) = Config_Project_File_Extension
2027 and then First /= 1)
2028 then
2029 -- Look for the last directory separator, if any
2031 First := First - 1;
2032 Last := First;
2033 while First > 0
2034 and then Canonical (First) /= '/'
2035 and then Canonical (First) /= Dir_Sep
2036 loop
2037 First := First - 1;
2038 end loop;
2040 else
2041 -- Not the correct extension, return No_Name to indicate failure
2043 return No_Name;
2044 end if;
2046 -- If no dot in the path name, return No_Name to indicate failure
2048 else
2049 return No_Name;
2050 end if;
2052 First := First + 1;
2054 -- If the extension is the file name, return No_Name to indicate failure
2056 if First > Last then
2057 return No_Name;
2058 end if;
2060 -- Put the name in lower case into Name_Buffer
2062 Name_Len := Last - First + 1;
2063 Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last));
2065 Index := 1;
2067 -- Check if it is a well formed project name. Return No_Name if it is
2068 -- ill formed.
2070 loop
2071 if not Is_Letter (Name_Buffer (Index)) then
2072 return No_Name;
2074 else
2075 loop
2076 Index := Index + 1;
2078 exit when Index >= Name_Len;
2080 if Name_Buffer (Index) = '_' then
2081 if Name_Buffer (Index + 1) = '_' then
2082 return No_Name;
2083 end if;
2084 end if;
2086 exit when Name_Buffer (Index) = '-';
2088 if Name_Buffer (Index) /= '_'
2089 and then not Is_Alphanumeric (Name_Buffer (Index))
2090 then
2091 return No_Name;
2092 end if;
2094 end loop;
2095 end if;
2097 if Index >= Name_Len then
2098 if Is_Alphanumeric (Name_Buffer (Name_Len)) then
2100 -- All checks have succeeded. Return name in Name_Buffer
2102 return Name_Find;
2104 else
2105 return No_Name;
2106 end if;
2108 elsif Name_Buffer (Index) = '-' then
2109 Index := Index + 1;
2110 end if;
2111 end loop;
2112 end Project_Name_From;
2114 end Prj.Part;