-- Returns true if Prim is not a predefined dispatching primitive but it is
-- an alias of a predefined dispatching primitive (i.e. through a renaming)
+ function New_Value (From : Node_Id) return Node_Id;
+ -- From is the original Expression. New_Value is equivalent to a call
+ -- to Duplicate_Subexpr with an explicit dereference when From is an
+ -- access parameter.
+
function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
-- Check if the type has a private view or if the public view appears
-- in the visible part of a package spec.
-- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
-- to an RE_Tagged_Kind enumeration value.
+ ----------------------
+ -- Apply_Tag_Checks --
+ ----------------------
+
+ procedure Apply_Tag_Checks (Call_Node : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Call_Node);
+ Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
+ Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
+ Param_List : constant List_Id := Parameter_Associations (Call_Node);
+
+ Subp : Entity_Id;
+ CW_Typ : Entity_Id;
+ Param : Node_Id;
+ Typ : Entity_Id;
+ Eq_Prim_Op : Entity_Id := Empty;
+
+ begin
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("tagged types", Call_Node);
+ return;
+ end if;
+
+ -- Apply_Tag_Checks is called directly from the semantics, so we need
+ -- a check to see whether expansion is active before proceeding. In
+ -- addition, there is no need to expand the call when compiling under
+ -- restriction No_Dispatching_Calls; the semantic analyzer has
+ -- previously notified the violation of this restriction.
+
+ if not Expander_Active
+ or else Restriction_Active (No_Dispatching_Calls)
+ then
+ return;
+ end if;
+
+ -- Set subprogram. If this is an inherited operation that was
+ -- overridden, the body that is being called is its alias.
+
+ Subp := Entity (Name (Call_Node));
+
+ if Present (Alias (Subp))
+ and then Is_Inherited_Operation (Subp)
+ and then No (DTC_Entity (Subp))
+ then
+ Subp := Alias (Subp);
+ end if;
+
+ -- Definition of the class-wide type and the tagged type
+
+ -- If the controlling argument is itself a tag rather than a tagged
+ -- object, then use the class-wide type associated with the subprogram's
+ -- controlling type. This case can occur when a call to an inherited
+ -- primitive has an actual that originated from a default parameter
+ -- given by a tag-indeterminate call and when there is no other
+ -- controlling argument providing the tag (AI-239 requires dispatching).
+ -- This capability of dispatching directly by tag is also needed by the
+ -- implementation of AI-260 (for the generic dispatching constructors).
+
+ if Ctrl_Typ = RTE (RE_Tag)
+ or else (RTE_Available (RE_Interface_Tag)
+ and then Ctrl_Typ = RTE (RE_Interface_Tag))
+ then
+ CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
+
+ -- Class_Wide_Type is applied to the expressions used to initialize
+ -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
+ -- there are cases where the controlling type is resolved to a specific
+ -- type (such as for designated types of arguments such as CW'Access).
+
+ elsif Is_Access_Type (Ctrl_Typ) then
+ CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
+
+ else
+ CW_Typ := Class_Wide_Type (Ctrl_Typ);
+ end if;
+
+ Typ := Root_Type (CW_Typ);
+
+ if Ekind (Typ) = E_Incomplete_Type then
+ Typ := Non_Limited_View (Typ);
+ end if;
+
+ if not Is_Limited_Type (Typ) then
+ Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
+ end if;
+
+ -- Dispatching call to C++ primitive
+
+ if Is_CPP_Class (Typ) then
+ null;
+
+ -- Dispatching call to Ada primitive
+
+ elsif Present (Param_List) then
+
+ -- Generate the Tag checks when appropriate
+
+ Param := First_Actual (Call_Node);
+ while Present (Param) loop
+
+ -- No tag check with itself
+
+ if Param = Ctrl_Arg then
+ null;
+
+ -- No tag check for parameter whose type is neither tagged nor
+ -- access to tagged (for access parameters)
+
+ elsif No (Find_Controlling_Arg (Param)) then
+ null;
+
+ -- No tag check for function dispatching on result if the
+ -- Tag given by the context is this one
+
+ elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
+ null;
+
+ -- "=" is the only dispatching operation allowed to get
+ -- operands with incompatible tags (it just returns false).
+ -- We use Duplicate_Subexpr_Move_Checks instead of calling
+ -- Relocate_Node because the value will be duplicated to
+ -- check the tags.
+
+ elsif Subp = Eq_Prim_Op then
+ null;
+
+ -- No check in presence of suppress flags
+
+ elsif Tag_Checks_Suppressed (Etype (Param))
+ or else (Is_Access_Type (Etype (Param))
+ and then Tag_Checks_Suppressed
+ (Designated_Type (Etype (Param))))
+ then
+ null;
+
+ -- Optimization: no tag checks if the parameters are identical
+
+ elsif Is_Entity_Name (Param)
+ and then Is_Entity_Name (Ctrl_Arg)
+ and then Entity (Param) = Entity (Ctrl_Arg)
+ then
+ null;
+
+ -- Now we need to generate the Tag check
+
+ else
+ -- Generate code for tag equality check
+ -- Perhaps should have Checks.Apply_Tag_Equality_Check???
+
+ Insert_Action (Ctrl_Arg,
+ Make_Implicit_If_Statement (Call_Node,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Value (Ctrl_Arg),
+ Selector_Name =>
+ New_Reference_To
+ (First_Tag_Component (Typ), Loc)),
+
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Typ, New_Value (Param)),
+ Selector_Name =>
+ New_Reference_To
+ (First_Tag_Component (Typ), Loc))),
+
+ Then_Statements =>
+ New_List (New_Constraint_Error (Loc))));
+ end if;
+
+ Next_Actual (Param);
+ end loop;
+ end if;
+ end Apply_Tag_Checks;
+
------------------------
-- Building_Static_DT --
------------------------
-- Dispatching call to C++ primitive. Create a new parameter list
-- with no tag checks.
+ New_Params := New_List;
+
if Is_CPP_Class (Typ) then
- New_Params := New_List;
Param := First_Actual (Call_Node);
while Present (Param) loop
Append_To (New_Params, Relocate_Node (Param));
-- Dispatching call to Ada primitive
elsif Present (Param_List) then
+ Apply_Tag_Checks (Call_Node);
- -- Generate the Tag checks when appropriate
-
- New_Params := New_List;
Param := First_Actual (Call_Node);
while Present (Param) loop
+ -- Cases in which we may have generated runtime checks
- -- No tag check with itself
-
- if Param = Ctrl_Arg then
- Append_To (New_Params,
- Duplicate_Subexpr_Move_Checks (Param));
-
- -- No tag check for parameter whose type is neither tagged nor
- -- access to tagged (for access parameters)
-
- elsif No (Find_Controlling_Arg (Param)) then
- Append_To (New_Params, Relocate_Node (Param));
-
- -- No tag check for function dispatching on result if the
- -- Tag given by the context is this one
-
- elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
- Append_To (New_Params, Relocate_Node (Param));
-
- -- "=" is the only dispatching operation allowed to get
- -- operands with incompatible tags (it just returns false).
- -- We use Duplicate_Subexpr_Move_Checks instead of calling
- -- Relocate_Node because the value will be duplicated to
- -- check the tags.
-
- elsif Subp = Eq_Prim_Op then
+ if Param = Ctrl_Arg
+ or else Subp = Eq_Prim_Op
+ then
Append_To (New_Params,
Duplicate_Subexpr_Move_Checks (Param));
- -- No check in presence of suppress flags
-
- elsif Tag_Checks_Suppressed (Etype (Param))
- or else (Is_Access_Type (Etype (Param))
- and then Tag_Checks_Suppressed
- (Designated_Type (Etype (Param))))
- then
- Append_To (New_Params, Relocate_Node (Param));
-
- -- Optimization: no tag checks if the parameters are identical
-
- elsif Is_Entity_Name (Param)
- and then Is_Entity_Name (Ctrl_Arg)
- and then Entity (Param) = Entity (Ctrl_Arg)
- then
- Append_To (New_Params, Relocate_Node (Param));
-
- -- Now we need to generate the Tag check
-
else
- -- Generate code for tag equality check
- -- Perhaps should have Checks.Apply_Tag_Equality_Check???
-
- Insert_Action (Ctrl_Arg,
- Make_Implicit_If_Statement (Call_Node,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => New_Value (Ctrl_Arg),
- Selector_Name =>
- New_Reference_To
- (First_Tag_Component (Typ), Loc)),
-
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (Typ, New_Value (Param)),
- Selector_Name =>
- New_Reference_To
- (First_Tag_Component (Typ), Loc))),
-
- Then_Statements =>
- New_List (New_Constraint_Error (Loc))));
-
Append_To (New_Params, Relocate_Node (Param));
end if;
return Result;
end Make_Tags;
+ ---------------
+ -- New_Value --
+ ---------------
+
+ function New_Value (From : Node_Id) return Node_Id is
+ Res : constant Node_Id := Duplicate_Subexpr (From);
+ begin
+ if Is_Access_Type (Etype (From)) then
+ return Make_Explicit_Dereference (Sloc (From),
+ Prefix => Res);
+ else
+ return Res;
+ end if;
+ end New_Value;
+
-----------------------------------
-- Original_View_In_Visible_Part --
-----------------------------------
OSDN Git Service
