elsif Ekind (Id) in Incomplete_Or_Private_Kind then
-- If we have an incomplete or private type with a full view,
- -- then we return the Underlying_Type of this full view
+ -- then we return the Underlying_Type of this full view.
if Present (Full_View (Id)) then
if Id = Full_View (Id) then
return Underlying_Type (Full_View (Id));
end if;
+ -- If we have a private type with an underlying full view, then we
+ -- return the Underlying_Type of this underlying full view.
+
+ elsif Ekind (Id) in Private_Kind
+ and then Present (Underlying_Full_View (Id))
+ then
+ return Underlying_Type (Underlying_Full_View (Id));
+
-- If we have an incomplete entity that comes from the limited
-- view then we return the Underlying_Type of its non-limited
-- view.
-- view, we can retrieve the full view, but not the reverse).
-- However, in order to freeze correctly, we need to freeze the full
-- view. If we are freezing at the end of a scope (or within the
- -- scope of the private type), the partial and full views will have
+ -- scope) of the private type, the partial and full views will have
-- been swapped, the full view appears first in the entity chain and
-- the swapping mechanism ensures that the pointers are properly set
-- (on scope exit).
-- set the pointers appropriately since we cannot rely on swapping to
-- fix things up (subtypes in an outer scope might not get swapped).
+ -- If the full view is itself private, the above requirements apply
+ -- to the underlying full view instead of the full view. But there is
+ -- no swapping mechanism for the underlying full view so we need to
+ -- set the pointers appropriately in both cases.
+
elsif Is_Incomplete_Or_Private_Type (E)
and then not Is_Generic_Type (E)
then
if Is_Frozen (Full_View (E)) then
Set_Has_Delayed_Freeze (E, False);
Set_Freeze_Node (E, Empty);
- Check_Debug_Info_Needed (E);
-- Otherwise freeze full view and patch the pointers so that
- -- the freeze node will elaborate both views in the back-end.
+ -- the freeze node will elaborate both views in the back end.
+ -- However, if full view is itself private, freeze underlying
+ -- full view instead and patch the pointer so that the freeze
+ -- node will elaborate the three views in the back end.
else
declare
- Full : constant Entity_Id := Full_View (E);
+ Full : Entity_Id := Full_View (E);
begin
if Is_Private_Type (Full)
and then Present (Underlying_Full_View (Full))
then
- Freeze_And_Append
- (Underlying_Full_View (Full), N, Result);
+ Full := Underlying_Full_View (Full);
end if;
Freeze_And_Append (Full, N, Result);
- if Has_Delayed_Freeze (E) then
+ if Full /= Full_View (E)
+ and then Has_Delayed_Freeze (Full_View (E))
+ then
F_Node := Freeze_Node (Full);
if Present (F_Node) then
+ Set_Freeze_Node (Full_View (E), F_Node);
+ Set_Entity (F_Node, Full_View (E));
+
+ else
+ Set_Has_Delayed_Freeze (Full_View (E), False);
+ Set_Freeze_Node (Full_View (E), Empty);
+ end if;
+ end if;
+
+ if Has_Delayed_Freeze (E) then
+ F_Node := Freeze_Node (Full_View (E));
+
+ if Present (F_Node) then
Set_Freeze_Node (E, F_Node);
Set_Entity (F_Node, E);
end if;
end if;
end;
-
- Check_Debug_Info_Needed (E);
end if;
+ Check_Debug_Info_Needed (E);
+
-- AI-117 requires that the convention of a partial view be the
-- same as the convention of the full view. Note that this is a
-- recognized breach of privacy, but it's essential for logical
return Result;
+ -- Case of underlying full view present
+
+ elsif Is_Private_Type (E)
+ and then Present (Underlying_Full_View (E))
+ then
+ if not Is_Frozen (Underlying_Full_View (E)) then
+ Freeze_And_Append (Underlying_Full_View (E), N, Result);
+ end if;
+
+ -- Patch the pointers so that the freeze node will elaborate
+ -- both views in the back end.
+
+ if Has_Delayed_Freeze (E) then
+ F_Node := Freeze_Node (Underlying_Full_View (E));
+
+ if Present (F_Node) then
+ Set_Freeze_Node (E, F_Node);
+ Set_Entity (F_Node, E);
+
+ else
+ Set_Has_Delayed_Freeze (E, False);
+ Set_Freeze_Node (E, Empty);
+ end if;
+ end if;
+
+ Check_Debug_Info_Needed (E);
+
+ return Result;
+
-- Case of no full view present. If entity is derived or subtype,
-- it is safe to freeze, correctness depends on the frozen status
-- of parent. Otherwise it is either premature usage, or a Taft
? Non_Limited_View (gnat_entity)
: Present (Full_View (gnat_entity))
? Full_View (gnat_entity)
- : Underlying_Full_View (gnat_entity);
+ : IN (kind, Private_Kind)
+ ? Underlying_Full_View (gnat_entity)
+ : Empty;
/* If this is an incomplete type with no full view, it must be a Taft
Amendment type, in which case we return a dummy type. Otherwise,
if (gnu_old)
{
save_gnu_tree (gnat_entity, NULL_TREE, false);
+
if (IN (kind, Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_entity))
- && present_gnu_tree (Full_View (gnat_entity)))
- save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
+ && Present (Full_View (gnat_entity)))
+ {
+ Entity_Id full_view = Full_View (gnat_entity);
+
+ if (IN (Ekind (full_view), Private_Kind)
+ && Present (Underlying_Full_View (full_view)))
+ full_view = Underlying_Full_View (full_view);
+
+ if (present_gnu_tree (full_view))
+ save_gnu_tree (full_view, NULL_TREE, false);
+ }
+
if (IN (kind, Type_Kind)
&& Present (Class_Wide_Type (gnat_entity))
&& Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
if (IN (kind, Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_entity)))
{
- gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
+ Entity_Id full_view = Full_View (gnat_entity);
+
+ if (IN (Ekind (full_view), Private_Kind)
+ && Present (Underlying_Full_View (full_view)))
+ full_view = Underlying_Full_View (full_view);
+
+ gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, 1);
/* Propagate back-annotations from full view to partial view. */
if (Unknown_Alignment (gnat_entity))
- Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
+ Set_Alignment (gnat_entity, Alignment (full_view));
if (Unknown_Esize (gnat_entity))
- Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
+ Set_Esize (gnat_entity, Esize (full_view));
if (Unknown_RM_Size (gnat_entity))
- Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
+ Set_RM_Size (gnat_entity, RM_Size (full_view));
/* The above call may have defined this entity (the simplest example
of this is when we have a private enumeral type since the bounds
tree
make_dummy_type (Entity_Id gnat_type)
{
- Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type);
+ Entity_Id gnat_equiv = Gigi_Equivalent_Type (Underlying_Type (gnat_type));
tree gnu_type;
- /* If there is an equivalent type, get its underlying type. */
- if (Present (gnat_underlying))
- gnat_underlying = Gigi_Equivalent_Type (Underlying_Type (gnat_underlying));
-
/* If there was no equivalent type (can only happen when just annotating
types) or underlying type, go back to the original type. */
- if (No (gnat_underlying))
- gnat_underlying = gnat_type;
+ if (No (gnat_equiv))
+ gnat_equiv = gnat_type;
/* If it there already a dummy type, use that one. Else make one. */
- if (PRESENT_DUMMY_NODE (gnat_underlying))
- return GET_DUMMY_NODE (gnat_underlying);
+ if (PRESENT_DUMMY_NODE (gnat_equiv))
+ return GET_DUMMY_NODE (gnat_equiv);
/* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make
an ENUMERAL_TYPE. */
- gnu_type = make_node (Is_Record_Type (gnat_underlying)
- ? tree_code_for_record_type (gnat_underlying)
+ gnu_type = make_node (Is_Record_Type (gnat_equiv)
+ ? tree_code_for_record_type (gnat_equiv)
: ENUMERAL_TYPE);
TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
TYPE_DUMMY_P (gnu_type) = 1;
TYPE_STUB_DECL (gnu_type)
= create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type);
- if (Is_By_Reference_Type (gnat_underlying))
+ if (Is_By_Reference_Type (gnat_equiv))
TYPE_BY_REFERENCE_P (gnu_type) = 1;
- SET_DUMMY_NODE (gnat_underlying, gnu_type);
+ SET_DUMMY_NODE (gnat_equiv, gnu_type);
return gnu_type;
}
if Operating_Mode /= Check_Syntax then
-- Acquire target parameters from system.ads (package System source)
- -- System).
Targparm_Acquire : declare
use Sinput;
and then Entity (Identifier (Enclosing_Loop)) /= Loop_Id
then
Error_Attr_P
- ("prefix of attribute % that applies to "
- & "outer loop must denote an entity");
+ ("prefix of attribute % that applies to outer loop must denote "
+ & "an entity");
elsif Is_Potentially_Unevaluated (P) then
Uneval_Old_Msg;
end if;
- -- Finally, if the Loop_Entry attribute appears within a pragma
- -- that is ignored, we replace P'Loop_Entity by P to avoid useless
- -- generation of the loop entity variable. Note that in this case
- -- the expression won't be executed anyway, and this substitution
- -- keeps types happy!
-
- -- We should really do this in the expander, but it's easier here
+ -- Replace the Loop_Entry attribute reference by its prefix if the
+ -- related pragma is ignored. This transformation is OK with respect
+ -- to typing because Loop_Entry's type is that of its prefix. This
+ -- early transformation also avoids the generation of a useless loop
+ -- entry constant.
if Is_Ignored (Enclosing_Pragma) then
Rewrite (N, Relocate_Node (P));
end if;
+
+ Preanalyze_And_Resolve (P);
end Loop_Entry;
-------------
if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then
return;
+ -- Special casee message for character literal
+
elsif Exp_Btype = Any_Character then
Error_Msg_N
("character literal as case expression is ambiguous", Expr);
end if;
if Etype (N) = Any_Type and then Present (Wrong_Alt) then
- Error_Msg_N ("type incompatible with that of previous alternatives",
- Expression (Wrong_Alt));
+ Error_Msg_N
+ ("type incompatible with that of previous alternatives",
+ Expression (Wrong_Alt));
return;
end if;
then
Set_Condition (Parent (N), Empty);
- -- If the expression raising CE is a N_Raise_CE node, we can use that
- -- one. We just preserve the type of the context.
-
- elsif Nkind (Exp) = N_Raise_Constraint_Error then
- Rewrite (N, Exp);
- Set_Etype (N, Typ);
-
-- Else build an explicit N_Raise_CE
else
Pragma_Assume |
Pragma_Loop_Invariant =>
Assert : declare
- Expr : Node_Id;
- Newa : List_Id;
-
- Has_Loop_Entry : Boolean;
- -- Set True by
-
- function Contains_Loop_Entry return Boolean;
- -- Tests if Expr contains a Loop_Entry attribute reference
+ function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
+ -- Determine whether expression Expr contains a Loop_Entry
+ -- attribute reference.
-------------------------
-- Contains_Loop_Entry --
-------------------------
- function Contains_Loop_Entry return Boolean is
+ function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
+ Has_Loop_Entry : Boolean := False;
+
function Process (N : Node_Id) return Traverse_Result;
-- Process function for traversal to look for Loop_Entry
-- Start of processing for Contains_Loop_Entry
begin
- Has_Loop_Entry := False;
Traverse (Expr);
return Has_Loop_Entry;
end Contains_Loop_Entry;
+ -- Local variables
+
+ Expr : Node_Id;
+ Newa : List_Id;
+
-- Start of processing for Assert
begin
Check_Optional_Identifier (Arg1, Name_Check);
Expr := Get_Pragma_Arg (Arg1);
- -- Special processing for Loop_Invariant or for other cases if
- -- a Loop_Entry attribute is present.
+ -- Special processing for Loop_Invariant, Loop_Variant or for
+ -- other cases where a Loop_Entry attribute is present. If the
+ -- assertion pragma contains attribute Loop_Entry, ensure that
+ -- the related pragma is within a loop.
if Prag_Id = Pragma_Loop_Invariant
- or else Contains_Loop_Entry
+ or else Prag_Id = Pragma_Loop_Variant
+ or else Contains_Loop_Entry (Expr)
then
- -- Check restricted placement, must be within a loop
-
Check_Loop_Pragma_Placement;
- -- Do preanalyze to deal with embedded Loop_Entry attribute
+ -- Perform preanalysis to deal with embedded Loop_Entry
+ -- attributes.
Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean);
end if;
------------------
procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Subp : constant Node_Id := Name (N);
- Nam : Entity_Id;
- I : Interp_Index;
- It : Interp;
- Norm_OK : Boolean;
- Scop : Entity_Id;
- Rtype : Entity_Id;
-
function Same_Or_Aliased_Subprograms
(S : Entity_Id;
E : Entity_Id) return Boolean;
return S = E or else (Present (Subp_Alias) and then Subp_Alias = E);
end Same_Or_Aliased_Subprograms;
+ -- Local variables
+
+ Loc : constant Source_Ptr := Sloc (N);
+ Subp : constant Node_Id := Name (N);
+ Body_Id : Entity_Id;
+ I : Interp_Index;
+ It : Interp;
+ Nam : Entity_Id;
+ Nam_Decl : Node_Id;
+ Nam_UA : Entity_Id;
+ Norm_OK : Boolean;
+ Rtype : Entity_Id;
+ Scop : Entity_Id;
+
-- Start of processing for Resolve_Call
begin
and then Is_Overloadable (Nam)
and then not Inside_A_Generic
then
- -- Retrieve the body to inline from the ultimate alias of Nam, if
- -- there is one, otherwise calls that should be inlined end up not
- -- being inlined.
+ Nam_UA := Ultimate_Alias (Nam);
+ Nam_Decl := Unit_Declaration_Node (Nam_UA);
- declare
- Nam_UA : constant Entity_Id := Ultimate_Alias (Nam);
- Decl : constant Node_Id := Unit_Declaration_Node (Nam_UA);
- Body_Id : constant Entity_Id := Corresponding_Body (Decl);
+ if Nkind (Nam_Decl) = N_Subprogram_Declaration then
+ Body_Id := Corresponding_Body (Nam_Decl);
- begin
- -- If the subprogram is not eligible for inlining in GNATprove
- -- mode, do nothing.
+ -- Nothing to do if the subprogram is not eligible for inlining in
+ -- GNATprove mode.
- if Nkind (Decl) /= N_Subprogram_Declaration
- or else not Is_Inlined_Always (Nam_UA)
+ if not Is_Inlined_Always (Nam_UA)
or else not Can_Be_Inlined_In_GNATprove_Mode (Nam_UA, Body_Id)
then
null;
-- the subprogram is not suitable for inlining in GNATprove
-- mode.
- elsif No (Body_To_Inline (Decl)) then
+ elsif No (Body_To_Inline (Nam_Decl)) then
null;
-- Calls cannot be inlined inside potentially unevaluated
Expand_Inlined_Call (N, Nam_UA, Nam);
end if;
end if;
- end;
+ end if;
end if;
Warn_On_Overlapping_Actuals (Nam, N);
raise Program_Error;
end Body_Formal;
- -----------------------------------
- -- May_Need_Initialized_Actual --
- -----------------------------------
+ ---------------------------------
+ -- May_Need_Initialized_Actual --
+ ---------------------------------
procedure May_Need_Initialized_Actual (Ent : Entity_Id) is
T : constant Entity_Id := Etype (Ent);
projects / platform / upstream / gcc.git / commitdiff