From 8abe457acb2207a1d3b3d5e020c532780276dcdd Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 15 Apr 2008 11:02:58 +0000 Subject: [PATCH] [multiple changes] 2008-04-15 Ed Schonberg gcc/ada/ PR ada/16086 * sem_ch12.adb (Analyze_Formal_Subprogram): The default can be any protected operation that matches the signature, not only an entry, a regular subprogram or a literal. 2008-04-15 Samuel Tardieu gcc/testsuite/ PR ada/16086 * gnat.dg/prot_def.adb: New. From-SVN: r134312 --- gcc/ada/ChangeLog | 7 +++++ gcc/ada/sem_ch12.adb | 33 ++++++++++++++-------- gcc/testsuite/ChangeLog | 5 ++++ gcc/testsuite/gnat.dg/prot_def.adb | 44 ++++++++++++++++++++++++++++++ 4 files changed, 77 insertions(+), 12 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/prot_def.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d00479bb926..cec2e8cb2e5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2008-04-15 Ed Schonberg + + PR ada/16086 + * sem_ch12.adb (Analyze_Formal_Subprogram): The default can be any + protected operation that matches the signature, not only an entry, a + regular subprogram or a literal. + 2008-04-15 Eric Botcazou * ada-tree.h (DECL_BY_COMPONENT_PTR_P): Use DECL_LANG_FLAG_3. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index e7755c4f534..c44f3929d50 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2361,30 +2361,34 @@ package body Sem_Ch12 is -- Default name may be overloaded, in which case the interpretation -- with the correct profile must be selected, as for a renaming. + -- If the definition is an indexed component, it must denote a + -- member of an entry family. If it is a selected component, it + -- can be a protected operation. if Etype (Def) = Any_Type then return; elsif Nkind (Def) = N_Selected_Component then - Subp := Entity (Selector_Name (Def)); - - if Ekind (Subp) /= E_Entry then + if not Is_Overloadable (Entity (Selector_Name (Def))) then Error_Msg_N ("expect valid subprogram name as default", Def); - return; end if; elsif Nkind (Def) = N_Indexed_Component then - if Nkind (Prefix (Def)) /= N_Selected_Component then - Error_Msg_N ("expect valid subprogram name as default", Def); - return; - - else - Subp := Entity (Selector_Name (Prefix (Def))); + if Is_Entity_Name (Prefix (Def)) then + if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then + Error_Msg_N ("expect valid subprogram name as default", Def); + end if; - if Ekind (Subp) /= E_Entry_Family then + elsif Nkind (Prefix (Def)) = N_Selected_Component then + if Ekind (Entity (Selector_Name (Prefix (Def)))) + /= E_Entry_Family + then Error_Msg_N ("expect valid subprogram name as default", Def); - return; end if; + + else + Error_Msg_N ("expect valid subprogram name as default", Def); + return; end if; elsif Nkind (Def) = N_Character_Literal then @@ -2410,6 +2414,9 @@ package body Sem_Ch12 is end if; else + + -- Several interpretations. Disambiguate as for a renaming. + declare I : Interp_Index; I1 : Interp_Index := 0; @@ -9778,6 +9785,8 @@ package body Sem_Ch12 is -- interface then the generic formal is not unless declared -- explicitly so. If not declared limited, the actual cannot be -- limited (see AI05-0087). + -- Disable check for now, limited interfaces implemented by + -- protected types are common, Need to update tests ??? if Is_Limited_Type (Act_T) and then not Is_Limited_Type (A_Gen_T) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d87b121e885..e3350a80c8e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2008-04-15 Samuel Tardieu + + PR ada/16086 + * gnat.dg/prot_def.adb: New. + 2008-04-14 Ian Lance Taylor * gcc.dg/strict-overflow-6.c: New. diff --git a/gcc/testsuite/gnat.dg/prot_def.adb b/gcc/testsuite/gnat.dg/prot_def.adb new file mode 100644 index 00000000000..d56195ea483 --- /dev/null +++ b/gcc/testsuite/gnat.dg/prot_def.adb @@ -0,0 +1,44 @@ +-- { dg-do run } +procedure Prot_Def is + + protected Prot is + procedure Inc; + function Get return Integer; + private + Data : Integer := 0; + end Prot; + + protected body Prot is + procedure Inc is + begin + Data := Data + 1; + end Inc; + function Get return Integer is + begin + return Data; + end Get; + end Prot; + + generic + with procedure Inc is Prot.Inc; + with function Get return Integer is Prot.Get; + package Gen is + function Add2_Get return Integer; + end Gen; + + package body Gen is + function Add2_Get return Integer is + begin + Inc; + Inc; + return Get; + end Add2_Get; + end Gen; + + package Inst is new Gen; + +begin + if Inst.Add2_Get /= 2 then + raise Constraint_Error; + end if; +end Prot_Def; -- 2.30.2