Skip to content

R
riscv-gcc-1
Commit ca811241 by Bob Duff Committed by Arnaud Charlet
Options

exp_utils.ads, [...] (Find_Optional_Prim_Op): New interface to return Empty when not found... 

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.

From-SVN: r223541
parent a95f708e
Showing with 117 additions and 80 deletions
gcc/ada/ChangeLog
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,
......
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;
......
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;
----------------------------
......
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
......
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
......
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment