From: Arnaud Charlet Date: Tue, 28 Jul 2009 09:25:52 +0000 (+0200) Subject: [multiple changes] X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=f7e71125e21dc6589eb2d76ab97cef6bbdcc9f5b;p=platform%2Fupstream%2Fgcc.git [multiple changes] 2009-07-28 Emmanuel Briot * prj.adb, prj.ads (Compute_All_Imported_Projects): Make sure the importing project does not end up in the list, in the case of extending projects. * make.adb, makeutl.adb, makeutl.ads (File_Not_A_Source_Of): Moved to makeutl.ads, for better sharing with gprbuild. 2009-07-28 Arnaud Charlet * gnat_ugn.texi: Fix typo. 2009-07-28 Ed Schonberg * sem_ch3.adb (Build_Derived_Concurrent_Type): Handle properly a derivation that renames some discriminants and constrain others. * exp_ch9.adb (Build_Protected_Subprogram_Call): If the type of the prefix is a derived untagged type, convert to the root type to conform to the signature of the protected operations. 2009-07-28 Robert Dewar * sinfo.ads: Update comments. * exp_attr.adb: Minor reformatting From-SVN: r150152 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d1077cb..69c8fee 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2009-07-28 Emmanuel Briot + + * prj.adb, prj.ads (Compute_All_Imported_Projects): Make sure the + importing project does not end up in the list, in the case of extending + projects. + * make.adb, makeutl.adb, makeutl.ads (File_Not_A_Source_Of): Moved to + makeutl.ads, for better sharing with gprbuild. + +2009-07-28 Arnaud Charlet + + * gnat_ugn.texi: Fix typo. + +2009-07-28 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Concurrent_Type): Handle properly a + derivation that renames some discriminants and constrain others. + * exp_ch9.adb (Build_Protected_Subprogram_Call): If the type of the + prefix is a derived untagged type, convert to the root type to conform + to the signature of the protected operations. + +2009-07-28 Robert Dewar + + * sinfo.ads: Update comments. + * exp_attr.adb: Minor reformatting + 2009-07-28 Ed Schonberg * sem_aggr.adb (Get_Value): A named association in a record aggregate diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 56fa4c4..d5cce9b 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -358,7 +358,7 @@ package body Exp_Attr is Sub_Ref := Make_Attribute_Reference (Loc, - Prefix => Sub, + Prefix => Sub, Attribute_Name => Name_Access); -- We set the type of the access reference to the already generated @@ -370,17 +370,13 @@ package body Exp_Attr is Agg := Make_Aggregate (Loc, - Expressions => - New_List ( - Obj_Ref, Sub_Ref)); + Expressions => New_List (Obj_Ref, Sub_Ref)); Rewrite (N, Agg); - Analyze_And_Resolve (N, E_T); - -- For subsequent analysis, the node must retain its type. - -- The backend will replace it with the equivalent type where - -- needed. + -- For subsequent analysis, the node must retain its type. The backend + -- will replace it with the equivalent type where needed. Set_Etype (N, Typ); end Expand_Access_To_Protected_Op; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index e75ceca..3a7fa25 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -3193,6 +3193,18 @@ package body Exp_Ch9 is Params := New_List; end if; + -- If the type is an untagged derived type, convert to the root type, + -- which is the one on which the operations are defined. + + if Nkind (Rec) = N_Unchecked_Type_Conversion + and then not Is_Tagged_Type (Etype (Rec)) + and then Is_Derived_Type (Etype (Rec)) + then + Set_Etype (Rec, Root_Type (Etype (Rec))); + Set_Subtype_Mark (Rec, + New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N))); + end if; + Prepend (Rec, Params); if Ekind (Sub) = E_Procedure then @@ -4358,8 +4370,8 @@ package body Exp_Ch9 is return N; else return - Unchecked_Convert_To (Corresponding_Record_Type (Typ), - New_Copy_Tree (N)); + Unchecked_Convert_To + (Corresponding_Record_Type (Typ), New_Copy_Tree (N)); end if; end Convert_Concurrent; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 25124fa..3e1a864 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -557,25 +557,6 @@ package body Make is procedure List_Bad_Compilations; -- Prints out the list of all files for which the compilation failed - procedure Verbose_Msg - (N1 : Name_Id; - S1 : String; - N2 : Name_Id := No_Name; - S2 : String := ""; - Prefix : String := " -> "; - Minimum_Verbosity : Verbosity_Level_Type := Opt.Low); - procedure Verbose_Msg - (N1 : File_Name_Type; - S1 : String; - N2 : File_Name_Type := No_File; - S2 : String := ""; - Prefix : String := " -> "; - Minimum_Verbosity : Verbosity_Level_Type := Opt.Low); - -- If the verbose flag (Verbose_Mode) is set and the verbosity level is - -- at least equal to Minimum_Verbosity, then print Prefix to standard - -- output followed by N1 and S1. If N2 /= No_Name then N2 is printed after - -- S1. S2 is printed last. Both N1 and N2 are printed in quotation marks. - Usage_Needed : Boolean := True; -- Flag used to make sure Makeusg is call at most once @@ -1434,10 +1415,6 @@ package body Make is O_File : out File_Name_Type; O_Stamp : out Time_Stamp_Type) is - function File_Not_A_Source_Of - (Uname : Name_Id; - Sfile : File_Name_Type) return Boolean; - function First_New_Spec (A : ALI_Id) return File_Name_Type; -- Looks in the with table entries of A and returns the spec file name -- of the first withed unit (subprogram) for which no spec existed when @@ -1452,34 +1429,6 @@ package body Make is -- services, but this causes the whole compiler to be dragged along -- for gnatbind and gnatmake. - -------------------------- - -- File_Not_A_Source_Of -- - -------------------------- - - function File_Not_A_Source_Of - (Uname : Name_Id; - Sfile : File_Name_Type) return Boolean - is - UID : Prj.Unit_Index; - - begin - UID := Units_Htable.Get (Project_Tree.Units_HT, Uname); - - if UID /= Prj.No_Unit_Index then - if (UID.File_Names (Impl) = null - or else UID.File_Names (Impl).File /= Sfile) - and then - (UID.File_Names (Spec) = null - or else UID.File_Names (Spec).File /= Sfile) - then - Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile)); - return True; - end if; - end if; - - return False; - end File_Not_A_Source_Of; - -------------------- -- First_New_Spec -- -------------------- @@ -8240,52 +8189,6 @@ package body Make is end if; end Usage; - ----------------- - -- Verbose_Msg -- - ----------------- - - procedure Verbose_Msg - (N1 : Name_Id; - S1 : String; - N2 : Name_Id := No_Name; - S2 : String := ""; - Prefix : String := " -> "; - Minimum_Verbosity : Verbosity_Level_Type := Opt.Low) - is - begin - if (not Verbose_Mode) or else (Minimum_Verbosity > Verbosity_Level) then - return; - end if; - - Write_Str (Prefix); - Write_Str (""""); - Write_Name (N1); - Write_Str (""" "); - Write_Str (S1); - - if N2 /= No_Name then - Write_Str (" """); - Write_Name (N2); - Write_Str (""" "); - end if; - - Write_Str (S2); - Write_Eol; - end Verbose_Msg; - - procedure Verbose_Msg - (N1 : File_Name_Type; - S1 : String; - N2 : File_Name_Type := No_File; - S2 : String := ""; - Prefix : String := " -> "; - Minimum_Verbosity : Verbosity_Level_Type := Opt.Low) - is - begin - Verbose_Msg - (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity); - end Verbose_Msg; - begin -- Make sure that in case of failure, the temp files will be deleted diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 46169d5..af5e7d6 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -26,6 +26,7 @@ with Debug; with Osint; use Osint; with Output; use Output; +with Opt; use Opt; with Prj.Ext; with Prj.Util; with Snames; use Snames; @@ -264,6 +265,47 @@ package body Makeutl is end; end Executable_Prefix_Path; + -------------------------- + -- File_Not_A_Source_Of -- + -------------------------- + + function File_Not_A_Source_Of + (Uname : Name_Id; + Sfile : File_Name_Type) return Boolean + is + Unit : constant Unit_Index := + Units_Htable.Get (Project_Tree.Units_HT, Uname); + + At_Least_One_File : Boolean := False; + + begin + if Unit /= No_Unit_Index then + for F in Unit.File_Names'Range loop + if Unit.File_Names (F) /= null then + At_Least_One_File := True; + if Unit.File_Names (F).File = Sfile then + return False; + end if; + end if; + end loop; + + if not At_Least_One_File then + + -- The unit was probably created initially for a separate unit + -- (which are initially created as IMPL when both suffixes are the + -- same). Later on, Override_Kind changed the type of the file, + -- and the unit is no longer valid in fact. + + return False; + end if; + + Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile)); + return True; + end if; + + return False; + end File_Not_A_Source_Of; + ---------- -- Hash -- ---------- @@ -749,4 +791,52 @@ package body Makeutl is return Result; end Unit_Index_Of; + ----------------- + -- Verbose_Msg -- + ----------------- + + procedure Verbose_Msg + (N1 : Name_Id; + S1 : String; + N2 : Name_Id := No_Name; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low) + is + begin + if not Opt.Verbose_Mode + or else Minimum_Verbosity > Opt.Verbosity_Level + then + return; + end if; + + Write_Str (Prefix); + Write_Str (""""); + Write_Name (N1); + Write_Str (""" "); + Write_Str (S1); + + if N2 /= No_Name then + Write_Str (" """); + Write_Name (N2); + Write_Str (""" "); + end if; + + Write_Str (S2); + Write_Eol; + end Verbose_Msg; + + procedure Verbose_Msg + (N1 : File_Name_Type; + S1 : String; + N2 : File_Name_Type := No_File; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low) + is + begin + Verbose_Msg + (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity); + end Verbose_Msg; + end Makeutl; diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index ae55ebb..e33369f 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Namet; use Namet; +with Opt; with Osint; with Prj; use Prj; with Types; use Types; @@ -69,6 +70,13 @@ package Makeutl is procedure Inform (N : File_Name_Type; Msg : String); -- Prints out the program name followed by a colon, N and S + function File_Not_A_Source_Of + (Uname : Name_Id; + Sfile : File_Name_Type) return Boolean; + -- Check that file name Sfile is one of the source of unit Uname. + -- Returns True if the unit is in one of the project file, but the file + -- name is not one of its source. Returns False otherwise. + function Is_External_Assignment (Argv : String) return Boolean; -- Verify that an external assignment switch is syntactically correct -- @@ -82,6 +90,25 @@ package Makeutl is -- been entered by a call to Prj.Ext.Add, so that in a project -- file, External ("name") will return "value". + procedure Verbose_Msg + (N1 : Name_Id; + S1 : String; + N2 : Name_Id := No_Name; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low); + procedure Verbose_Msg + (N1 : File_Name_Type; + S1 : String; + N2 : File_Name_Type := No_File; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low); + -- If the verbose flag (Verbose_Mode) is set and the verbosity level is + -- at least equal to Minimum_Verbosity, then print Prefix to standard + -- output followed by N1 and S1. If N2 /= No_Name then N2 is printed after + -- S1. S2 is printed last. Both N1 and N2 are printed in quotation marks. + function Linker_Options_Switches (Project : Project_Id; In_Tree : Project_Tree_Ref) return String_List; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index a4b9de1..0f4e050 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -1069,8 +1069,8 @@ package body Prj is begin -- A project is not importing itself - if Project /= Prj then - Prj2 := Ultimate_Extending_Project_Of (Prj); + Prj2 := Ultimate_Extending_Project_Of (Prj); + if Project /= Prj2 then -- Check that the project is not already in the list. We know the -- one passed to Recursive_Add have never been visited before, but diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index e3c0491..8f95c08 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -1061,7 +1061,8 @@ package Prj is -- The list of all directly imported projects, if any All_Imported_Projects : Project_List; - -- The list of all projects imported directly or indirectly, if any + -- The list of all projects imported directly or indirectly, if any. + -- This does not include the project itself. ----------------- -- Directories -- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ff8dd6e..5696a1c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4826,17 +4826,72 @@ package body Sem_Ch3 is Parent_Type : Entity_Id; Derived_Type : Entity_Id) is - D_Constraint : Node_Id; - Disc_Spec : Node_Id; - Old_Disc : Entity_Id; - New_Disc : Entity_Id; - - Constraint_Present : constant Boolean := - Nkind (Subtype_Indication (Type_Definition (N))) - = N_Subtype_Indication; + Loc : constant Source_Ptr := Sloc (N); + + Corr_Record : constant Entity_Id + := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + Corr_Decl : Node_Id; + Corr_Decl_Needed : Boolean; + -- If the derived type has fewer discriminants than its parent, + -- the corresponding record is also a derived type, in order to + -- account for the bound discriminants. We create a full type + -- declaration for it in this case. + + Constraint_Present : constant Boolean + := Nkind (Subtype_Indication (Type_Definition (N))) + = N_Subtype_Indication; + + D_Constraint : Node_Id; + New_Constraint : Elist_Id; + Old_Disc : Entity_Id; + New_Disc : Entity_Id; + New_N : Node_Id; begin Set_Stored_Constraint (Derived_Type, No_Elist); + Corr_Decl_Needed := False; + Old_Disc := Empty; + + if Present (Discriminant_Specifications (N)) + and then Constraint_Present + then + Old_Disc := First_Discriminant (Parent_Type); + New_Disc := First (Discriminant_Specifications (N)); + while Present (New_Disc) and then Present (Old_Disc) loop + Next_Discriminant (Old_Disc); + Next (New_Disc); + end loop; + end if; + + if Present (Old_Disc) then + + -- The new type has fewer discriminants, so we need to create a new + -- corresponding record, which is derived from the corresponding + -- record of the parent, and has a stored constraint that + -- captures the values of the discriminant constraints. + -- The type declaration for the derived corresponding record has + -- the same discriminant part and constraints as the current + -- declaration. Copy the unanalyzed tree to build declaration. + + Corr_Decl_Needed := True; + New_N := Copy_Separate_Tree (N); + + Corr_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Corr_Record, + Discriminant_Specifications => + Discriminant_Specifications (New_N), + Type_Definition => + Make_Derived_Type_Definition (Loc, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of + (Corresponding_Record_Type (Parent_Type), Loc), + Constraint => + Constraint + (Subtype_Indication (Type_Definition (New_N)))))); + end if; -- Copy Storage_Size and Relative_Deadline variables if task case @@ -4850,6 +4905,16 @@ package body Sem_Ch3 is if Present (Discriminant_Specifications (N)) then Push_Scope (Derived_Type); Check_Or_Process_Discriminants (N, Derived_Type); + + if Constraint_Present then + New_Constraint := + Expand_To_Stored_Constraint + (Parent_Type, + Build_Discriminant_Constraints + (Parent_Type, + Subtype_Indication (Type_Definition (N)), True)); + end if; + End_Scope; elsif Constraint_Present then @@ -4880,9 +4945,9 @@ package body Sem_Ch3 is end; end if; - -- All attributes are inherited from parent. In particular, - -- entries and the corresponding record type are the same. - -- Discriminants may be renamed, and must be treated separately. + -- By default, operations and private data are inherited from parent. + -- However, in the presence of bound discriminants, a new corresponding + -- record will be created, see below. Set_Has_Discriminants (Derived_Type, Has_Discriminants (Parent_Type)); @@ -4910,44 +4975,99 @@ package body Sem_Ch3 is (Constraints (Constraint (Subtype_Indication (Type_Definition (N))))); - Old_Disc := First_Discriminant (Parent_Type); - New_Disc := First_Discriminant (Derived_Type); - Disc_Spec := First (Discriminant_Specifications (N)); - while Present (Old_Disc) and then Present (Disc_Spec) loop - if Nkind (Discriminant_Type (Disc_Spec)) /= - N_Access_Definition - then - Analyze (Discriminant_Type (Disc_Spec)); + Old_Disc := First_Discriminant (Parent_Type); - if not Subtypes_Statically_Compatible ( - Etype (Discriminant_Type (Disc_Spec)), - Etype (Old_Disc)) - then - Error_Msg_N - ("not statically compatible with parent discriminant", - Discriminant_Type (Disc_Spec)); + while Present (D_Constraint) loop + if Nkind (D_Constraint) /= N_Discriminant_Association then + + -- Positional constraint. If it is a reference to a + -- new discriminant, it constrains the corresponding + -- old one. + + if Nkind (D_Constraint) = N_Identifier then + New_Disc := First_Discriminant (Derived_Type); + while Present (New_Disc) loop + exit when + Chars (New_Disc) = Chars (D_Constraint); + Next_Discriminant (New_Disc); + end loop; + + if Present (New_Disc) then + Set_Corresponding_Discriminant (New_Disc, Old_Disc); + end if; + end if; + + Next_Discriminant (Old_Disc); + + -- if this is a named constraint, search by name for the + -- old discriminants constrained by the new one. + + elsif Nkind (Expression (D_Constraint)) = N_Identifier then + + -- Find new discriminant with that name. + + New_Disc := First_Discriminant (Derived_Type); + while Present (New_Disc) loop + exit when + Chars (New_Disc) = Chars (Expression (D_Constraint)); + Next_Discriminant (New_Disc); + end loop; + + if Present (New_Disc) then + + -- Verify that the new discriminant renames + -- some discriminant of the parent type, and + -- associate the new discriminant with an old + -- one that it renames (may be more than one). + + declare + Selector : Node_Id; + + begin + Selector := First (Selector_Names (D_Constraint)); + + while Present (Selector) loop + Old_Disc := First_Discriminant (Parent_Type); + + while Present (Old_Disc) loop + exit when Chars (Old_Disc) = Chars (Selector); + Next_Discriminant (Old_Disc); + end loop; + + if Present (Old_Disc) then + Set_Corresponding_Discriminant + (New_Disc, Old_Disc); + + end if; + + Next (Selector); + end loop; + end; end if; end if; - if Nkind (D_Constraint) = N_Identifier - and then Chars (D_Constraint) /= - Chars (Defining_Identifier (Disc_Spec)) + Next (D_Constraint); + end loop; + + New_Disc := First_Discriminant (Derived_Type); + while Present (New_Disc) loop + if No (Corresponding_Discriminant (New_Disc)) then + Error_Msg_NE + ("new discriminant& must constraint old one", + N, New_Disc); + elsif not + Subtypes_Statically_Compatible ( + Etype (New_Disc), + Etype (Corresponding_Discriminant (New_Disc))) then - Error_Msg_N ("new discriminants must constrain old ones", - D_Constraint); - else - Set_Corresponding_Discriminant (New_Disc, Old_Disc); + Error_Msg_NE + ("& not statically compatible with parent discriminant", + N, New_Disc); + end if; - Next_Discriminant (Old_Disc); Next_Discriminant (New_Disc); - Next (Disc_Spec); end loop; - - if Present (Old_Disc) or else Present (Disc_Spec) then - Error_Msg_N ("discriminant mismatch in derivation", N); - end if; - end if; elsif Present (Discriminant_Specifications (N)) then @@ -4956,6 +5076,9 @@ package body Sem_Ch3 is N); end if; + -- The entity chain of the derived type includes the new + -- discriminants but shares operations with the parent. + if Present (Discriminant_Specifications (N)) then Old_Disc := First_Discriminant (Parent_Type); while Present (Old_Disc) loop @@ -4983,6 +5106,13 @@ package body Sem_Ch3 is Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type)); Set_Has_Completion (Derived_Type); + + if Corr_Decl_Needed then + Set_Stored_Constraint (Derived_Type, New_Constraint); + Insert_After (N, Corr_Decl); + Analyze (Corr_Decl); + Set_Corresponding_Record_Type (Derived_Type, Corr_Record); + end if; end Build_Derived_Concurrent_Type; ------------------------------------ diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 2b51273..b598b77 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -6850,15 +6850,16 @@ package Sinfo is -- SCIL Nodes -- ----------------- - -- SCIL nodes are special nodes added to the tree when the CodePeer mode - -- is active. They help CodePeer backend to locate nodes that require - -- special processing. - - -- Where is the detailed description of what these nodes are for??? The - -- above is not sufficient. The description should be here, or perhaps - -- it could be in a new Sem_SCIL unit, with a pointer from here. But - -- right now I am afraid this documentation is missing and the purpose - -- of these nodes remains secret??? + -- SCIL nodes are special nodes added to the tree when the CodePeer + -- mode is active. They help the CodePeer backend to locate nodes that + -- require special processing. + + -- Major documentation on the general design of the SCIL interface, and + -- in particular detailed description of these nodes is missing and is + -- to be supplied in the future, when the design has finalized ??? + + -- Meanwhile these nodes should be considered in experimental form, and + -- should be ignored by all code generating back ends. ??? -- N_SCIL_Dispatch_Table_Object_Init -- Sloc references a declaration node containing a dispatch table