2009-07-13 Emmanuel Briot <briot@adacore.com>
+ * prj.adb, prj.ads, prj-env.adb, prj-conf.adb, prj-tree.adb,
+ mlib-prj.adb (Private_Part.Ada_Prj_Objects_File_Set,
+ Ada_Prj_Include_File_Set): Removed, since not needed
+ Code clean up.
+
+2009-07-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Analyze_Set_Membership): New procedure, subsidiary of
+ Analyze_Membership_Op.
+
+ * sem_res.adb (Resolve_Set_Membership): New procedure, subsidiary of
+ Resolve_Membership_Op.
+
+ * exp_ch4.adb (Expand_Set_Membership): New procedure, subsidiary of
+ Expand_N_In.
+
+2009-07-13 Robert Dewar <dewar@adacore.com>
+
+ * clean.adb: Minor reformattting
+
+2009-07-13 Emmanuel Briot <briot@adacore.com>
+
* gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj-ext.adb,
gnat_ugn.texi, prj.adb, prj.ads, clean.adb, prj-nmsc.adb, prj-util.adb,
prj-conf.adb, gnatname.adb, prj-env.adb, prj-env.ads, prj-tree.adb,
Proj := Project_Tree.Projects;
while Proj /= null loop
- -- for gnatmake, when the project specifies more than
- -- Ada as a language (even if course we could not find
- -- any source file for the other languages), we will
- -- take all object files found in the object
+ -- For gnatmake, when the project specifies more than
+ -- just Ada as a language (even if course we could not
+ -- find any source file for the other languages), we
+ -- will take all the object files found in the object
-- directories. Since we know the project supports at
-- least Ada, we just have to test whether it has at
- -- least two languages, and not care about the sources
+ -- least two languages, and we do not care about the
+ -- sources.
if Proj.Project.Languages /= null
and then Proj.Project.Languages.Next /= null
Rop : constant Node_Id := Right_Opnd (N);
Static : constant Boolean := Is_OK_Static_Expression (N);
+ procedure Expand_Set_Membership;
+ -- For each disjunct we create a simple equality or membership test.
+ -- The whole membership is rewritten as a short-circuit disjunction.
+
+ ---------------------------
+ -- Expand_Set_Membership --
+ ---------------------------
+
+ procedure Expand_Set_Membership is
+ Alt : Node_Id;
+ Res : Node_Id;
+
+ function Make_Cond (Alt : Node_Id) return Node_Id;
+ -- If the alternative is a subtype mark, create a simple membership
+ -- test. Otherwise create an equality test for it.
+
+ ---------------
+ -- Make_Cond --
+ ---------------
+
+ function Make_Cond (Alt : Node_Id) return Node_Id is
+ Cond : Node_Id;
+ L : constant Node_Id := New_Copy (Lop);
+ R : constant Node_Id := Relocate_Node (Alt);
+
+ begin
+ if Is_Entity_Name (Alt)
+ and then Is_Type (Entity (Alt))
+ then
+ Cond :=
+ Make_In (Sloc (Alt),
+ Left_Opnd => L,
+ Right_Opnd => R);
+ else
+ Cond := Make_Op_Eq (Sloc (Alt),
+ Left_Opnd => L,
+ Right_Opnd => R);
+ end if;
+
+ return Cond;
+ end Make_Cond;
+
+ -- Start of proessing for Expand_N_In
+
+ begin
+ Alt := Last (Alternatives (N));
+ Res := Make_Cond (Alt);
+
+ Prev (Alt);
+ while Present (Alt) loop
+ Res :=
+ Make_Or_Else (Sloc (Alt),
+ Left_Opnd => Make_Cond (Alt),
+ Right_Opnd => Res);
+ Prev (Alt);
+ end loop;
+
+ Rewrite (N, Res);
+ Analyze_And_Resolve (N, Standard_Boolean);
+ end Expand_Set_Membership;
+
procedure Substitute_Valid_Check;
-- Replaces node N by Lop'Valid. This is done when we have an explicit
-- test for the left operand being in range of its subtype.
-- Start of processing for Expand_N_In
begin
+
+ if Present (Alternatives (N)) then
+ Remove_Side_Effects (Lop);
+ Expand_Set_Membership;
+ return;
+ end if;
+
-- Check case of explicit test for an expression in range of its
-- subtype. This is suspicious usage and we replace it with a 'Valid
-- test and give a warning.
Left_Opnd => Left_Opnd (N),
Right_Opnd => Right_Opnd (N))));
+ -- If this is a set membership, preserve list of alternatives
+
+ Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
+
-- We want this to appear as coming from source if original does (see
-- transformations in Expand_N_In).
-- a VM, since representations are largely symbolic there.
if Back_End_Mode = Declarations_Only
- and then (not (Back_Annotate_Rep_Info or else Inspector_Mode)
+ and then (not (Back_Annotate_Rep_Info or Inspector_Mode)
or else Main_Kind = N_Subunit
or else Targparm.Frontend_Layout_On_Target
or else Targparm.VM_Target /= No_VM)
In_Main_Object_Directory := True;
- -- for gnatmake, when the project specifies more than Ada as a
+ -- For gnatmake, when the project specifies more than just Ada as a
-- language (even if course we could not find any source file for
-- the other languages), we will take all object files found in the
-- object directories. Since we know the project supports at least
-- Ada, we just have to test whether it has at least two languages,
- -- and not care about the sources
+ -- and not care about the sources.
Foreign_Sources := For_Project.Languages.Next /= null;
Current_Proj := For_Project;
Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
Name := Name_Find;
+ -- An invalid project name to avoid conflicts with user-created ones
+ Name_Len := 5;
+ Name_Buffer (1 .. Name_Len) := "_auto";
+
Config_File :=
Create_Project
(In_Tree => Project_Tree,
- Name => Name_Default,
+ Name => Name_Find,
Full_Path => Path_Name_Type (Name),
Is_Config_File => True);
Set_Path_File_Var
(Project_Include_Path_File,
Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File));
- In_Tree.Private_Part.Ada_Prj_Include_File_Set := True;
end if;
if Including_Libraries then
(Project_Objects_Path_File,
Get_Name_String
(In_Tree.Private_Part.Current_Object_Path_File));
- In_Tree.Private_Part.Ada_Prj_Objects_File_Set := True;
end if;
else
(Project_Objects_Path_File,
Get_Name_String
(In_Tree.Private_Part.Current_Object_Path_File));
- In_Tree.Private_Part.Ada_Prj_Objects_File_Set := True;
end if;
end if;
end Set_Ada_Paths;
Qualifier := Configuration;
end if;
- Prj.Tree.Tree_Private_Part.Projects_Htable.Set
- (In_Tree.Projects_HT,
- Name,
- Prj.Tree.Tree_Private_Part.Project_Name_And_Node'
- (Name => Name,
- Canonical_Path => No_Path,
- Node => Project,
- Extended => False,
- Proj_Qualifier => Qualifier));
+ if not Is_Config_File then
+ Prj.Tree.Tree_Private_Part.Projects_Htable.Set
+ (In_Tree.Projects_HT,
+ Name,
+ Prj.Tree.Tree_Private_Part.Project_Name_And_Node'
+ (Name => Name,
+ Canonical_Path => No_Path,
+ Node => Project,
+ Extended => False,
+ Proj_Qualifier => Qualifier));
+ end if;
return Project;
end Create_Project;
-- Find out the case sensitivity of the attribute
- if Kind_Of (Prj_Or_Pkg, Tree) = N_Package_Declaration then
+ if Prj_Or_Pkg /= Empty_Node
+ and then Kind_Of (Prj_Or_Pkg, Tree) = N_Package_Declaration
+ then
Pkg := Prj.Attr.Package_Node_Id_Of (Name_Of (Prj_Or_Pkg, Tree));
Start_At := First_Attribute_Of (Pkg);
else
-- the empty string. On VMS, this has the effect of deassigning
-- the logical names.
- if Tree.Private_Part.Ada_Prj_Include_File_Set then
+ if Tree.Private_Part.Current_Source_Path_File /= No_Path then
Setenv (Project_Include_Path_File, "");
- Tree.Private_Part.Ada_Prj_Include_File_Set := False;
end if;
- if Tree.Private_Part.Ada_Prj_Objects_File_Set then
+ if Tree.Private_Part.Current_Object_Path_File /= No_Path then
Setenv (Project_Objects_Path_File, "");
- Tree.Private_Part.Ada_Prj_Objects_File_Set := False;
end if;
end Delete_All_Temp_Files;
Tree.Private_Part.Current_Source_Path_File := No_Path;
Tree.Private_Part.Current_Object_Path_File := No_Path;
- Tree.Private_Part.Ada_Prj_Include_File_Set := False;
- Tree.Private_Part.Ada_Prj_Objects_File_Set := False;
end Reset;
-------------------
Current_Source_Path_File : Path_Name_Type := No_Path;
-- Current value of project source path file env var. Used to avoid
- -- setting the env var to the same value.
+ -- setting the env var to the same value. When different from No_Path,
+ -- this indicates that logical names (VMS) or environment variables were
+ -- created and should be deassigned to avoid polluting the environment
+ -- on VMS.
-- gnatmake only
Current_Object_Path_File : Path_Name_Type := No_Path;
-- setting the env var to the same value.
-- gnatmake only
- Ada_Prj_Include_File_Set : Boolean := False;
- Ada_Prj_Objects_File_Set : Boolean := False;
- -- These flags are set to True when the corresponding environment
- -- variables are set and are used to give these environment variables an
- -- empty string value at the end of the program. This has no practical
- -- effect on most platforms, except on VMS where the logical names are
- -- deassigned, thus avoiding the pollution of the environment of the
- -- caller.
- -- gnatmake only
-
end record;
-- Type to represent the part of a project tree which is private to the
-- Project Manager.
end Try_One_Interp;
+ procedure Analyze_Set_Membership;
+ -- If a set of alternatives is present, analyze each and find the
+ -- common type to which they must all resolve.
+
+ ----------------------------
+ -- Analyze_Set_Membership --
+ ----------------------------
+
+ procedure Analyze_Set_Membership is
+ Alt : Node_Id;
+ Index : Interp_Index;
+ It : Interp;
+
+ Candidate_Interps : Node_Id;
+ Common_Type : Entity_Id := Empty;
+
+ begin
+ Analyze (L);
+ Candidate_Interps := L;
+
+ if not Is_Overloaded (L) then
+ Common_Type := Etype (L);
+
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+ Analyze (Alt);
+
+ if not Has_Compatible_Type (Alt, Common_Type) then
+ Wrong_Type (Alt, Common_Type);
+ end if;
+
+ Next (Alt);
+ end loop;
+
+ else
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+ Analyze (Alt);
+ if not Is_Overloaded (Alt) then
+ Common_Type := Etype (Alt);
+
+ else
+ Get_First_Interp (Alt, Index, It);
+ while Present (It.Typ) loop
+ if
+ not Has_Compatible_Type (Candidate_Interps, It.Typ)
+ then
+ Remove_Interp (Index);
+ end if;
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ Get_First_Interp (Alt, Index, It);
+ if No (It.Typ) then
+ Error_Msg_N ("alternative has no legal type", Alt);
+ return;
+ end if;
+
+ -- If alternative is not overloaded, we have a
+ -- unique type for all of them.
+
+ Set_Etype (Alt, It.Typ);
+ Get_Next_Interp (Index, It);
+
+ if No (It.Typ) then
+ Set_Is_Overloaded (Alt, False);
+ Common_Type := Etype (Alt);
+ end if;
+
+ Candidate_Interps := Alt;
+ end if;
+
+ Next (Alt);
+ end loop;
+ end if;
+
+ Set_Etype (N, Standard_Boolean);
+
+ if Present (Common_Type) then
+ Set_Etype (L, Common_Type);
+ Set_Is_Overloaded (L, False);
+
+ else
+ Error_Msg_N ("cannot resolve membership operation", N);
+ end if;
+ end Analyze_Set_Membership;
+
-- Start of processing for Analyze_Membership_Op
begin
Analyze_Expression (L);
+ if No (R)
+ and then Extensions_Allowed
+ then
+ Analyze_Set_Membership;
+ return;
+ end if;
+
if Nkind (R) = N_Range
or else (Nkind (R) = N_Attribute_Reference
and then Attribute_Name (R) = Name_Range)
Set_Etype (N, Standard_Boolean);
if Comes_From_Source (N)
+ and then Present (Right_Opnd (N))
and then Is_CPP_Class (Etype (Etype (Right_Opnd (N))))
then
Error_Msg_N ("membership test not applicable to cpp-class types", N);
procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
pragma Warnings (Off, Typ);
- L : constant Node_Id := Left_Opnd (N);
+ L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
T : Entity_Id;
+ procedure Resolve_Set_Membership;
+ -- Analysis has determined a unique type for the left operand.
+ -- Use it to resolve the disjuncts.
+
+ ----------------------------
+ -- Resolve_Set_Membership --
+ ----------------------------
+
+ procedure Resolve_Set_Membership is
+ Alt : Node_Id;
+
+ begin
+ Resolve (L, Etype (L));
+
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+
+ -- Alternative is an expression, a range
+ -- or a subtype mark.
+
+ if not Is_Entity_Name (Alt)
+ or else not Is_Type (Entity (Alt))
+ then
+ Resolve (Alt, Etype (L));
+ end if;
+
+ Next (Alt);
+ end loop;
+ end Resolve_Set_Membership;
+
+ -- start of processing for Resolve_Membership_Op
+
begin
if L = Error or else R = Error then
return;
end if;
- if not Is_Overloaded (R)
+ if Present (Alternatives (N)) then
+ Resolve_Set_Membership;
+ return;
+
+ elsif not Is_Overloaded (R)
and then
(Etype (R) = Universal_Integer or else
Etype (R) = Universal_Real)
projects / platform / upstream / linaro-gcc.git / commitdiff