From ea0342360d98139d57ce7550ef03da55616a0a00 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 22 Oct 2010 11:14:01 +0200 Subject: [PATCH] [multiple changes] 2010-10-22 Thomas Quinot * einfo.ads (Declaration_Node): Clarify documentation, in particular regarding what is returned for subprogram entities. 2010-10-22 Arnaud Charlet * exp_attr.adb (Make_Range_Test): Generate a Range node instead of explicit comparisons, generates simpler expanded code. * a-except-2005.adb (Rcheck_06_Ext): New. * gcc-interface/trans.c (gigi, gnat_to_gnu): Handle validity checks like range checks. * gcc-interface/Make-lang.in: Update dependencies. 2010-10-22 Robert Dewar * sem_ch3.adb (Array_Type_Declaration): Error for subtype wi predicate for index type (Constrain_Index): Error of subtype wi predicate in index constraint * sem_ch9.adb (Analyze_Entry_Declaration): Error of subtype wi predicate in entry family. * sem_res.adb (Resolve_Slice): Error of type wi predicate in slice. 2010-10-22 Javier Miranda * sem_util.ads, sem_util.adb (Collect_Parents): New subprogram. (Original_Corresponding_Operation): New subprogram. (Visible_Ancestors): New subprogram. * sem_ch6.adb (New_Overloaded_Entity): Handle new case of dispatching operation that overrides a hidden inherited primitive. * sem_disp.adb (Find_Hidden_Overridden_Primitive): New subprogram. (Check_Dispatching_Operation): if the new dispatching operation does not override a visible primtive then check if it overrides some hidden inherited primitive. 2010-10-22 Ed Schonberg * sem_ch10.adb (Analyze_With_Clause): If the parent_unit_name in a with clause is a child unit that denotes a renaming, replace the parent_unit_name with a reference to the renamed unit, because the prefix is irrelevant to subsequent visibility.. From-SVN: r165805 --- gcc/ada/ChangeLog | 42 ++++++++++ gcc/ada/a-except-2005.adb | 15 ++++ gcc/ada/einfo.ads | 16 ++-- gcc/ada/exp_attr.adb | 27 +++---- gcc/ada/gcc-interface/Make-lang.in | 29 +++---- gcc/ada/gcc-interface/trans.c | 8 +- gcc/ada/sem_ch10.adb | 16 ++++ gcc/ada/sem_ch3.adb | 20 ++++- gcc/ada/sem_ch6.adb | 14 ++++ gcc/ada/sem_ch9.adb | 17 +++++ gcc/ada/sem_disp.adb | 119 +++++++++++++++++++++++++++-- gcc/ada/sem_res.adb | 11 ++- gcc/ada/sem_util.adb | 111 +++++++++++++++++++++++++++ gcc/ada/sem_util.ads | 20 +++++ 14 files changed, 415 insertions(+), 50 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b396ff6dad9..07ce0f5cfc3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,45 @@ +2010-10-22 Thomas Quinot + + * einfo.ads (Declaration_Node): Clarify documentation, in particular + regarding what is returned for subprogram entities. + +2010-10-22 Arnaud Charlet + + * exp_attr.adb (Make_Range_Test): Generate a Range node instead of + explicit comparisons, generates simpler expanded code. + * a-except-2005.adb (Rcheck_06_Ext): New. + * gcc-interface/trans.c (gigi, gnat_to_gnu): Handle validity checks + like range checks. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-10-22 Robert Dewar + + * sem_ch3.adb (Array_Type_Declaration): Error for subtype wi predicate + for index type + (Constrain_Index): Error of subtype wi predicate in index constraint + * sem_ch9.adb (Analyze_Entry_Declaration): Error of subtype wi + predicate in entry family. + * sem_res.adb (Resolve_Slice): Error of type wi predicate in slice. + +2010-10-22 Javier Miranda + + * sem_util.ads, sem_util.adb (Collect_Parents): New subprogram. + (Original_Corresponding_Operation): New subprogram. + (Visible_Ancestors): New subprogram. + * sem_ch6.adb (New_Overloaded_Entity): Handle new case of dispatching + operation that overrides a hidden inherited primitive. + * sem_disp.adb (Find_Hidden_Overridden_Primitive): New subprogram. + (Check_Dispatching_Operation): if the new dispatching operation + does not override a visible primtive then check if it overrides + some hidden inherited primitive. + +2010-10-22 Ed Schonberg + + * sem_ch10.adb (Analyze_With_Clause): If the parent_unit_name in a with + clause is a child unit that denotes a renaming, replace the + parent_unit_name with a reference to the renamed unit, because the + prefix is irrelevant to subsequent visibility.. + 2010-10-22 Robert Dewar * einfo.ads, einfo.adb (Has_Predicates): Flag is now on all entities diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index 48574e236fe..b53560794b0 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -469,6 +469,8 @@ package body Ada.Exceptions is (File : System.Address; Line, Column : Integer); procedure Rcheck_05_Ext (File : System.Address; Line, Column, Index, First, Last : Integer); + procedure Rcheck_06_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer); procedure Rcheck_12_Ext (File : System.Address; Line, Column, Index, First, Last : Integer); @@ -509,6 +511,7 @@ package body Ada.Exceptions is pragma Export (C, Rcheck_00_Ext, "__gnat_rcheck_00_ext"); pragma Export (C, Rcheck_05_Ext, "__gnat_rcheck_05_ext"); + pragma Export (C, Rcheck_06_Ext, "__gnat_rcheck_06_ext"); pragma Export (C, Rcheck_12_Ext, "__gnat_rcheck_12_ext"); -- None of these procedures ever returns (they raise an exception!). By @@ -551,6 +554,7 @@ package body Ada.Exceptions is pragma No_Return (Rcheck_00_Ext); pragma No_Return (Rcheck_05_Ext); + pragma No_Return (Rcheck_06_Ext); pragma No_Return (Rcheck_12_Ext); --------------------------------------------- @@ -1236,6 +1240,17 @@ package body Ada.Exceptions is Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); end Rcheck_05_Ext; + procedure Rcheck_06_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer) + is + Msg : constant String := + Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF & + "value " & Image (Index) & " not in " & Image (First) & + ".." & Image (Last) & ASCII.NUL; + begin + Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); + end Rcheck_06_Ext; + procedure Rcheck_12_Ext (File : System.Address; Line, Column, Index, First, Last : Integer) is diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index febac6df740..e45d3d7c2f6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -692,13 +692,15 @@ package Einfo is -- details of the use of this field. -- Declaration_Node (synthesized) --- Applies to all entities. Returns the tree node for the declaration --- that declared the entity. Normally this is just the Parent of the --- entity. One exception arises with child units, where the parent of --- the entity is a selected component or a defining program unit name. --- Another exception is that if the entity is an incomplete type that --- has been completed, then we obtain the declaration node denoted by --- the full type, i.e. the full type declaration node. +-- Applies to all entities. Returns the tree node for the construct that +-- declared the entity. Normally this is just the Parent of the entity. +-- One exception arises with child units, where the parent of the entity +-- is a selected component/defining program unit name. Another exception +-- is that if the entity is an incomplete type that has been completed, +-- then we obtain the declaration node denoted by the full type, i.e. the +-- full type declaration node. Also note that for subprograms, this +-- returns the {function,procedure}_specification, not the subprogram_ +-- declaration. -- Default_Expr_Function (Node21) -- Present in parameters. It holds the entity of the parameterless diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 6d676acbca9..2e1073bacdc 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -4711,9 +4711,7 @@ package body Exp_Attr is function Make_Range_Test return Node_Id; -- Build the code for a range test of the form - -- Btyp!(Pref) >= Btyp!(Ptyp'First) - -- and then - -- Btyp!(Pref) <= Btyp!(Ptyp'Last) + -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last) --------------------- -- Make_Range_Test -- @@ -4732,24 +4730,17 @@ package body Exp_Attr is end if; return - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Ge (Loc, - Left_Opnd => - Unchecked_Convert_To (Btyp, Temp), - - Right_Opnd => + Make_In (Loc, + Left_Opnd => + Unchecked_Convert_To (Btyp, Temp), + Right_Opnd => + Make_Range (Loc, + Low_Bound => Unchecked_Convert_To (Btyp, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ptyp, Loc), - Attribute_Name => Name_First))), - - Right_Opnd => - Make_Op_Le (Loc, - Left_Opnd => - Unchecked_Convert_To (Btyp, Temp), - - Right_Opnd => + Attribute_Name => Name_First)), + High_Bound => Unchecked_Convert_To (Btyp, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ptyp, Loc), diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 8ead8b64260..693619e57e5 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1797,20 +1797,21 @@ ada/exp_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/exp_ch13.ads \ - ada/exp_ch13.adb ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_imgv.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/rtsfind.ads \ - ada/sem.ads ada/sem_aux.ads ada/sem_ch3.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_ch13.ads ada/exp_ch13.adb \ + ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_imgv.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \ + ada/sem_ch3.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/validsw.ads ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 90be61c5244..f1598364a7b 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -482,8 +482,9 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, gnat_raise_decls_ext[i] = build_raise_check (i, t, i == CE_Index_Check_Failed - || i == CE_Range_Check_Failed ? - exception_range : exception_column); + || i == CE_Range_Check_Failed + || i == CE_Invalid_Data + ? exception_range : exception_column); } /* Set the types that GCC and Gigi use from the front end. */ @@ -5518,7 +5519,8 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = build_call_raise_column (reason, gnat_node); } else if ((reason == CE_Index_Check_Failed - || reason == CE_Range_Check_Failed) + || reason == CE_Range_Check_Failed + || reason == CE_Invalid_Data) && Nkind (cond) == N_Op_Not && Nkind (Right_Opnd (cond)) == N_In && Nkind (Right_Opnd (Right_Opnd (cond))) == N_Range) diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 89dda5da36d..9ddde90459e 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2556,6 +2556,22 @@ package body Sem_Ch10 is Par_Name := Scope (E_Name); while Nkind (Pref) = N_Selected_Component loop Change_Selected_Component_To_Expanded_Name (Pref); + + if Present (Entity (Selector_Name (Pref))) + and then + Present (Renamed_Entity (Entity (Selector_Name (Pref)))) + and then Entity (Selector_Name (Pref)) /= Par_Name + then + + -- The prefix is a child unit that denotes a renaming + -- declaration. Replace the prefix directly with the renamed + -- unit, because the rest of the prefix is irrelevant to the + -- visibility of the real unit. + + Rewrite (Pref, New_Occurrence_Of (Par_Name, Sloc (Pref))); + exit; + end if; + Set_Entity_With_Style_Check (Pref, Par_Name); Generate_Reference (Par_Name, Pref); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 335d348b649..22d2fdf551e 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -446,7 +446,7 @@ package body Sem_Ch3 is Related_Id : Entity_Id; Suffix : Character; Suffix_Index : Nat); - -- Process an index constraint in a constrained array declaration. The + -- Process an index constraint S in a constrained array declaration. The -- constraint can be a subtype name, or a range with or without an explicit -- subtype mark. The index is the corresponding index of the unconstrained -- array. The Related_Id and Suffix parameters are used to build the @@ -4424,6 +4424,17 @@ package body Sem_Ch3 is end if; Make_Index (Index, P, Related_Id, Nb_Index); + + -- Check error of subtype with predicate for index type + + if Has_Predicates (Etype (Index)) then + Error_Msg_NE + ("subtype& has predicate, not allowed as index subtype", + Index, Etype (Index)); + end if; + + -- Move to next index + Next_Index (Index); Nb_Index := Nb_Index + 1; end loop; @@ -11332,6 +11343,13 @@ package body Sem_Ch3 is elsif Base_Type (Entity (S)) /= Base_Type (T) then Wrong_Type (S, Base_Type (T)); + + -- Check error of subtype with predicate in index constraint + + elsif Has_Predicates (Entity (S)) then + Error_Msg_NE + ("subtype& has predicate, not allowed in index consraint", + S, Entity (S)); end if; return; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index fe2e1973797..f5853685f0b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -7824,6 +7824,20 @@ package body Sem_Ch6 is if Comes_From_Source (S) then Check_Synchronized_Overriding (S, Overridden_Subp); + + -- (Ada 2012: AI05-0125-1): If S is a dispatching operation then + -- it may have overridden some hidden inherited primitive. Update + -- Overriden_Subp to avoid spurious errors when checking the + -- overriding indicator. + + if Ada_Version >= Ada_2012 + and then No (Overridden_Subp) + and then Is_Dispatching_Operation (S) + and then Is_Overriding_Operation (S) + then + Overridden_Subp := Overridden_Operation (S); + end if; + Check_Overriding_Indicator (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp); end if; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index e060504d505..42297a114e9 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -879,19 +879,36 @@ package body Sem_Ch9 is Generate_Definition (Def_Id); Tasking_Used := True; + -- Case of no discrete subtype definition + if No (D_Sdef) then Set_Ekind (Def_Id, E_Entry); + + -- Processing for discrete subtype definition present + else Enter_Name (Def_Id); Set_Ekind (Def_Id, E_Entry_Family); Analyze (D_Sdef); Make_Index (D_Sdef, N, Def_Id); + + -- Check subtype with predicate in entry family + + if Has_Predicates (Etype (D_Sdef)) then + Error_Msg_NE + ("subtype& has predicate, not allowed in entry family", + D_Sdef, Etype (D_Sdef)); + end if; end if; + -- Decorate Def_Id + Set_Etype (Def_Id, Standard_Void_Type); Set_Convention (Def_Id, Convention_Entry); Set_Accept_Address (Def_Id, New_Elmt_List); + -- Process formals + if Present (Formals) then Set_Scope (Def_Id, Current_Scope); Push_Scope (Def_Id); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 322e5352f4d..774c2affc7c 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -72,6 +72,18 @@ package body Sem_Disp is -- (returning the designated tagged type in the case of an access -- parameter); otherwise returns empty. + function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id; + -- [Ada 2012:AI-0125] Find an inherited hidden primitive of the dispatching + -- type of S that has the same name of S, a type-conformant profile, an + -- original corresponding operation O that is a primitive of a visible + -- ancestor of the dispatching type of S and O is visible at the point of + -- of declaration of S. If the entity is found the Alias of S is set to the + -- original corresponding operation S and its Overridden_Operation is set + -- to the found entity; otherwise return Empty. + -- + -- This routine does not search for non-hidden primitives since they are + -- covered by the normal Ada 2005 rules. + ------------------------------- -- Add_Dispatching_Operation -- ------------------------------- @@ -741,8 +753,9 @@ package body Sem_Disp is procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is Tagged_Type : Entity_Id; - Has_Dispatching_Parent : Boolean := False; - Body_Is_Last_Primitive : Boolean := False; + Has_Dispatching_Parent : Boolean := False; + Body_Is_Last_Primitive : Boolean := False; + Ovr_Subp : Entity_Id := Empty; begin if not Ekind_In (Subp, E_Procedure, E_Function) then @@ -1078,14 +1091,25 @@ package body Sem_Disp is Check_Controlling_Formals (Tagged_Type, Subp); + Ovr_Subp := Old_Subp; + + -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be + -- overridden by Subp + + if No (Ovr_Subp) + and then Ada_Version >= Ada_2012 + then + Ovr_Subp := Find_Hidden_Overridden_Primitive (Subp); + end if; + -- Now it should be a correct primitive operation, put it in the list - if Present (Old_Subp) then + if Present (Ovr_Subp) then -- If the type has interfaces we complete this check after we set -- attribute Is_Dispatching_Operation. - Check_Subtype_Conformant (Subp, Old_Subp); + Check_Subtype_Conformant (Subp, Ovr_Subp); if (Chars (Subp) = Name_Initialize or else Chars (Subp) = Name_Adjust @@ -1114,7 +1138,7 @@ package body Sem_Disp is end if; else - Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); + Override_Dispatching_Operation (Tagged_Type, Ovr_Subp, Subp); Set_Is_Overriding_Operation (Subp); -- Ada 2005 (AI-251): In case of late overriding of a primitive @@ -1183,7 +1207,7 @@ package body Sem_Disp is -- subtype conformance against all the interfaces covered by this -- primitive. - if Present (Old_Subp) + if Present (Ovr_Subp) and then Has_Interfaces (Tagged_Type) then declare @@ -1649,6 +1673,89 @@ package body Sem_Disp is return Empty; end Find_Dispatching_Type; + -------------------------------------- + -- Find_Hidden_Overridden_Primitive -- + -------------------------------------- + + function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id + is + Tag_Typ : constant Entity_Id := Find_Dispatching_Type (S); + Elmt : Elmt_Id; + Orig_Prim : Entity_Id; + Prim : Entity_Id; + Vis_List : Elist_Id; + + begin + -- This Ada 2012 rule is valid only for type extensions or private + -- extensions + + if No (Tag_Typ) + or else not Is_Record_Type (Tag_Typ) + or else Etype (Tag_Typ) = Tag_Typ + then + return Empty; + end if; + + -- Collect the list of visible ancestor of the tagged type + + Vis_List := Visible_Ancestors (Tag_Typ); + + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + + -- Find an inherited hidden dispatching primitive with the name of S + -- and a type-conformant profile + + if Present (Alias (Prim)) + and then Is_Hidden (Alias (Prim)) + and then Find_Dispatching_Type (Alias (Prim)) /= Tag_Typ + and then Primitive_Names_Match (S, Prim) + and then Type_Conformant (S, Prim) + then + declare + Vis_Ancestor : Elmt_Id; + Elmt : Elmt_Id; + + begin + -- The original corresponding operation of Prim must be an + -- operation of a visible ancestor of the dispatching type + -- of S, and the original corresponding operation of S2 must + -- be visible. + + Orig_Prim := Original_Corresponding_Operation (Prim); + + if Orig_Prim /= Prim + and then Is_Immediately_Visible (Orig_Prim) + then + Vis_Ancestor := First_Elmt (Vis_List); + + while Present (Vis_Ancestor) loop + Elmt := + First_Elmt (Primitive_Operations (Node (Vis_Ancestor))); + while Present (Elmt) loop + if Node (Elmt) = Orig_Prim then + Set_Overridden_Operation (S, Prim); + Set_Alias (Prim, Orig_Prim); + + return Prim; + end if; + + Next_Elmt (Elmt); + end loop; + + Next_Elmt (Vis_Ancestor); + end loop; + end if; + end; + end if; + + Next_Elmt (Elmt); + end loop; + + return Empty; + end Find_Hidden_Overridden_Primitive; + --------------------------------------- -- Find_Primitive_Covering_Interface -- --------------------------------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 7c823a8b261..6df474133d2 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8478,7 +8478,16 @@ package body Sem_Res is Set_Slice_Subtype (N); - if Nkind (Drange) = N_Range then + -- Check bad use of type with predicates + + if Has_Predicates (Etype (Drange)) then + Error_Msg_NE + ("subtype& has predicate, not allowed in slice", + Drange, Etype (Drange)); + + -- Otherwise here is where we check suspicious indexes + + elsif Nkind (Drange) = N_Range then Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); Warn_On_Suspicious_Index (Name, High_Bound (Drange)); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ba4d37df723..676051d379c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1679,6 +1679,44 @@ package body Sem_Util is end loop; end Collect_Interfaces_Info; + --------------------- + -- Collect_Parents -- + --------------------- + + procedure Collect_Parents + (T : Entity_Id; + List : out Elist_Id; + Use_Full_View : Boolean := True) + is + Current_Typ : Entity_Id := T; + Parent_Typ : Entity_Id; + + begin + List := New_Elmt_List; + + -- No action if the if the type has no parents + + if T = Etype (T) then + return; + end if; + + loop + Parent_Typ := Etype (Current_Typ); + + if Is_Private_Type (Parent_Typ) + and then Present (Full_View (Parent_Typ)) + and then Use_Full_View + then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + + Append_Elmt (Parent_Typ, List); + + exit when Parent_Typ = Current_Typ; + Current_Typ := Parent_Typ; + end loop; + end Collect_Parents; + ---------------------------------- -- Collect_Primitive_Operations -- ---------------------------------- @@ -9790,6 +9828,38 @@ package body Sem_Util is end if; end Object_Access_Level; + -------------------------------------- + -- Original_Corresponding_Operation -- + -------------------------------------- + + function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id + is + Typ : constant Entity_Id := Find_Dispatching_Type (S); + + begin + -- If S is an inherited primitive S2 the original corresponding + -- operation of S is the original corresponding operation of S2 + + if Present (Alias (S)) + and then Find_Dispatching_Type (Alias (S)) /= Typ + then + return Original_Corresponding_Operation (Alias (S)); + + -- If S overrides an inherted subprogram S2 the original corresponding + -- operation of S is the original corresponding operation of S2 + + elsif Is_Overriding_Operation (S) + and then Present (Overridden_Operation (S)) + then + return Original_Corresponding_Operation (Overridden_Operation (S)); + + -- otherwise it is S itself + + else + return S; + end if; + end Original_Corresponding_Operation; + ----------------------- -- Private_Component -- ----------------------- @@ -11387,6 +11457,47 @@ package body Sem_Util is end if; end Unqualify; + ----------------------- + -- Visible_Ancestors -- + ----------------------- + + function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is + List_1 : Elist_Id; + List_2 : Elist_Id; + Elmt : Elmt_Id; + + begin + pragma Assert (Is_Record_Type (Typ) + and then Is_Tagged_Type (Typ)); + + -- Collect all the parents and progenitors of Typ. If the full-view of + -- private parents and progenitors is available then it is used to + -- generate the list of visible ancestors; otherwise their partial + -- view is added to the resulting list. + + Collect_Parents + (T => Typ, + List => List_1, + Use_Full_View => True); + + Collect_Interfaces + (T => Typ, + Ifaces_List => List_2, + Exclude_Parents => True, + Use_Full_View => True); + + -- Join the two lists. Avoid duplications because an interface may + -- simultaneously be parent and progenitor of a type. + + Elmt := First_Elmt (List_2); + while Present (Elmt) loop + Append_Unique_Elmt (Node (Elmt), List_1); + Next_Elmt (Elmt); + end loop; + + return List_1; + end Visible_Ancestors; + ---------------------- -- Within_Init_Proc -- ---------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 9c8bdd1fe1c..ec330992cd2 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -197,6 +197,13 @@ package Sem_Util is -- of elements, and elements at the same position on these tables provide -- information on the same interface type. + procedure Collect_Parents + (T : Entity_Id; + List : out Elist_Id; + Use_Full_View : Boolean := True); + -- Collect all the parents of Typ. Use_Full_View is used to collect them + -- using the full-view of private parents (if available). + function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id; -- Called upon type derivation and extension. We scan the declarative part -- in which the type appears, and collect subprograms that have one @@ -1052,6 +1059,12 @@ package Sem_Util is -- (e.g. target of assignment, or out parameter), and to False if the -- modification is only potential (e.g. address of entity taken). + function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id; + -- [Ada 2012: AI05-0125-1]: If S is an inherited dispatching primitive S2, + -- or overrides an inherited dispatching primitive S2, the original + -- corresponding operation of S is the original corresponding operation of + -- S2. Otherwise, it is S itself. + function Object_Access_Level (Obj : Node_Id) return Uint; -- Return the accessibility level of the view of the object Obj. -- For convenience, qualified expressions applied to object names @@ -1290,6 +1303,13 @@ package Sem_Util is -- Removes any qualifications from Expr. For example, for T1'(T2'(X)), this -- returns X. If Expr is not a qualified expression, returns Expr. + function Visible_Ancestors (Typ : Entity_Id) return Elist_Id; + -- [Ada 2012:AI-0125-1]: Collect all the visible parents and progenitors + -- of a type extension or private extension declaration. If the full-view + -- of private parents and progenitors is available then it is used to + -- generate the list of visible ancestors; otherwise their partial + -- view is added to the resulting list. + function Within_Init_Proc return Boolean; -- Determines if Current_Scope is within an init proc -- 2.30.2