diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 16 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 27 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 27 | ||||
| -rwxr-xr-x | gcc/ada/sem_aux.adb | 55 | ||||
| -rwxr-xr-x | gcc/ada/sem_aux.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 26 |
15 files changed, 136 insertions, 68 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 68b248fab51..208867fe583 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,21 @@ 2010-10-08 Robert Dewar <dewar@adacore.com> + * sem_prag.adb (Check_Duplicate_Pragma): Check for entity match + * gcc-interface/Make-lang.in: Update dependencies. + * einfo.ads: Minor reformatting. + +2010-10-08 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb, sem_ch3.adb, exp_ch7.adb, exp_util.adb, sem_aux.adb, + sem_aux.ads, exp_ch4.adb, exp_ch6.adb, sem_ch6.adb, exp_aggr.adb, + exp_ch3.adb: Change Is_Inherently_Limited_Type to + Is_Immutably_Limited_Type to accord with new RM terminology. + * sem_aux.adb (Is_Immutably_Limited_Type): A type that is a descendant + of a formal limited private type is not immutably limited in a generic + body. + +2010-10-08 Robert Dewar <dewar@adacore.com> + * sem_prag.adb (Check_Duplicate_Pragma): New procedure Add calls to this new procedure where appropriate diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 5611278e6d7..a1034cf2fcb 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2436,7 +2436,7 @@ package Einfo is -- 4. Setting Component_Size of an array to a bit-packable value -- 3. Indexing an array with a non-standard enumeration type. -- --- For records, Is_Packed is always set if Has_Pack_Pragma is set, +-- For records, Is_Packed is always set if Has_Pragma_Pack is set, -- and can also be set on its own in a derived type which inherited -- its packed status. -- @@ -2455,7 +2455,7 @@ package Einfo is -- the bit packed case once the array type is frozen. -- -- Before an array type is frozen, Is_Packed will always be set if --- Has_Pack_Pragma is set. Before the freeze point, it is not possible +-- Has_Pragma_Pack is set. Before the freeze point, it is not possible -- to know the component size, since the component type is not frozen -- until the array type is frozen. Thus Is_Packed for an array type -- before it is frozen means that packed is required. Then if it turns diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index e60f21644ee..a352587828a 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -596,7 +596,7 @@ package body Exp_Aggr is -- If component is limited, aggregate must be expanded because each -- component assignment must be built in place. - if Is_Inherently_Limited_Type (Component_Type (Typ)) then + if Is_Immutably_Limited_Type (Component_Type (Typ)) then return False; end if; @@ -2120,7 +2120,7 @@ package body Exp_Aggr is then RC := RE_Limited_Record_Controller; - elsif Is_Inherently_Limited_Type (Target_Type) then + elsif Is_Immutably_Limited_Type (Target_Type) then RC := RE_Limited_Record_Controller; else @@ -3648,7 +3648,7 @@ package body Exp_Aggr is -- in place within the caller's scope). or else - (Is_Inherently_Limited_Type (Typ) + (Is_Immutably_Limited_Type (Typ) and then (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement or else Nkind (Parent_Node) = N_Simple_Return_Statement)) @@ -5598,7 +5598,7 @@ package body Exp_Aggr is -- Extension aggregates, aggregates in extended return statements, and -- aggregates for C++ imported types must be expanded. - if Ada_Version >= Ada_05 and then Is_Inherently_Limited_Type (Typ) then + if Ada_Version >= Ada_05 and then Is_Immutably_Limited_Type (Typ) then if not Nkind_In (Parent (N), N_Object_Declaration, N_Component_Association) then diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 77a09eb4aae..7dc684226a6 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1661,7 +1661,7 @@ package body Exp_Ch3 is and then Has_New_Controlled_Component (Enclos_Type) and then Has_Controlled_Component (Typ) then - if Is_Inherently_Limited_Type (Typ) then + if Is_Immutably_Limited_Type (Typ) then Controller_Typ := RTE (RE_Limited_Record_Controller); else Controller_Typ := RTE (RE_Record_Controller); @@ -1930,7 +1930,7 @@ package body Exp_Ch3 is if Needs_Finalization (Typ) and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) - and then not Is_Inherently_Limited_Type (Typ) + and then not Is_Immutably_Limited_Type (Typ) then declare Ref : constant Node_Id := @@ -4800,7 +4800,7 @@ package body Exp_Ch3 is -- creating the object (via allocator) and initializing it. if Is_Return_Object (Def_Id) - and then Is_Inherently_Limited_Type (Typ) + and then Is_Immutably_Limited_Type (Typ) then null; @@ -5014,7 +5014,7 @@ package body Exp_Ch3 is -- renaming declaration. if Needs_Finalization (Typ) - and then not Is_Inherently_Limited_Type (Typ) + and then not Is_Immutably_Limited_Type (Typ) and then not Rewrite_As_Renaming then Insert_Actions_After (Init_After, @@ -5291,7 +5291,7 @@ package body Exp_Ch3 is Loc := Sloc (First (Component_Items (Comp_List))); end if; - if Is_Inherently_Limited_Type (T) then + if Is_Immutably_Limited_Type (T) then Controller_Type := RTE (RE_Limited_Record_Controller); else Controller_Type := RTE (RE_Record_Controller); @@ -6099,7 +6099,11 @@ package body Exp_Ch3 is end if; Set_Is_Frozen (Def_Id); - Set_All_DT_Position (Def_Id); + if not Is_Derived_Type (Def_Id) + or else Is_Tagged_Type (Etype (Def_Id)) + then + Set_All_DT_Position (Def_Id); + end if; -- Add the controlled component before the freezing actions -- referenced in those actions. @@ -6194,9 +6198,16 @@ package body Exp_Ch3 is end if; end; - elsif Ada_Version >= Ada_12 - and then Comes_From_Source (Def_Id) + -- Otherwise create primitive equality operation (AI05-0123) + -- This is done unconditionally to ensure that tools can be linked + -- properly with user programs compiled with older language versions. + -- It might be worth including a switch to revert to a non-composable + -- equality for untagged records, even though no program depending on + -- non-composability has surfaced ??? + + elsif Comes_From_Source (Def_Id) and then Convention (Def_Id) = Convention_Ada + and then not Is_Limited_Type (Def_Id) then Build_Untagged_Equality (Def_Id); end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index b8c51dc7e56..505ebfeb183 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -947,7 +947,7 @@ package body Exp_Ch4 is -- want to Adjust. if not Aggr_In_Place - and then not Is_Inherently_Limited_Type (T) + and then not Is_Immutably_Limited_Type (T) then Insert_Actions (N, Make_Adjust_Call ( diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 647f08819f8..2c2ddb0a980 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3896,7 +3896,7 @@ package body Exp_Ch5 is -- the type of the expression may be. if not Comes_From_Extended_Return_Statement (N) - and then Is_Inherently_Limited_Type (Etype (Expression (N))) + and then Is_Immutably_Limited_Type (Etype (Expression (N))) and then Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L then @@ -3967,7 +3967,7 @@ package body Exp_Ch5 is -- type that requires special processing (indicated by the fact that -- it requires a cleanup scope for the secondary stack case). - if Is_Inherently_Limited_Type (Exptyp) + if Is_Immutably_Limited_Type (Exptyp) or else Is_Limited_Interface (Exptyp) then null; @@ -4252,7 +4252,7 @@ package body Exp_Ch5 is elsif Ekind (R_Type) = E_Anonymous_Access_Type and then Has_Controlling_Result (Scope_Id) - and then Ada_Version >= Ada_12 + and then (Ada_Version >= Ada_12 or else True) then Insert_Action (Exp, Make_Raise_Constraint_Error (Loc, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 6cfc955ffa5..423e24b8000 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3106,7 +3106,7 @@ package body Exp_Ch6 is -- not a rewriting of a protected function call. if Needs_Finalization (Etype (Subp)) then - if not Is_Inherently_Limited_Type (Etype (Subp)) + if not Is_Immutably_Limited_Type (Etype (Subp)) and then (No (First_Formal (Subp)) or else @@ -4405,7 +4405,7 @@ package body Exp_Ch6 is then null; - elsif Is_Inherently_Limited_Type (Typ) then + elsif Is_Immutably_Limited_Type (Typ) then Set_Returns_By_Ref (Spec_Id); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then @@ -4810,7 +4810,7 @@ package body Exp_Ch6 is -- may return objects of nonlimited descendants. else - return Is_Inherently_Limited_Type (Etype (E)) + return Is_Immutably_Limited_Type (Etype (E)) and then Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L; end if; @@ -5025,7 +5025,7 @@ package body Exp_Ch6 is Typ : constant Entity_Id := Etype (Subp); Utyp : constant Entity_Id := Underlying_Type (Typ); begin - if Is_Inherently_Limited_Type (Typ) then + if Is_Immutably_Limited_Type (Typ) then Set_Returns_By_Ref (Subp); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Subp); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index c299dc17f12..2b7d901789b 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -392,7 +392,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); - if not Is_Inherently_Limited_Type (Typ) then + if not Is_Immutably_Limited_Type (Typ) then Set_TSS (Typ, Make_Deep_Proc ( Prim => Adjust_Case, @@ -502,7 +502,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); - if not Is_Inherently_Limited_Type (Typ) then + if not Is_Immutably_Limited_Type (Typ) then Set_TSS (Typ, Make_Deep_Proc ( Prim => Adjust_Case, @@ -2725,7 +2725,7 @@ package body Exp_Ch7 is Res : constant List_Id := New_List; begin - if Is_Inherently_Limited_Type (Typ) then + if Is_Immutably_Limited_Type (Typ) then Controller_Typ := RTE (RE_Limited_Record_Controller); else Controller_Typ := RTE (RE_Record_Controller); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 45913579be7..8a487162b07 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5028,7 +5028,7 @@ package body Exp_Util is -- to accommodate functions returning limited objects by reference. if Nkind (Exp) = N_Function_Call - and then Is_Inherently_Limited_Type (Etype (Exp)) + and then Is_Immutably_Limited_Type (Etype (Exp)) and then Nkind (Parent (Exp)) /= N_Object_Declaration and then Ada_Version >= Ada_05 then diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 721528828c4..8e6f458907a 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1913,19 +1913,20 @@ ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch6.adb \ - ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/exp_aggr.ads ada/exp_atag.ads ada/exp_cg.ads ada/exp_ch11.ads \ + ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads \ + ada/exp_ch6.adb ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_dbug.ads \ + ada/exp_disp.ads ada/exp_disp.adb ada/exp_dist.ads ada/exp_intr.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/layout.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ + ada/scil_ll.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch12.ads \ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 99bec9b72da..c1a41cee0ea 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -570,24 +570,49 @@ package body Sem_Aux is end if; end Is_Indefinite_Subtype; - -------------------------------- - -- Is_Inherently_Limited_Type -- - -------------------------------- + ------------------------------- + -- Is_Immutably_Limited_Type -- + ------------------------------- - function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is + function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is Btype : constant Entity_Id := Base_Type (Ent); begin - if Is_Private_Type (Btype) then - declare - Utyp : constant Entity_Id := Underlying_Type (Btype); - begin - if No (Utyp) then + if Ekind (Btype) = E_Limited_Private_Type then + if Nkind (Parent (Btype)) = N_Formal_Type_Declaration then + return not In_Package_Body (Scope ((Btype))); + else + return True; + end if; + + elsif Is_Private_Type (Btype) then + -- AI05-0063 : a type derived from a limited private formal type + -- is not immutably limited in a generic body. + + if Is_Derived_Type (Btype) + and then Is_Generic_Type (Etype (Btype)) + then + if not Is_Limited_Type (Etype (Btype)) then return False; + + elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then + return not In_Package_Body (Scope (Etype (Btype))); + else - return Is_Inherently_Limited_Type (Utyp); + return False; end if; - end; + + else + declare + Utyp : constant Entity_Id := Underlying_Type (Btype); + begin + if No (Utyp) then + return False; + else + return Is_Immutably_Limited_Type (Utyp); + end if; + end; + end if; elsif Is_Concurrent_Type (Btype) then return True; @@ -605,7 +630,7 @@ package body Sem_Aux is return True; elsif Is_Class_Wide_Type (Btype) then - return Is_Inherently_Limited_Type (Root_Type (Btype)); + return Is_Immutably_Limited_Type (Root_Type (Btype)); else declare @@ -622,7 +647,7 @@ package body Sem_Aux is -- limited intefaces. if not Is_Interface (Etype (C)) - and then Is_Inherently_Limited_Type (Etype (C)) + and then Is_Immutably_Limited_Type (Etype (C)) then return True; end if; @@ -635,12 +660,12 @@ package body Sem_Aux is end if; elsif Is_Array_Type (Btype) then - return Is_Inherently_Limited_Type (Component_Type (Btype)); + return Is_Immutably_Limited_Type (Component_Type (Btype)); else return False; end if; - end Is_Inherently_Limited_Type; + end Is_Immutably_Limited_Type; --------------------- -- Is_Limited_Type -- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 490f8e3d5d4..133788ea07d 100755 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -165,7 +165,7 @@ package Sem_Aux is -- discriminant values or a class wide type or subtype and returns True if -- so. False for other type entities, or any entities that are not types. - function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean; + function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean; -- Ent is any entity. True for a type that is "inherently" limited (i.e. -- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with -- a part that is of a task, protected, or explicitly limited record type". diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 3a4eecf9ec3..d8491bac712 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8794,12 +8794,11 @@ package body Sem_Ch3 is -- only in the declaration for a task or protected type, or for a type -- with the reserved word 'limited' in its definition or in one of its -- ancestors. (RM 3.7(10)) + -- AI-0063 : the proper condition is that type must be immutably + -- limited. if Nkind (Discriminant_Type (D)) = N_Access_Definition - and then not Is_Concurrent_Type (Current_Scope) - and then not Is_Concurrent_Record_Type (Current_Scope) - and then not Is_Limited_Record (Current_Scope) - and then Ekind (Current_Scope) /= E_Limited_Private_Type + and then not Is_Immutably_Limited_Type (Current_Scope) then Error_Msg_N ("access discriminants allowed only for limited types", Loc); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 90e81f98b9a..5de59cb4c1d 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -483,7 +483,7 @@ package body Sem_Ch6 is Error_Msg_N ("(Ada 2005) cannot copy object of a limited type " & "(RM-2005 6.5(5.5/2))", Expr); - if Is_Inherently_Limited_Type (R_Type) then + if Is_Immutably_Limited_Type (R_Type) then Error_Msg_N ("\return by reference not permitted in Ada 2005", Expr); end if; @@ -495,7 +495,7 @@ package body Sem_Ch6 is -- evilly turned off. Otherwise it is a real error. elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then - if Is_Inherently_Limited_Type (R_Type) then + if Is_Immutably_Limited_Type (R_Type) then Error_Msg_N ("return by reference not permitted in Ada 2005 " & "(RM-2005 6.5(5.5/2))?", Expr); @@ -759,7 +759,7 @@ package body Sem_Ch6 is -- check the static cases. if (Ada_Version < Ada_05 or else Debug_Flag_Dot_L) - and then Is_Inherently_Limited_Type (Etype (Scope_Id)) + and then Is_Immutably_Limited_Type (Etype (Scope_Id)) and then Object_Access_Level (Expr) > Subprogram_Access_Level (Scope_Id) then @@ -4256,7 +4256,7 @@ package body Sem_Ch6 is Utyp : constant Entity_Id := Underlying_Type (Typ); begin - if Is_Inherently_Limited_Type (Typ) then + if Is_Immutably_Limited_Type (Typ) then Set_Returns_By_Ref (Designator); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index bd7e144a298..d10237125be 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1199,14 +1199,30 @@ package body Sem_Prag is end if; end Check_Component; + ---------------------------- + -- Check_Duplicate_Pragma -- + ---------------------------- + procedure Check_Duplicate_Pragma (E : Entity_Id) is - P : constant Node_Id := Get_Rep_Pragma (E, Pragma_Name (N)); + P : constant Node_Id := Get_Rep_Pragma (E, Pragma_Name (N)); + Arg : Node_Id; + begin if Present (P) then - Error_Msg_Name_1 := Pname; - Error_Msg_Sloc := Sloc (P); - Error_Msg_NE ("pragma% for & duplicates one#", N, E); - raise Pragma_Exit; + + -- Make sure pragma is for this entity, and not for some parent + -- entity in the case of a derived type. + + Arg := Get_Pragma_Arg (First (Pragma_Argument_Associations (P))); + + if Nkind (Arg) = N_Identifier + and then Entity (Arg) = E + then + Error_Msg_Name_1 := Pname; + Error_Msg_Sloc := Sloc (P); + Error_Msg_NE ("pragma% for & duplicates one#", N, E); + raise Pragma_Exit; + end if; end if; end Check_Duplicate_Pragma; |