-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
(Tagged_Type : Entity_Id;
Prev_Op : Entity_Id;
New_Op : Entity_Id);
- -- Replace an implicit dispatching operation with an explicit one.
+ -- Replace an implicit dispatching operation with an explicit one.
-- Prev_Op is an inherited primitive operation which is overridden
-- by the explicit declaration of New_Op.
("operation can be dispatching in only one type", Subp);
end if;
- -- Verify that the restriction in E.2.2 (1) is obeyed.
+ -- Verify that the restriction in E.2.2 (14) is obeyed
elsif Remote
and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type
and then not Is_Abstract (Alias (Func))
and then No (DTC_Entity (Func))
then
- -- private overriding of inherited abstract operation,
- -- call is legal
+ -- Private overriding of inherited abstract operation,
+ -- call is legal.
Set_Entity (Name (N), Alias (Func));
return;
if not Is_Controlling_Actual (Actual) then
null; -- can be anything
- elsif (Is_Dynamically_Tagged (Actual)) then
+ elsif Is_Dynamically_Tagged (Actual) then
null; -- valid parameter
elsif Is_Tag_Indeterminate (Actual) then
-- inherited private subprograms are treated as dispatching, even
-- if the associated tagged type is already frozen.
- Has_Dispatching_Parent := Present (Alias (Subp))
- and then Is_Dispatching_Operation (Alias (Subp));
+ Has_Dispatching_Parent :=
+ Present (Alias (Subp))
+ and then Is_Dispatching_Operation (Alias (Subp));
if No (Tagged_Type) then
return;
then
declare
Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
- Decl_Item : Node_Id := Next (Parent (Tagged_Type));
+ Decl_Item : Node_Id := Next (Parent (Tagged_Type));
begin
-- ??? The checks here for whether the type has been
elsif Is_Frozen (Subp) then
- -- the subprogram body declares a primitive operation.
+ -- The subprogram body declares a primitive operation.
-- if the subprogram is already frozen, we must update
-- its dispatching information explicitly here. The
-- information is taken from the overridden subprogram.
if Present (Old_Subp) then
Check_Subtype_Conformant (Subp, Old_Subp);
Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
-
+ Set_Is_Overriding_Operation (Subp);
else
Add_Dispatching_Operation (Tagged_Type, Subp);
end if;
or else Chars (Subp) = Name_Finalize)
then
declare
- F_Node : Node_Id := Freeze_Node (Tagged_Type);
+ F_Node : constant Node_Id := Freeze_Node (Tagged_Type);
Decl : Node_Id;
Old_P : Entity_Id;
Old_Bod : Node_Id;
Name_Adjust,
Name_Finalize);
- D_Names : constant array (1 .. 3) of Name_Id :=
- (Name_uDeep_Initialize,
- Name_uDeep_Adjust,
- Name_uDeep_Finalize);
+ D_Names : constant array (1 .. 3) of TSS_Name_Type :=
+ (TSS_Deep_Initialize,
+ TSS_Deep_Adjust,
+ TSS_Deep_Finalize);
begin
-- Remove previous controlled function, which was constructed
-- and analyzed when the type was frozen. This requires
- -- removing the body of the redefined primitive, as well as its
- -- specification if needed (there is no spec created for
+ -- removing the body of the redefined primitive, as well as
+ -- its specification if needed (there is no spec created for
-- Deep_Initialize, see exp_ch3.adb). We must also dismantle
- -- the exception information that may have been generated for it
- -- when zero-cost is enabled.
+ -- the exception information that may have been generated for
+ -- it when front end zero-cost tables are enabled.
for J in D_Names'Range loop
Old_P := TSS (Tagged_Type, D_Names (J));
Old_Spec := Corresponding_Spec (Old_Bod);
Set_Has_Completion (Old_Spec, False);
- if Exception_Mechanism = Front_End_ZCX then
+ if Exception_Mechanism = Front_End_ZCX_Exceptions then
Set_Has_Subprogram_Descriptor (Old_Spec, False);
Set_Handler_Records (Old_Spec, No_List);
Set_Is_Eliminated (Old_Spec);
Next_Elmt (Op2);
end loop;
- -- Operation is a new primitive.
+ -- Operation is a new primitive
Append_Elmt (Subp, New_Prim);
-
end Check_Operation_From_Incomplete_Type;
---------------------------------------
-- dispatching attributes here.
if not Is_Dispatching_Operation (Old_Subp) then
+
+ -- If the untagged type has no discriminants, and the full
+ -- view is constrained, there will be a spurious mismatch
+ -- of subtypes on the controlling arguments, because the tagged
+ -- type is the internal base type introduced in the derivation.
+ -- Use the original type to verify conformance, rather than the
+ -- base type.
+
+ if not Comes_From_Source (Tagged_Type)
+ and then Has_Discriminants (Tagged_Type)
+ then
+ declare
+ Formal : Entity_Id;
+ begin
+ Formal := First_Formal (Old_Subp);
+ while Present (Formal) loop
+ if Tagged_Type = Base_Type (Etype (Formal)) then
+ Tagged_Type := Etype (Formal);
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end;
+
+ if Tagged_Type = Base_Type (Etype (Old_Subp)) then
+ Tagged_Type := Etype (Old_Subp);
+ end if;
+ end if;
+
Check_Controlling_Formals (Tagged_Type, Old_Subp);
Set_Is_Dispatching_Operation (Old_Subp, True);
Set_DT_Position (Old_Subp, No_Uint);
Set_Alias (Old_Subp, Alias (Subp));
-- The derived subprogram should inherit the abstractness
+
-- of the parent subprogram (except in the case of a function
-- returning the type). This sets the abstractness properly
-- for cases where a private extension may have inherited
-- Normal case
- elsif Is_Controlling_Actual (N) then
+ elsif Is_Controlling_Actual (N)
+ or else
+ (Nkind (Parent (N)) = N_Qualified_Expression
+ and then Is_Controlling_Actual (Parent (N)))
+ then
Typ := Etype (N);
if Is_Access_Type (Typ) then
end if;
end if;
- if Is_Class_Wide_Type (Typ) then
+ if Is_Class_Wide_Type (Typ)
+ or else
+ (Nkind (Parent (N)) = N_Qualified_Expression
+ and then Is_Access_Type (Etype (N))
+ and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
+ then
return N;
end if;
end if;
if not Has_Controlling_Result (Nam) then
return False;
+ -- An explicit dereference means that the call has already been
+ -- expanded and there is no tag to propagate.
+
+ elsif Nkind (N) = N_Explicit_Dereference then
+ return False;
+
-- If there are no actuals, the call is tag-indeterminate
elsif No (Parameter_Associations (Orig_Node)) then
Prev_Op : Entity_Id;
New_Op : Entity_Id)
is
- Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
+ Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
begin
-- Patch the primitive operation list
projects / thirdparty / gcc.git / blobdiff