diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 12 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 64 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 24 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 67 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 2 |
6 files changed, 117 insertions, 80 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fd598d4..3174cf1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2015-05-22 Bob Duff <duff@adacore.com> + + * exp_utils.ads, exp_utils.adb (Find_Optional_Prim_Op): New + interface to return Empty when not found, so we can avoid handling + Program_Error in that case. + (Find_Prim_Op): Fix latent bug: raise Program_Error when there are no + primitives. + * exp_ch7.adb, sem_util.adb: Use Find_Optional_Prim_Op when the + code is expecting Empty. + * sem_ch8.adb: Use Find_Optional_Prim_Op to avoid handling + Program_Error. + 2015-05-22 Robert Dewar <dewar@adacore.com> * sem_ch3.adb, sem_intr.adb, exp_ch4.adb, s-rannum.adb, diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 5c78bf8..661809c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2406,7 +2406,7 @@ package body Exp_Ch7 is -- Primitive Initialize if Is_Controlled (Typ) then - Prim_Init := Find_Prim_Op (Typ, Name_Initialize); + Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize); if Present (Prim_Init) then Prim_Init := Ultimate_Alias (Prim_Init); @@ -3671,7 +3671,7 @@ package body Exp_Ch7 is -- is from a private type that is not visibly controlled. Parent_Type := Etype (Typ); - Op := Find_Prim_Op (Parent_Type, Name_Of (Prim)); + Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim)); if Present (Op) then E := Op; @@ -5104,7 +5104,7 @@ package body Exp_Ch7 is if Skip_Self then if Has_Controlled_Component (Utyp) then if Is_Tagged_Type (Utyp) then - Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust); + Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); else Adj_Id := TSS (Utyp, TSS_Deep_Adjust); end if; @@ -5117,7 +5117,7 @@ package body Exp_Ch7 is or else Has_Controlled_Component (Utyp) then if Is_Tagged_Type (Utyp) then - Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust); + Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); else Adj_Id := TSS (Utyp, TSS_Deep_Adjust); end if; @@ -5126,15 +5126,15 @@ package body Exp_Ch7 is elsif Is_Controlled (Utyp) then if Has_Controlled_Component (Utyp) then - Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust); + Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); else - Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case)); + Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case)); end if; -- Tagged types elsif Is_Tagged_Type (Utyp) then - Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust); + Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); else raise Program_Error; @@ -6491,7 +6491,7 @@ package body Exp_Ch7 is Proc : Entity_Id; begin - Proc := Find_Prim_Op (Typ, Name_Adjust); + Proc := Find_Optional_Prim_Op (Typ, Name_Adjust); -- Generate: -- if F then @@ -7065,7 +7065,7 @@ package body Exp_Ch7 is Proc : Entity_Id; begin - Proc := Find_Prim_Op (Typ, Name_Finalize); + Proc := Find_Optional_Prim_Op (Typ, Name_Finalize); -- Generate: -- if F then @@ -7336,7 +7336,7 @@ package body Exp_Ch7 is if Skip_Self then if Has_Controlled_Component (Utyp) then if Is_Tagged_Type (Utyp) then - Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize); + Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); else Fin_Id := TSS (Utyp, TSS_Deep_Finalize); end if; @@ -7349,7 +7349,7 @@ package body Exp_Ch7 is or else Has_Controlled_Component (Utyp) then if Is_Tagged_Type (Utyp) then - Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize); + Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); else Fin_Id := TSS (Utyp, TSS_Deep_Finalize); end if; @@ -7358,15 +7358,15 @@ package body Exp_Ch7 is elsif Is_Controlled (Utyp) then if Has_Controlled_Component (Utyp) then - Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize); + Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); else - Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case)); + Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case)); end if; -- Tagged types elsif Is_Tagged_Type (Utyp) then - Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize); + Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); else raise Program_Error; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index ccb594b..2aa6e97 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2624,11 +2624,13 @@ package body Exp_Util is end if; end Find_Interface_Tag; - ------------------ - -- Find_Prim_Op -- - ------------------ + --------------------------- + -- Find_Optional_Prim_Op -- + --------------------------- - function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is + function Find_Optional_Prim_Op + (T : Entity_Id; Name : Name_Id) return Entity_Id + is Prim : Elmt_Id; Typ : Entity_Id := T; Op : Entity_Id; @@ -2657,25 +2659,16 @@ package body Exp_Util is or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op))); Next_Elmt (Prim); - - -- Raise Program_Error if no primitive found. ???This doesn't work as - -- advertised if there are no primitives. But fixing that breaks - -- Is_Init_Proc_Of in Exp_Ch7, which is expecting Empty in some - -- cases. - - if No (Prim) then - raise Program_Error; - end if; end loop; - return Node (Prim); - end Find_Prim_Op; + return Node (Prim); -- Empty if not found + end Find_Optional_Prim_Op; - ------------------ - -- Find_Prim_Op -- - ------------------ + --------------------------- + -- Find_Optional_Prim_Op -- + --------------------------- - function Find_Prim_Op + function Find_Optional_Prim_Op (T : Entity_Id; Name : TSS_Name_Type) return Entity_Id is @@ -2715,8 +2708,41 @@ package body Exp_Util is elsif Present (Inher_Op) then return Inher_Op; else + return Empty; + end if; + end Find_Optional_Prim_Op; + + ------------------ + -- Find_Prim_Op -- + ------------------ + + function Find_Prim_Op + (T : Entity_Id; Name : Name_Id) return Entity_Id + is + Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name); + begin + if No (Result) then raise Program_Error; end if; + + return Result; + end Find_Prim_Op; + + ------------------ + -- Find_Prim_Op -- + ------------------ + + function Find_Prim_Op + (T : Entity_Id; + Name : TSS_Name_Type) return Entity_Id + is + Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name); + begin + if No (Result) then + raise Program_Error; + end if; + + return Result; end Find_Prim_Op; ---------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index a7d8f4c..01f4377 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -471,9 +471,8 @@ package Exp_Util is -- Find the first primitive operation of a tagged type T with name Name. -- This function allows the use of a primitive operation which is not -- directly visible. If T is a class wide type, then the reference is to an - -- operation of the corresponding root type. Raises Program_Error exception - -- if no primitive operation is found. This is normally an internal error, - -- but in some cases is an expected consequence of illegalities elsewhere. + -- operation of the corresponding root type. It is an error if no primitive + -- operation with the given name is found. function Find_Prim_Op (T : Entity_Id; @@ -483,16 +482,19 @@ package Exp_Util is -- with the indicated suffix). This function allows use of a primitive -- operation which is not directly visible. If T is a class wide type, -- then the reference is to an operation of the corresponding root type. - -- Raises Program_Error exception if no primitive operation is found. - -- This is normally an internal error, but in some cases is an expected - -- consequence of illegalities elsewhere. + + function Find_Optional_Prim_Op + (T : Entity_Id; Name : Name_Id) return Entity_Id; + function Find_Optional_Prim_Op + (T : Entity_Id; + Name : TSS_Name_Type) return Entity_Id; + -- Same as Find_Prim_Op, except returns Empty if not found function Find_Protection_Object (Scop : Entity_Id) return Entity_Id; - -- Traverse the scope stack starting from Scop and look for an entry, - -- entry family, or a subprogram that has a Protection_Object and return - -- it. Raises Program_Error if no such entity is found since the context - -- in which this routine is invoked should always have a protection - -- object. + -- Traverse the scope stack starting from Scop and look for an entry, entry + -- family, or a subprogram that has a Protection_Object and return it. Must + -- always return a value since the context in which this routine is invoked + -- should always have a protection object. function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id; -- Given a protected type or its corresponding record, find the type of diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index c1c40bc..d3784f8 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -2639,45 +2639,42 @@ package body Sem_Ch8 is -- an abstract formal subprogram must be dispatching -- operation). - begin - case Attribute_Name (Nam) is - when Name_Input => - Stream_Prim := - Find_Prim_Op (Prefix_Type, TSS_Stream_Input); - when Name_Output => - Stream_Prim := - Find_Prim_Op (Prefix_Type, TSS_Stream_Output); - when Name_Read => - Stream_Prim := - Find_Prim_Op (Prefix_Type, TSS_Stream_Read); - when Name_Write => - Stream_Prim := - Find_Prim_Op (Prefix_Type, TSS_Stream_Write); - when others => - Error_Msg_N - ("attribute must be a primitive" - & " dispatching operation", Nam); - return; - end case; - - exception + case Attribute_Name (Nam) is + when Name_Input => + Stream_Prim := + Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Input); + when Name_Output => + Stream_Prim := + Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Output); + when Name_Read => + Stream_Prim := + Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Read); + when Name_Write => + Stream_Prim := + Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Write); + when others => + Error_Msg_N + ("attribute must be a primitive" + & " dispatching operation", Nam); + return; + end case; - -- If no operation was found, and the type is limited, - -- the user should have defined one. + -- If no operation was found, and the type is limited, + -- the user should have defined one. - when Program_Error => - if Is_Limited_Type (Prefix_Type) then - Error_Msg_NE - ("stream operation not defined for type&", - N, Prefix_Type); - return; + if No (Stream_Prim) then + if Is_Limited_Type (Prefix_Type) then + Error_Msg_NE + ("stream operation not defined for type&", + N, Prefix_Type); + return; - -- Otherwise, compiler should have generated default + -- Otherwise, compiler should have generated default - else - raise; - end if; - end; + else + raise Program_Error; + end if; + end if; -- Rewrite the attribute into the name of its corresponding -- primitive dispatching subprogram. We can then proceed with diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 716c2d8..d1f222e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11388,7 +11388,7 @@ package body Sem_Util is if Present (Utyp) then declare Init : constant Entity_Id := - (Find_Prim_Op + (Find_Optional_Prim_Op (Underlying_Type (Typ), Name_Initialize)); begin |