-- replaced by gotos which jump to the end of the routine and restore the
-- Ghost mode.
- function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
+ function Make_DT (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Max_Predef_Prims : constant Int :=
-- offset to the components that reference secondary dispatch tables.
-- Used to compute the offset of components located at fixed position.
- procedure Check_Premature_Freezing
- (Subp : Entity_Id;
- Tagged_Type : Entity_Id;
- Typ : Entity_Id);
- -- Verify that all untagged types in the profile of a subprogram are
- -- frozen at the point the subprogram is frozen. This enforces the rule
- -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
- -- is frozen, enough must be known about it to build the activation
- -- record for it, which requires at least that the size of all
- -- parameters be known. Controlling arguments are by-reference,
- -- and therefore the rule only applies to untagged types. Typical
- -- violation of the rule involves an object declaration that freezes a
- -- tagged type, when one of its primitive operations has a type in its
- -- profile whose full view has not been analyzed yet. More complex cases
- -- involve composite types that have one private unfrozen subcomponent.
- -- Move this check to sem???
-
procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
-- Export the dispatch table DT of tagged type Typ. Required to generate
-- forward references and statically allocate the table. For primary
function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat;
-- Returns the number of predefined primitives of Typ
- ------------------------------
- -- Check_Premature_Freezing --
- ------------------------------
-
- procedure Check_Premature_Freezing
- (Subp : Entity_Id;
- Tagged_Type : Entity_Id;
- Typ : Entity_Id)
- is
- Comp : Entity_Id;
-
- function Is_Actual_For_Formal_Incomplete_Type
- (T : Entity_Id) return Boolean;
- -- In Ada 2012, if a nested generic has an incomplete formal type,
- -- the actual may be (and usually is) a private type whose completion
- -- appears later. It is safe to build the dispatch table in this
- -- case, gigi will have full views available.
-
- ------------------------------------------
- -- Is_Actual_For_Formal_Incomplete_Type --
- ------------------------------------------
-
- function Is_Actual_For_Formal_Incomplete_Type
- (T : Entity_Id) return Boolean
- is
- Gen_Par : Entity_Id;
- F : Node_Id;
-
- begin
- if not Is_Generic_Instance (Current_Scope)
- or else not Used_As_Generic_Actual (T)
- then
- return False;
- else
- Gen_Par := Generic_Parent (Parent (Current_Scope));
- end if;
-
- F :=
- First
- (Generic_Formal_Declarations
- (Unit_Declaration_Node (Gen_Par)));
- while Present (F) loop
- if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
- return True;
- end if;
-
- Next (F);
- end loop;
-
- return False;
- end Is_Actual_For_Formal_Incomplete_Type;
-
- -- Start of processing for Check_Premature_Freezing
-
- begin
- -- Note that if the type is a (subtype of) a generic actual, the
- -- actual will have been frozen by the instantiation.
-
- if Present (N)
- and then Is_Private_Type (Typ)
- and then No (Full_View (Typ))
- and then not Has_Private_Declaration (Typ)
- and then not Is_Generic_Type (Typ)
- and then not Is_Tagged_Type (Typ)
- and then not Is_Frozen (Typ)
- and then not Is_Generic_Actual_Type (Typ)
- then
- Error_Msg_Sloc := Sloc (Subp);
- Error_Msg_NE
- ("declaration must appear after completion of type &", N, Typ);
- Error_Msg_NE
- ("\which is an untagged type in the profile of "
- & "primitive operation & declared#", N, Subp);
-
- else
- Comp := Private_Component (Typ);
-
- if not Is_Tagged_Type (Typ)
- and then Present (Comp)
- and then not Is_Frozen (Comp)
- and then not Has_Private_Declaration (Comp)
- and then not Is_Actual_For_Formal_Incomplete_Type (Comp)
- then
- Error_Msg_Sloc := Sloc (Subp);
- Error_Msg_NE
- ("declaration must appear after completion of type &",
- N, Comp);
- Error_Msg_Node_2 := Subp;
- Error_Msg_Name_1 := Chars (Tagged_Type);
- Error_Msg_NE
- ("\which is a component of untagged type& in the profile "
- & "of primitive & of type % that is frozen by the "
- & "declaration", N, Typ);
- end if;
- end if;
- end Check_Premature_Freezing;
-
---------------
-- Export_DT --
---------------
end if;
-- Ensure that all the primitives are frozen. This is only required when
- -- building static dispatch tables --- the primitives must be frozen to
- -- be referenced (otherwise we have problems with the backend). It is
+ -- building static dispatch tables: the primitives must be frozen to be
+ -- referenced, otherwise we have problems with the back end. But this is
-- not a requirement with nonstatic dispatch tables because in this case
- -- we generate now an empty dispatch table; the extra code required to
- -- register the primitives in the slots will be generated later --- when
- -- each primitive is frozen (see Freeze_Subprogram).
+ -- we generate an empty dispatch table at this point and the extra code
+ -- required to register the primitives in their slot will be generated
+ -- later, when each primitive is frozen (see Freeze_Subprogram).
if Building_Static_DT (Typ) then
declare
- Saved_FLLTT : constant Boolean :=
- Freezing_Library_Level_Tagged_Type;
-
- Formal : Entity_Id;
- Frnodes : List_Id;
+ F_List : List_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
begin
- Freezing_Library_Level_Tagged_Type := True;
-
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
- Frnodes := Freeze_Entity (Prim, Typ);
-
- -- We disable this check for abstract subprograms, given that
- -- they cannot be called directly and thus the state of their
- -- untagged formals is of no concern. The RM is unclear in any
- -- case concerning the need for this check, and this topic may
- -- go back to the ARG.
-
- if not Is_Abstract_Subprogram (Prim) then
- Formal := First_Formal (Prim);
- while Present (Formal) loop
- Check_Premature_Freezing (Prim, Typ, Etype (Formal));
- Next_Formal (Formal);
- end loop;
-
- Check_Premature_Freezing (Prim, Typ, Etype (Prim));
- end if;
+ Prim := Node (Prim_Elmt);
+ F_List := Freeze_Entity (Prim, Typ, Do_Freeze_Profile => False);
- if Present (Frnodes) then
- Append_List_To (Result, Frnodes);
+ if Present (F_List) then
+ Append_List_To (Result, F_List);
end if;
Next_Elmt (Prim_Elmt);
end loop;
-
- Freezing_Library_Level_Tagged_Type := Saved_FLLTT;
end;
end if;
-- Generate checks required on dispatching calls
function Building_Static_DT (Typ : Entity_Id) return Boolean;
- pragma Inline (Building_Static_DT);
-- Returns true when building statically allocated dispatch tables
function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean;
- pragma Inline (Building_Static_Secondary_DT);
-- Returns true when building statically allocated secondary dispatch
-- tables
function Convert_Tag_To_Interface
(Typ : Entity_Id; Expr : Node_Id) return Node_Id;
- pragma Inline (Convert_Tag_To_Interface);
-- This function is used in class-wide interface conversions; the expanded
-- code generated to convert a tagged object to a class-wide interface type
-- involves referencing the tag component containing the secondary dispatch
function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean;
-- Returns true if N is the expanded code of a dispatching call
- function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id;
- -- Expand the declarations for the Dispatch Table. The node N is the
- -- declaration that forces the generation of the table. It is used to place
- -- error messages when the declaration leads to the freezing of a given
- -- primitive operation that has an incomplete non- tagged formal.
+ function Make_DT (Typ : Entity_Id) return List_Id;
+ -- Expand the declarations for the Dispatch Table of Typ
function Make_Disp_Asynchronous_Select_Body
(Typ : Entity_Id) return Node_Id;
Result := No_List;
return False;
- elsif not After_Last_Declaration
- and then not Freezing_Library_Level_Tagged_Type
- then
+ elsif not After_Last_Declaration then
Error_Msg_NE
("type & must be fully defined before this point",
N,
if Is_Access_Type (F_Type) then
F_Type := Designated_Type (F_Type);
end if;
-
- -- If the formal is an anonymous_access_to_subprogram
- -- freeze the subprogram type as well, to prevent
- -- scope anomalies in gigi, because there is no other
- -- clear point at which it could be frozen.
-
- if Is_Itype (Etype (Formal))
- and then Ekind (F_Type) = E_Subprogram_Type
- then
- Freeze_And_Append (F_Type, N, Result);
- end if;
end if;
Next_Formal (Formal);
-- In Ada 2012, freezing a subprogram does not always freeze the
-- corresponding profile (see AI05-019). An attribute reference
- -- is not a freezing point of the profile. Flag Do_Freeze_Profile
+ -- is not a freezing point of the profile. Similarly, we do not
+ -- freeze the profile of primitives of a library-level tagged type
+ -- when we are building its dispatch table. Flag Do_Freeze_Profile
-- indicates whether the profile should be frozen now.
- -- Other constructs that should not freeze ???
-- This processing doesn't apply to internal entities (see below)