From f3296dd398cbfd8b126d3f8bf49ea47691b69f2c Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 31 Jul 2014 14:28:48 +0200 Subject: [PATCH] [multiple changes] 2014-07-31 Gary Dismukes * exp_util.adb: Minor reformatting. 2014-07-31 Vincent Celier * errutil.adb (Error_Msg): Make sure that all components of the error message object are initialized. 2014-07-31 Ed Schonberg * sem_ch4.adb (Try_Container_Indexing): If the container type is class-wide, use specific type to locate iteration primitives. * sem_ch13.adb (Check_Indexing_Functions): Add legality checks for rules in RM 4.1.6 (Illegal_Indexing): New diagnostic procedure. Minor error message reformating. * exp_ch5.adb (Expand_Iterator_Loop): Handle properly Iterator aspect for a derived type. 2014-07-31 Robert Dewar * debug.adb: Document debug flag d.X. From-SVN: r213346 --- gcc/ada/ChangeLog | 23 +++++++++ gcc/ada/debug.adb | 8 ++- gcc/ada/errutil.adb | 39 +++++++------- gcc/ada/exp_ch5.adb | 114 +++++++++++++++++++++++++++++++---------- gcc/ada/exp_util.adb | 10 ++-- gcc/ada/sem_ch13.adb | 119 +++++++++++++++++++++++++++++++++++++------ gcc/ada/sem_ch4.adb | 13 ++++- 7 files changed, 256 insertions(+), 70 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f806a8b8371..03aa74363a7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2014-07-31 Gary Dismukes + + * exp_util.adb: Minor reformatting. + +2014-07-31 Vincent Celier + + * errutil.adb (Error_Msg): Make sure that all components of + the error message object are initialized. + +2014-07-31 Ed Schonberg + + * sem_ch4.adb (Try_Container_Indexing): If the container type is + class-wide, use specific type to locate iteration primitives. + * sem_ch13.adb (Check_Indexing_Functions): Add legality checks for + rules in RM 4.1.6 (Illegal_Indexing): New diagnostic procedure. + Minor error message reformating. + * exp_ch5.adb (Expand_Iterator_Loop): Handle properly Iterator + aspect for a derived type. + +2014-07-31 Robert Dewar + + * debug.adb: Document debug flag d.X. + 2014-07-31 Ed Schonberg * sem_util.ads (Find_Specific_Type): Moved here from exp_disp.adb. diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 64162ef0602..a1a1d8c1a13 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -141,7 +141,7 @@ package body Debug is -- d.U Ignore indirect calls for static elaboration -- d.V -- d.W Print out debugging information for Walk_Library_Items - -- d.X + -- d.X Old treatment of indexing aspects -- d.Y -- d.Z @@ -685,6 +685,12 @@ package body Debug is -- the order in which units are walked. This is primarily for use in -- debugging CodePeer mode. + -- d.X A previous version of GNAT allowed indexing aspects to be + -- redefined on derived container types, while the default iterator + -- was inherited from the aprent type. This non-standard extension + -- is preserved temporarily for use by the modelling project under + -- debug flag d.X. + -- d1 Error messages have node numbers where possible. Normally error -- messages have only source locations. This option is useful when -- debugging errors caused by expanded code, where the source location diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index e63ebc009cc..4121ba983b9 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -201,24 +201,27 @@ package body Errutil is -- Otherwise build error message object for new message - Errors.Increment_Last; - Cur_Msg := Errors.Last; - Errors.Table (Cur_Msg).Text := new String'(Msg_Buffer (1 .. Msglen)); - Errors.Table (Cur_Msg).Next := No_Error_Msg; - Errors.Table (Cur_Msg).Sptr := Sptr; - Errors.Table (Cur_Msg).Optr := Optr; - Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Sptr); - Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Sptr); - Errors.Table (Cur_Msg).Col := Get_Column_Number (Sptr); - Errors.Table (Cur_Msg).Style := Is_Style_Msg; - Errors.Table (Cur_Msg).Warn := Is_Warning_Msg; - Errors.Table (Cur_Msg).Info := Is_Info_Msg; - Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char; - Errors.Table (Cur_Msg).Serious := Is_Serious_Error; - Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg; - Errors.Table (Cur_Msg).Msg_Cont := Continuation; - Errors.Table (Cur_Msg).Deleted := False; - + Errors.Append + (New_Val => + (Text => new String'(Msg_Buffer (1 .. Msglen)), + Next => No_Error_Msg, + Prev => No_Error_Msg, + Sfile => Get_Source_File_Index (Sptr), + Sptr => Sptr, + Optr => Optr, + Line => Get_Physical_Line_Number (Sptr), + Col => Get_Column_Number (Sptr), + Warn => Is_Warning_Msg, + Info => Is_Info_Msg, + Warn_Err => Warning_Mode = Treat_As_Error, + Warn_Chr => Warning_Msg_Char, + Style => Is_Style_Msg, + Serious => Is_Serious_Error, + Uncond => Is_Unconditional_Msg, + Msg_Cont => Continuation, + Deleted => False)); + + Cur_Msg := Errors.Last; Prev_Msg := No_Error_Msg; Next_Msg := First_Error_Msg; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 94f6cd92a69..120200f8915 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -28,6 +28,7 @@ with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; @@ -58,6 +59,7 @@ with Stand; use Stand; with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; +with Uintp; use Uintp; with Validsw; use Validsw; package body Exp_Ch5 is @@ -3292,17 +3294,90 @@ package body Exp_Ch5 is -- type of the iterator must be obtained from the aspect. if Of_Present (I_Spec) then - declare - Default_Iter : constant Entity_Id := - Entity - (Find_Value_Of_Aspect - (Etype (Container), - Aspect_Default_Iterator)); - + Handle_Of : declare + Default_Iter : Entity_Id; Container_Arg : Node_Id; Ent : Entity_Id; + function Get_Default_Iterator + (T : Entity_Id) return Entity_Id; + -- If the container is a derived type, the aspect holds the + -- parent operation. The required one is a primitive of the + -- derived type and is either inherited or overridden. + + -------------------------- + -- Get_Default_Iterator -- + -------------------------- + + function Get_Default_Iterator + (T : Entity_Id) return Entity_Id + is + Iter : constant Entity_Id := + Entity (Find_Value_Of_Aspect (T, Aspect_Default_Iterator)); + Prim : Elmt_Id; + Op : Entity_Id; + + begin + Container_Arg := New_Copy_Tree (Container); + + -- A previous version of GNAT allowed indexing aspects to + -- be redefined on derived container types, while the + -- default iterator was inherited from the aprent type. + -- This non-standard extension is preserved temporarily for + -- use by the modelling project under debug flag d.X. + + if Debug_Flag_Dot_XX then + if Base_Type (Etype (Container)) /= + Base_Type (Etype (First_Formal (Iter))) + then + Container_Arg := + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Etype (First_Formal (Iter)), Loc), + Expression => Container_Arg); + end if; + + return Iter; + + elsif Is_Derived_Type (T) then + + -- The default iterator must be a primitive operation + -- of the type, at the same dispatch slot position. + + Prim := First_Elmt (Primitive_Operations (T)); + while Present (Prim) loop + Op := Node (Prim); + + if Chars (Op) = Chars (Iter) + and then DT_Position (Op) = DT_Position (Iter) + then + return Op; + end if; + + Next_Elmt (Prim); + end loop; + + -- default iterator must exist. + + pragma Assert (False); + + else -- not a derived type + return Iter; + end if; + end Get_Default_Iterator; + + -- Start of processing for Handle_Of + begin + if Is_Class_Wide_Type (Container_Typ) then + Default_Iter := + Get_Default_Iterator (Etype (Base_Type (Container_Typ))); + + else + Default_Iter := Get_Default_Iterator (Etype (Container)); + end if; + Cursor := Make_Temporary (Loc, 'C'); -- For an container element iterator, the iterator type @@ -3320,24 +3395,7 @@ package body Exp_Ch5 is Pack := Scope (Root_Type (Etype (Iter_Type))); -- Rewrite domain of iteration as a call to the default - -- iterator for the container type. If the container is - -- a derived type and the aspect is inherited, convert - -- container to parent type. The Cursor type is also - -- inherited from the scope of the parent. - - if Base_Type (Etype (Container)) = - Base_Type (Etype (First_Formal (Default_Iter))) - then - Container_Arg := New_Copy_Tree (Container); - - else - Container_Arg := - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of - (Etype (First_Formal (Default_Iter)), Loc), - Expression => New_Copy_Tree (Container)); - end if; + -- iterator for the container type. Rewrite (Name (I_Spec), Make_Function_Call (Loc, @@ -3367,9 +3425,9 @@ package body Exp_Ch5 is Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Id, - Subtype_Mark => + Subtype_Mark => New_Occurrence_Of (Element_Type, Loc), - Name => + Name => Make_Indexed_Component (Loc, Prefix => Relocate_Node (Container_Arg), Expressions => @@ -3415,7 +3473,7 @@ package body Exp_Ch5 is else Prepend_To (Stats, Decl); end if; - end; + end Handle_Of; -- X in Iterate (S) : type of iterator is type of explicitly -- given Iterate function, and the loop variable is the cursor. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index a61efab750d..c99a67446f3 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -786,7 +786,7 @@ package body Exp_Util is if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc)); - -- For deallocation of class wide types we obtain the value of + -- For deallocation of class-wide types we obtain the value of -- alignment from the Type Specific Record of the deallocated object. -- This is needed because the frontend expansion of class-wide types -- into equivalent types confuses the backend. @@ -5860,7 +5860,7 @@ package body Exp_Util is Set_Is_Class_Wide_Equivalent_Type (Equiv_Type); - -- A class_wide equivalent type does not require initialization + -- A class-wide equivalent type does not require initialization Set_Suppress_Initialization (Equiv_Type); @@ -6097,7 +6097,7 @@ package body Exp_Util is -- 2. If Expr is a unconstrained discriminated type expression, creates -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n) - -- 3. If Expr is class-wide, creates an implicit class wide subtype + -- 3. If Expr is class-wide, creates an implicit class-wide subtype function Make_Subtype_From_Expr (E : Node_Id; @@ -6186,8 +6186,8 @@ package body Exp_Util is if Expander_Active and then Tagged_Type_Expansion then - -- If this is the class_wide type of a completion that is a - -- record subtype, set the type of the class_wide type to be + -- If this is the class-wide type of a completion that is a + -- record subtype, set the type of the class-wide type to be -- the full base type, for use in the expanded code for the -- equivalent type. Should this be done earlier when the -- completion is analyzed ??? diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 2ef89b623a1..e58614d4b5a 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1671,7 +1671,9 @@ package body Sem_Ch13 is and then not (Is_Type (E) and then Is_Tagged_Type (E)) then - Error_Msg_N ("indexing applies to a tagged type", N); + Error_Msg_N + ("indexing aspect can only apply to a tagged type", + Aspect); goto Continue; end if; @@ -3471,53 +3473,138 @@ package body Sem_Ch13 is -- Check one possible interpretation. Sets Indexing_Found True if an -- indexing function is found. + procedure Illegal_Indexing (Msg : String); + -- Diagnose illegal indexing function if not overloaded. In the + -- overloaded case indicate that no legal interpretation exists. + ------------------------ -- Check_One_Function -- ------------------------ procedure Check_One_Function (Subp : Entity_Id) is - Default_Element : constant Node_Id := - Find_Value_Of_Aspect - (Etype (First_Formal (Subp)), - Aspect_Iterator_Element); + Default_Element : Node_Id; + Ret_Type : constant Entity_Id := Etype (Subp); begin + if not Is_Overloadable (Subp) then + Illegal_Indexing ("illegal indexing function for type&"); + return; + + elsif Scope (Subp) /= Current_Scope then + Illegal_Indexing + ("indexing function must be declared in scope of type&"); + return; + + elsif No (First_Formal (Subp)) then + Illegal_Indexing + ("Indexing requires a function that applies to type&"); + return; + + elsif No (Next_Formal (First_Formal (Subp))) then + Illegal_Indexing + ("indexing function must have at least two parameters"); + return; + + elsif Is_Derived_Type (Ent) then + if (Attr = Name_Constant_Indexing + and then Present + (Find_Aspect (Etype (Ent), Aspect_Constant_Indexing))) + + or else (Attr = Name_Variable_Indexing + and then Present + (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing))) + then + if Debug_Flag_Dot_XX then + null; + + else + Illegal_Indexing + ("indexing function already inherited " + & "from parent type"); + end if; + + return; + end if; + end if; + if not Check_Primitive_Function (Subp) and then not Is_Overloaded (Expr) then - Error_Msg_NE - ("aspect Indexing requires a function that applies to type&", - Subp, Ent); + Illegal_Indexing + ("Indexing aspect requires a function that applies to type&"); + return; end if; -- An indexing function must return either the default element of -- the container, or a reference type. For variable indexing it -- must be the latter. + Default_Element := + Find_Value_Of_Aspect + (Etype (First_Formal (Subp)), Aspect_Iterator_Element); + if Present (Default_Element) then Analyze (Default_Element); if Is_Entity_Name (Default_Element) - and then Covers (Entity (Default_Element), Etype (Subp)) + and then not Covers (Entity (Default_Element), Ret_Type) + and then False then - Indexing_Found := True; + Illegal_Indexing + ("wrong return type for indexing function"); return; end if; end if; -- For variable_indexing the return type must be a reference type - if Attr = Name_Variable_Indexing - and then not Has_Implicit_Dereference (Etype (Subp)) - then - Error_Msg_N - ("function for indexing must return a reference type", Subp); + if Attr = Name_Variable_Indexing then + if not Has_Implicit_Dereference (Ret_Type) then + Illegal_Indexing + ("variable indexing must return a reference type"); + return; + + elsif Is_Access_Constant (Etype (First_Discriminant (Ret_Type))) + then + Illegal_Indexing + ("variable indexing must return an access to variable"); + return; + end if; else - Indexing_Found := True; + if Has_Implicit_Dereference (Ret_Type) + and then not + Is_Access_Constant (Etype (First_Discriminant (Ret_Type))) + then + Illegal_Indexing + ("constant indexing must return an access to constant"); + return; + + elsif Is_Access_Type (Etype (First_Formal (Subp))) + and then not Is_Access_Constant (Etype (First_Formal (Subp))) + then + Illegal_Indexing + ("constant indexing must apply to an access to constant"); + return; + end if; end if; + + -- All checks succeeded. + + Indexing_Found := True; end Check_One_Function; + ----------------------- + -- Illegal_Indexing -- + ----------------------- + + procedure Illegal_Indexing (Msg : String) is + begin + if not Is_Overloaded (Expr) then + Error_Msg_NE (Msg, N, Ent); + end if; + end Illegal_Indexing; + -- Start of processing for Check_Indexing_Functions begin diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index b78b06a05e0..7b296979823 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6959,6 +6959,7 @@ package body Sem_Ch4 is Exprs : List_Id) return Boolean is Loc : constant Source_Ptr := Sloc (N); + C_Type : Entity_Id; Assoc : List_Id; Disc : Entity_Id; Func : Entity_Id; @@ -6966,6 +6967,14 @@ package body Sem_Ch4 is Indexing : Node_Id; begin + C_Type := Etype (Prefix); + + -- If indexing a class-wide container, obtain indexing primitive + -- from specific type. + + if Is_Class_Wide_Type (C_Type) then + C_Type := Etype (Base_Type (C_Type)); + end if; -- Check whether type has a specified indexing aspect @@ -7013,10 +7022,10 @@ package body Sem_Ch4 is -- Additional machinery may be needed for types that have several user- -- defined Reference operations with different signatures ??? - elsif Is_Derived_Type (Etype (Prefix)) + elsif Is_Derived_Type (C_Type) and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix) then - Func := Find_Prim_Op (Etype (Prefix), Chars (Func_Name)); + Func := Find_Prim_Op (C_Type, Chars (Func_Name)); Func_Name := New_Occurrence_Of (Func, Loc); end if; -- 2.30.2