-- Otherwise, proceed with processing tagged conversion
declare
- Actual_Operand_Type : Entity_Id;
- Actual_Target_Type : Entity_Id;
+ Actual_Op_Typ : Entity_Id;
+ Actual_Targ_Typ : Entity_Id;
+ Make_Conversion : Boolean := False;
+ Root_Op_Typ : Entity_Id;
- Cond : Node_Id;
+ procedure Make_Tag_Check (Targ_Typ : Entity_Id);
+ -- Create a membership check to test whether Operand is a member
+ -- of Targ_Typ. If the original Target_Type is an access, include
+ -- a test for null value. The check is inserted at N.
+
+ --------------------
+ -- Make_Tag_Check --
+ --------------------
+
+ procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
+ Cond : Node_Id;
+
+ begin
+ -- Generate:
+ -- [Constraint_Error
+ -- when Operand /= null
+ -- and then Operand.all not in Targ_Typ]
+
+ if Is_Access_Type (Target_Type) then
+ Cond :=
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
+ Right_Opnd => Make_Null (Loc)),
+
+ Right_Opnd =>
+ Make_Not_In (Loc,
+ Left_Opnd =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => Duplicate_Subexpr_No_Checks (Operand)),
+ Right_Opnd => New_Reference_To (Targ_Typ, Loc)));
+
+ -- Generate:
+ -- [Constraint_Error when Operand not in Targ_Typ]
+
+ else
+ Cond :=
+ Make_Not_In (Loc,
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
+ Right_Opnd => New_Reference_To (Targ_Typ, Loc));
+ end if;
+
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition => Cond,
+ Reason => CE_Tag_Check_Failed));
+ end Make_Tag_Check;
+
+ -- Start of processing
begin
if Is_Access_Type (Target_Type) then
- Actual_Operand_Type := Designated_Type (Operand_Type);
- Actual_Target_Type := Designated_Type (Target_Type);
+ Actual_Op_Typ := Designated_Type (Operand_Type);
+ Actual_Targ_Typ := Designated_Type (Target_Type);
else
- Actual_Operand_Type := Operand_Type;
- Actual_Target_Type := Target_Type;
+ Actual_Op_Typ := Operand_Type;
+ Actual_Targ_Typ := Target_Type;
end if;
+ Root_Op_Typ := Root_Type (Actual_Op_Typ);
+
-- Ada 2005 (AI-251): Handle interface type conversion
- if Is_Interface (Actual_Operand_Type) then
+ if Is_Interface (Actual_Op_Typ) then
Expand_Interface_Conversion (N, Is_Static => False);
return;
end if;
- if Is_Class_Wide_Type (Actual_Operand_Type)
- and then Root_Type (Actual_Operand_Type) /= Actual_Target_Type
- and then Is_Ancestor
- (Root_Type (Actual_Operand_Type),
- Actual_Target_Type)
- and then not Tag_Checks_Suppressed (Actual_Target_Type)
- then
- -- Conversion is valid for any descendant of the target type
+ if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
- Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
+ -- Create a runtime tag check for a downward class-wide type
+ -- conversion.
- if Is_Access_Type (Target_Type) then
- Cond :=
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Ne (Loc,
- Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
- Right_Opnd => Make_Null (Loc)),
+ if Is_Class_Wide_Type (Actual_Op_Typ)
+ and then Root_Op_Typ /= Actual_Targ_Typ
+ and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ)
+ then
+ Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
+ Make_Conversion := True;
+ end if;
- Right_Opnd =>
- Make_Not_In (Loc,
- Left_Opnd =>
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Duplicate_Subexpr_No_Checks (Operand)),
- Right_Opnd =>
- New_Reference_To (Actual_Target_Type, Loc)));
+ -- AI05-0073: If the result subtype of the function is defined
+ -- by an access_definition designating a specific tagged type
+ -- T, a check is made that the result value is null or the tag
+ -- of the object designated by the result value identifies T.
+ -- Constraint_Error is raised if this check fails.
- else
- Cond :=
- Make_Not_In (Loc,
- Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
- Right_Opnd =>
- New_Reference_To (Actual_Target_Type, Loc));
+ if Nkind (Parent (N)) = Sinfo.N_Return_Statement then
+ declare
+ Func : Entity_Id := Current_Scope;
+ Func_Typ : Entity_Id;
+
+ begin
+ -- Climb the scope stack looking for the enclosing
+ -- function.
+
+ while Present (Func)
+ and then Ekind (Func) /= E_Function
+ loop
+ Func := Scope (Func);
+ end loop;
+
+ -- The function's return subtype must be defined using
+ -- an access definition.
+
+ if Nkind (Result_Definition (Parent (Func))) =
+ N_Access_Definition
+ then
+ Func_Typ := Directly_Designated_Type (Etype (Func));
+
+ -- The return subtype denotes a specific tagged type,
+ -- in other words, a non class-wide type.
+
+ if Is_Tagged_Type (Func_Typ)
+ and then not Is_Class_Wide_Type (Func_Typ)
+ then
+ Make_Tag_Check (Actual_Targ_Typ);
+ Make_Conversion := True;
+ end if;
+ end if;
+ end;
end if;
- Insert_Action (N,
- Make_Raise_Constraint_Error (Loc,
- Condition => Cond,
- Reason => CE_Tag_Check_Failed));
+ -- We have generated a tag check for either a class-wide type
+ -- conversion or for AI05-0073.
- declare
- Conv : Node_Id;
- begin
- Conv :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
- Expression => Relocate_Node (Expression (N)));
- Rewrite (N, Conv);
- Analyze_And_Resolve (N, Target_Type);
- end;
+ if Make_Conversion then
+ declare
+ Conv : Node_Id;
+ begin
+ Conv :=
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
+ Expression => Relocate_Node (Expression (N)));
+ Rewrite (N, Conv);
+ Analyze_And_Resolve (N, Target_Type);
+ end;
+ end if;
end if;
end;
projects / gcc.git / commitdiff