From 5d6b98f60dbf269c822dce4af2b15d341a8f22f4 Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 13 Jul 2009 10:52:34 +0000 Subject: [PATCH] 2009-07-13 Emmanuel Briot * 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 * 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 * clean.adb: Minor reformattting git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149569 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 22 ++++++++++++ gcc/ada/clean.adb | 11 +++--- gcc/ada/exp_ch4.adb | 72 +++++++++++++++++++++++++++++++++++++++ gcc/ada/gnat1drv.adb | 2 +- gcc/ada/mlib-prj.adb | 4 +-- gcc/ada/prj-conf.adb | 6 +++- gcc/ada/prj-env.adb | 3 -- gcc/ada/prj-tree.adb | 24 +++++++------ gcc/ada/prj.adb | 8 ++--- gcc/ada/prj.ads | 15 +++------ gcc/ada/sem_ch4.adb | 95 ++++++++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_res.adb | 40 ++++++++++++++++++++-- 12 files changed, 261 insertions(+), 41 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2e12962..1475a55 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,27 @@ 2009-07-13 Emmanuel Briot + * 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 + + * 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 + + * clean.adb: Minor reformattting + +2009-07-13 Emmanuel Briot + * 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, diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index e4d4387..790b842 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -1045,13 +1045,14 @@ package body Clean is 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 diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 87ba037..e6e539e 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4121,6 +4121,67 @@ package body Exp_Ch4 is 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. @@ -4146,6 +4207,13 @@ package body Exp_Ch4 is -- 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. @@ -4733,6 +4801,10 @@ package body Exp_Ch4 is 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). diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index f737e96..7c39819 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -752,7 +752,7 @@ begin -- 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) diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 51de49b..d01a329 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -1328,12 +1328,12 @@ package body MLib.Prj is 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; diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 59b6c14..10fbdd7 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -1185,10 +1185,14 @@ package body Prj.Conf is 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); diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 7541e52..db688ce 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -1641,7 +1641,6 @@ package body Prj.Env is 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 @@ -1654,7 +1653,6 @@ package body Prj.Env is (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 @@ -1667,7 +1665,6 @@ package body Prj.Env is (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; diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index 42b281f..f054976 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -2848,15 +2848,17 @@ package body Prj.Tree is 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; @@ -3044,7 +3046,9 @@ package body Prj.Tree is -- 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 diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index c8f30ec..f9726be 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -223,14 +223,12 @@ package body Prj is -- 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; @@ -879,8 +877,6 @@ package body Prj is 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; ------------------- diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index b359515..4154e9b 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -1477,7 +1477,10 @@ private 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; @@ -1485,16 +1488,6 @@ private -- 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. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 98cbde3..ccfcf1f 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2050,11 +2050,105 @@ package body Sem_Ch4 is 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) @@ -2090,6 +2184,7 @@ package body Sem_Ch4 is 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); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f691847..42a7e12 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6734,16 +6734,52 @@ package body Sem_Res is 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) -- 2.7.4