+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,
-- 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);
-- 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;
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;
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;
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;
Proc : Entity_Id;
begin
- Proc := Find_Prim_Op (Typ, Name_Adjust);
+ Proc := Find_Optional_Prim_Op (Typ, Name_Adjust);
-- Generate:
-- if F then
Proc : Entity_Id;
begin
- Proc := Find_Prim_Op (Typ, Name_Finalize);
+ Proc := Find_Optional_Prim_Op (Typ, Name_Finalize);
-- Generate:
-- if F then
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;
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;
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;
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;
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
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;
----------------------------
-- 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;
-- 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
-- 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
if Present (Utyp) then
declare
Init : constant Entity_Id :=
- (Find_Prim_Op
+ (Find_Optional_Prim_Op
(Underlying_Type (Typ), Name_Initialize));
begin
projects / gcc.git / commitdiff