This addresses a long-standing issue in the implementation of expression
functions of Ada 2012, pertaining to their interaction with the freezing
of types that are referenced in their expression: when they are used as
the completion of a function declaration, their expression causes these
types to become frozen, but when they are stand-alone, it does not.
The last rule is problematic for GNAT, because it goes against its freezing
model devised for Ada 95, where types must always be frozen for code to be
generated. Therefore the current implementation needs to resort to several
kludges in order to implement it, but these are not bullet proof and do not
always work when tagged types are involved.
The new approach is to insert the generated body of stand-alone expression
functions at the next freezing point, instead of at the end of the current
package. This makes a difference for nested packages, which are precisely
the problematic case. This requires the analysis and resolution performed
on the body, potentially out of context now, to give identical results as
the preanalysis and resolution performed on the expression in its context,
which is achieved by treating the generated body as an inlined body.
This approach requires a more complete implementation of the special rules
for freezing expression functions, so the change overhauls it and plugs the
most blatant loopholes of the current implementation.
gcc/ada/ChangeLog:
PR ada/93702
* contracts.adb (Analyze_Entry_Or_Subprogram_Contract): Call
Freeze_Expr_Types_Before instead of Freeze_Expr_Types.
(Process_Preconditions_For): Likewise.
* exp_ch3.adb (Make_Controlling_Function_Wrappers): Do not set
Was_Expression_Function flag on the generated bodies.
* exp_ch6.adb (Expand_Call_Helper): Call Original_Node on the
result of the call to Expression_Of_Expression_Function.
* freeze.ads (Freeze_Expr_Types): Delete.
(Freeze_Expr_Types_Before): New procedure declaration.
* freeze.adb (Check_Expression_Function): Delete.
(Freeze_And_Append): Add Do_Freeze_Profile formal parameter and
pass it to Freeze_Entity. Remove call to Check_Expression_Function.
(Freeze_Entity): Set Test_E consistently and freeze the expression
of expression functions that are primitives of a tagged type.
(Freeze_Profile): Adjust calls to Should_Freeze_Type.
(In_Expanded_Body): Also return true for DIC procedures.
(Freeze_Expression): Remove call to Check_Expression_Function.
Freeze the expression of expression functions.
(Freeze_Expr_Types): Add Result and Before formal parameters.
Make a copy and preanalyze/resolve it only if Typ is present.
(Freeze_Expr_Types.Explain_Error): New procedure.
(Freeze_Expr_Types.Find_Incomplete_Constant): Likewise.
(Freeze_Expr_Types.Check_And_Freeze_Type): Return immediately if
the type is already frozen. Report errors on N instead of Node.
If Before is False, append the freeze nodes to Result.
(Freeze_Expr_Types.Freeze_Type_Refs): Call Find_Incomplete_Constant.
(Freeze_Expr_Types_Before): New procedure.
(Should_Freeze_Type): Remove formal parameter E and
specific kludge for stand-alone expression functions.
* ghost.ads (Mark_And_Set_Ghost_Body_Of_Expression_Function): New
procedure declaration.
* ghost.adb (Mark_And_Set_Ghost_Body_Of_Expression_Function): New
procedure body.
* rtsfind.adb (RTE): Preserve and reset the In_Inlined_Body flag.
(RTE_Record_Component): Likewise.
* sem_attr.adb (Resolve_Attribute) <Attribute_Access>: Just call
Freeze_Expression to freeze the expression of prefixes that are
expression functions and remove obsolete implementation.
* sem_ch3.adb (Analyze_Declarations): Adjust commentary.
(Check_Completion): Also skip stand-alone expressions functions.
* sem_ch4.adb (Analyze_Case_Expression): Always analyze the choices.
* sem_ch6.adb: Add with and use clauses for Sem_Ch7.
(Analyze_Expression_Function): Call Freeze_Expr_Types_Before instead
of Freeze_Expr_Types for expression functions that are completions.
For stand-alone expression functions, set In_Private_Part on the
entity if it is in the private part, propagate the results of the
resolution of the specification of the the declaration to that of
the body and insert the body at the next freezing point.
(Analyze_Subprogram_Body_Helper): Remove the machinery for masking
and unmasking unfrozen types. For a stand-alone expression function,
call Mark_And_Set_Ghost_Body_Of_Expression_Function, remove obsolete
code dealing with the freezing of the spec, set In_Inlined_Body to
True, make the full view of the private types of its scope visible
if this is not the current scope and it is in the private part, and
avoid making the spec immediately visible.
(Analyze_Subprogram_Specification): Fix typo.
(New_Overloaded_Entity): Set Has_Completion on a [generic] package
that conflicts with the entity to prevent a cascaded error.
* sem_ch7.ads (Is_Private_Base_Type): New function declaration moved
here from...
* sem_ch7.adb (Is_Private_Base_Type): ...here. Remove.
* sem_ch8.adb (Analyze_Subprogram_Renaming): Call Freeze_Expression
to freeze the expression of expression functions, but only if the
renaming comes from source.
* sem_ch12.adb (Analyze_One_Association): Likewise, and remove the
manual freezing for calls to them.
* sem_res.adb (Resolve): Remove obsolete commentary.
(Resolve_Call): Always freeze the expression of names that are
expression functions.
* sem_util.adb (Check_Fully_Declared): Add commentary and do not
check types with private component declared outside of the current
scope when it is a generic unit.
(Expression_Of_Expression_Function): Return Expression directly.
(Is_Inlinable_Expression_Function): Call Original_Node on the
result of the call to Expression_Of_Expression_Function.
if Freeze_Types
and then Present (Corresponding_Aspect (Prag))
then
- Freeze_Expr_Types
- (Def_Id => Subp_Id,
- Typ => Standard_Boolean,
+ Freeze_Expr_Types_Before
+ (N => Bod,
Expr =>
Expression
(First (Pragma_Argument_Associations (Prag))),
- N => Bod);
+ Def_Id => Subp_Id,
+ Typ => Standard_Boolean);
end if;
Analyze_Pre_Post_Condition_In_Decl_Part (Prag, Freeze_Id);
if Freeze_T
and then Present (Corresponding_Aspect (Prag))
then
- Freeze_Expr_Types
- (Def_Id => Subp_Id,
- Typ => Standard_Boolean,
+ Freeze_Expr_Types_Before
+ (N => Body_Decl,
Expr =>
Expression
(First (Pragma_Argument_Associations (Prag))),
- N => Body_Decl);
+ Def_Id => Subp_Id,
+ Typ => Standard_Boolean);
end if;
Prepend_Pragma_To_Decls (Prag);
Null_Record_Present => True);
-- GNATprove will use expression of an expression function as an
- -- implicit postcondition. GNAT will also benefit from expression
- -- function to avoid premature freezing, but would struggle if we
- -- added an expression function to freezing actions, so we create
- -- the expanded form directly.
+ -- implicit postcondition.
if GNATprove_Mode then
Func_Body :=
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression => Ext_Aggr))));
- Set_Was_Expression_Function (Func_Body);
end if;
Append_To (Body_List, Func_Body);
elsif Is_Inlinable_Expression_Function (Subp) then
Rewrite
- (Call_Node, New_Copy (Expression_Of_Expression_Function (Subp)));
+ (Call_Node,
+ New_Copy
+ (Original_Node (Expression_Of_Expression_Function (Subp))));
Analyze (Call_Node);
return;
-- the flag if Debug_Info_Off is set. This procedure also ensures that
-- subsidiary entities have the flag set as required.
- procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id);
- -- When an expression function is frozen by a use of it, the expression
- -- itself is frozen. Check that the expression does not include references
- -- to deferred constants without completion. We report this at the freeze
- -- point of the function, to provide a better error message.
- --
- -- In most cases the expression itself is frozen by the time the function
- -- itself is frozen, because the formals will be frozen by then. However,
- -- Attribute references to outer types are freeze points for those types;
- -- this routine generates the required freeze nodes for them.
-
procedure Check_Strict_Alignment (E : Entity_Id);
-- E is a base type. If E is tagged or has a component that is aliased
-- or tagged or contains something this is aliased or tagged, set
-- effect if the entity E is not a discrete or fixed-point type.
procedure Freeze_And_Append
- (Ent : Entity_Id;
- N : Node_Id;
- Result : in out List_Id);
+ (Ent : Entity_Id;
+ N : Node_Id;
+ Result : in out List_Id;
+ Do_Freeze_Profile : Boolean := True);
-- Freezes Ent using Freeze_Entity, and appends the resulting list of
- -- nodes to Result, modifying Result from No_List if necessary. N has
- -- the same usage as in Freeze_Entity.
+ -- nodes to Result, modifying Result from No_List if necessary. N and
+ -- Do_Freeze_Profile have the same usage as in Freeze_Entity.
procedure Freeze_Enumeration_Type (Typ : Entity_Id);
-- Freeze enumeration type. The Esize field is set as processing
-- that if a foreign convention is specified, and no specific size
-- is given, then the size must be at least Integer'Size.
+ procedure Freeze_Expr_Types
+ (Expr : Node_Id;
+ N : Node_Id;
+ Def_Id : Entity_Id;
+ Result : in out List_Id;
+ Before : Boolean := False;
+ Typ : Entity_Id := Empty);
+ -- Same as Freeze_Expr_Types_Before if Before is True, but appends the
+ -- resulting list of nodes to Result if Before is False, modifying Result
+ -- from No_List if necessary.
+
procedure Freeze_Static_Object (E : Entity_Id);
-- If an object is frozen which has Is_Statically_Allocated set, then
-- all referenced types must also be marked with this flag. This routine
-- attribute definition clause occurs, then these two flags are reset in
-- any case, so call will have no effect.
- function Should_Freeze_Type
- (Typ : Entity_Id;
- E : Entity_Id;
- N : Node_Id) return Boolean;
- -- True if Typ should be frozen when the profile of E is being frozen at N.
-
- -- ??? Expression functions that are not completions shouldn't freeze types
- -- but our current expansion and freezing model requires an early freezing
- -- when the tag of Typ is needed or for an aggregate with a subtype of Typ,
- -- so we return True in these cases.
+ function Should_Freeze_Type (Typ : Entity_Id; N : Node_Id) return Boolean;
+ -- True if Typ should be frozen when a profile is being frozen at N.
procedure Undelay_Type (T : Entity_Id);
-- T is a type of a component that we know to be an Itype. We don't want
end if;
end Check_Debug_Info_Needed;
- -------------------------------
- -- Check_Expression_Function --
- -------------------------------
-
- procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id) is
- function Find_Constant (Nod : Node_Id) return Traverse_Result;
- -- Function to search for deferred constant
-
- -------------------
- -- Find_Constant --
- -------------------
-
- function Find_Constant (Nod : Node_Id) return Traverse_Result is
- begin
- -- When a constant is initialized with the result of a dispatching
- -- call, the constant declaration is rewritten as a renaming of the
- -- displaced function result. This scenario is not a premature use of
- -- a constant even though the Has_Completion flag is not set.
-
- if Is_Entity_Name (Nod)
- and then Present (Entity (Nod))
- and then Ekind (Entity (Nod)) = E_Constant
- and then Scope (Entity (Nod)) = Current_Scope
- and then Nkind (Declaration_Node (Entity (Nod))) =
- N_Object_Declaration
- and then not Is_Imported (Entity (Nod))
- and then not Has_Completion (Entity (Nod))
- and then not (Present (Full_View (Entity (Nod)))
- and then Has_Completion (Full_View (Entity (Nod))))
- then
- Error_Msg_NE
- ("premature use of& in call or instance", N, Entity (Nod));
-
- elsif Nkind (Nod) = N_Attribute_Reference then
- Analyze (Prefix (Nod));
-
- if Is_Entity_Name (Prefix (Nod))
- and then Is_Type (Entity (Prefix (Nod)))
- then
- if Expander_Active then
- Check_Fully_Declared (Entity (Prefix (Nod)), N);
- end if;
-
- Freeze_Before (N, Entity (Prefix (Nod)));
- end if;
- end if;
-
- return OK;
- end Find_Constant;
-
- procedure Check_Deferred is new Traverse_Proc (Find_Constant);
-
- -- Local variables
-
- Decl : Node_Id;
-
- -- Start of processing for Check_Expression_Function
-
- begin
- Decl := Original_Node (Unit_Declaration_Node (Nam));
-
- -- The subprogram body created for the expression function is not
- -- itself a freeze point.
-
- if Scope (Nam) = Current_Scope
- and then Nkind (Decl) = N_Expression_Function
- and then Nkind (N) /= N_Subprogram_Body
- then
- Check_Deferred (Expression (Decl));
- end if;
- end Check_Expression_Function;
-
--------------------------------
-- Check_Inherited_Conditions --
--------------------------------
-----------------------
procedure Freeze_And_Append
- (Ent : Entity_Id;
- N : Node_Id;
- Result : in out List_Id)
+ (Ent : Entity_Id;
+ N : Node_Id;
+ Result : in out List_Id;
+ Do_Freeze_Profile : Boolean := True)
is
- -- Freezing an Expression_Function does not freeze its profile:
- -- the formals will have been frozen otherwise before the E_F
- -- can be called.
+ L : constant List_Id := Freeze_Entity (Ent, N, Do_Freeze_Profile);
- L : constant List_Id :=
- Freeze_Entity
- (Ent, N, Do_Freeze_Profile => not Is_Expression_Function (Ent));
begin
if Is_Non_Empty_List (L) then
if Result = No_List then
Pack : constant Entity_Id := Scope (T);
begin
- if Ekind (T) = E_Function then
- Check_Expression_Function (N, T);
- end if;
-
if Is_Non_Empty_List (Freeze_Nodes) then
-- If the entity is a type declared in an inner package, it may be
Result : List_Id := No_List;
-- List of freezing actions, left at No_List if none
- Test_E : Entity_Id := E;
+ Test_E : Entity_Id;
-- A local temporary used to test if freezing is necessary for E, since
-- its value can be set to something other than E in certain cases. For
-- example, E cannot be used directly in cases such as when it is an
end if;
if not From_Limited_With (F_Type)
- and then Should_Freeze_Type (F_Type, E, N)
+ and then Should_Freeze_Type (F_Type, N)
then
Freeze_And_Append (F_Type, N, Result);
end if;
Set_Etype (E, R_Type);
end if;
- if Should_Freeze_Type (R_Type, E, N) then
+ if Should_Freeze_Type (R_Type, N) then
Freeze_And_Append (R_Type, N, Result);
end if;
and then Is_Record_Type (Underlying_Type (Scope (E)))
then
Test_E := Underlying_Type (Scope (E));
+
+ else
+ Test_E := E;
end if;
-- Do not freeze if already frozen since we only need one freeze node
if Is_Type (E) then
Freeze_And_Append (First_Subtype (E), N, Result);
- -- If we just froze a tagged non-class-wide record, then freeze the
- -- corresponding class-wide type. This must be done after the tagged
- -- type itself is frozen, because the class-wide type refers to the
- -- tagged type which generates the class.
+ -- When a tagged type is frozen, the corresponding class-wide type
+ -- is frozen as well (RM 13.14(15)). This must be done after the
+ -- tagged type itself is frozen, because the class-wide type refers
+ -- to the tagged type which generates the class.
- -- For a tagged type, freeze explicitly those primitive operations
- -- that are expression functions, which otherwise have no clear
- -- freeze point: these have to be frozen before the dispatch table
- -- for the type is built, and before any explicit call to the
- -- primitive, which would otherwise be the freeze point for it.
+ -- When a tagged type is frozen, the primitive subprograms of the
+ -- type are frozen; for each such subprogram that is an expression
+ -- function, its expression causes freezing (RM 13.14(15.1)).
- if Is_Tagged_Type (E)
- and then not Is_Class_Wide_Type (E)
- and then Present (Class_Wide_Type (E))
- then
- Freeze_And_Append (Class_Wide_Type (E), N, Result);
+ -- Note that we explicitly freeze only expression functions here for
+ -- historical reasons; other primitive subprograms are frozen later,
+ -- by means of other freezing mechanisms.
+ if Is_Tagged_Type (E) and then not Is_Class_Wide_Type (E) then
declare
- Ops : constant Elist_Id := Primitive_Operations (E);
+ Ops : constant Elist_Id := Primitive_Operations (E);
Elmt : Elmt_Id;
Subp : Entity_Id;
begin
- if Ops /= No_Elist then
+ if Present (Class_Wide_Type (E)) then
+ Freeze_And_Append (Class_Wide_Type (E), N, Result);
+ end if;
+
+ if Present (Ops) then
Elmt := First_Elmt (Ops);
while Present (Elmt) loop
Subp := Node (Elmt);
if Is_Expression_Function (Subp) then
- Freeze_And_Append (Subp, N, Result);
+ Freeze_And_Append
+ (Subp, N, Result, Do_Freeze_Profile => False);
+ Freeze_Expr_Types
+ (Expr => Expression_Of_Expression_Function (Subp),
+ N => N,
+ Def_Id => Subp,
+ Result => Result);
end if;
-
Next_Elmt (Elmt);
end loop;
end if;
then
return True;
+ -- This is the body of a Default_Initial_Condition procedure
+
+ elsif Present (Corresponding_Spec (P))
+ and then Is_DIC_Procedure (Corresponding_Spec (P))
+ then
+ return True;
+
-- This is the body of a helper/wrapper built for CW preconditions
elsif Present (Corresponding_Spec (P))
or else not Comes_From_Source (Entity (N)))
then
Nam := Entity (N);
-
- if Present (Nam) and then Ekind (Nam) = E_Function then
- Check_Expression_Function (N, Nam);
- end if;
-
else
Nam := Empty;
end if;
if Present (Nam) then
Freeze_Before (P, Nam);
+
+ -- Freeze types in expression function (RM 13.14(10.1, 10.2, 10.3))
+
+ if Is_Expression_Function (Nam) then
+ Freeze_Expr_Types_Before
+ (N => P,
+ Expr => Expression_Of_Expression_Function (Nam),
+ Def_Id => Nam);
+ end if;
end if;
-- Restore In_Spec_Expression flag
-----------------------
procedure Freeze_Expr_Types
- (Def_Id : Entity_Id;
- Typ : Entity_Id;
- Expr : Node_Id;
- N : Node_Id)
+ (Expr : Node_Id;
+ N : Node_Id;
+ Def_Id : Entity_Id;
+ Result : in out List_Id;
+ Before : Boolean := False;
+ Typ : Entity_Id := Empty)
is
function Cloned_Expression return Node_Id;
-- Build a duplicate of the expression of the return statement that has
-- no defining entities shared with the original expression.
+ procedure Explain_Error;
+ -- Output an explanation of the error as continuation messages
+
+ procedure Find_Incomplete_Constant (Node : Node_Id);
+ -- Search for a deferred constant without completion
+
function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result;
-- Freeze all types referenced in the subtree rooted at Node
return Dup_Expr;
end Cloned_Expression;
+ -------------------
+ -- Explain_Error --
+ -------------------
+
+ procedure Explain_Error is
+ begin
+ Error_Msg_NE
+ ("\\because expression of function& is frozen here", N, Def_Id);
+ if Nkind (N) = N_Object_Declaration
+ and then Is_Dispatching_Operation (Def_Id)
+ then
+ declare
+ Typ : constant Entity_Id :=
+ (if Present (Expression (N))
+ then Etype (Expression (N))
+ else Etype (Defining_Identifier (N)));
+ begin
+ if Present (Typ) then
+ Error_Msg_NE
+ ("\\as a primitive operation of type& frozen here",
+ N, Typ);
+ end if;
+ end;
+ end if;
+ if Nkind (N) /= N_Expression_Function then
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Msg_NE ("\\expression function& is declared#", N, Def_Id);
+ end if;
+ end Explain_Error;
+
+ ------------------------------
+ -- Find_Incomplete_Constant --
+ ------------------------------
+
+ procedure Find_Incomplete_Constant (Node : Node_Id) is
+ begin
+ -- When a constant is initialized with the result of a dispatching
+ -- call, the constant declaration is rewritten as a renaming of the
+ -- displaced function result. This scenario is not a premature use of
+ -- a constant even though the Has_Completion flag is not set.
+
+ if Is_Entity_Name (Node)
+ and then Present (Entity (Node))
+ and then Ekind (Entity (Node)) = E_Constant
+ and then Scope (Entity (Node)) = Current_Scope
+ and then Nkind (Declaration_Node (Entity (Node))) =
+ N_Object_Declaration
+ and then not Is_Imported (Entity (Node))
+ and then not Has_Completion (Entity (Node))
+ and then not
+ (Present (Full_View (Entity (Node)))
+ and then (Has_Completion (Full_View (Entity (Node)))
+ or else
+ Declaration_Node (Full_View (Entity (Node))) = N))
+ then
+ Error_Msg_NE
+ ("deferred constant& is frozen before completion",
+ N, Entity (Node));
+
+ Explain_Error;
+
+ Set_Is_Frozen (Entity (Node));
+ end if;
+ end Find_Incomplete_Constant;
+
----------------------
-- Freeze_Type_Refs --
----------------------
procedure Check_And_Freeze_Type (Typ : Entity_Id) is
begin
+ if Is_Frozen (Typ) then
+ return;
+ end if;
+
-- Skip Itypes created by the preanalysis, and itypes whose
-- scope is another type (i.e. component subtypes that depend
-- on a discriminant),
-- whose compilation fails much later. Refine the error message if
-- possible.
- Check_Fully_Declared (Typ, Node);
+ Check_Fully_Declared (Typ, N);
- if Error_Posted (Node) then
+ if Error_Posted (N) then
if Has_Private_Component (Typ)
and then not Is_Private_Type (Typ)
then
- Error_Msg_NE ("\type& has private component", Node, Typ);
+ Error_Msg_NE ("\\type& has private component", N, Typ);
end if;
- else
+ Explain_Error;
+
+ elsif Before then
Freeze_Before (N, Typ);
+
+ else
+ Freeze_And_Append (Typ, N, Result);
end if;
end Check_And_Freeze_Type;
end;
end if;
+ Find_Incomplete_Constant (Node);
+
-- No point in posting several errors on the same expression
if Serious_Errors_Detected > 0 then
procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs);
- -- Local variables
-
- Saved_First_Entity : constant Entity_Id := First_Entity (Def_Id);
- Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id);
- Dup_Expr : constant Node_Id := Cloned_Expression;
-
-- Start of processing for Freeze_Expr_Types
begin
-- And_Resolve for the sake of consistency with Analyze_Expression_
-- Function.
- if Def_Id /= Current_Scope then
- Push_Scope (Def_Id);
- Install_Formals (Def_Id);
- Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ);
- End_Scope;
- else
- Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ);
- end if;
+ if Present (Typ) then
+ declare
+ Saved_First_Entity : constant Entity_Id := First_Entity (Def_Id);
+ Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id);
+ Dup_Expr : constant Node_Id := Cloned_Expression;
+
+ begin
+ if Def_Id /= Current_Scope then
+ Push_Scope (Def_Id);
+ Install_Formals (Def_Id);
+ Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ);
+ End_Scope;
+ else
+ Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ);
+ end if;
- -- Restore certain attributes of Def_Id since the preanalysis may
- -- have introduced itypes to this scope, thus modifying attributes
- -- First_Entity and Last_Entity.
+ -- Restore certain attributes of Def_Id since the preanalysis may
+ -- have introduced itypes to this scope, thus modifying attributes
+ -- First_Entity and Last_Entity.
- Set_First_Entity (Def_Id, Saved_First_Entity);
- Set_Last_Entity (Def_Id, Saved_Last_Entity);
+ Set_First_Entity (Def_Id, Saved_First_Entity);
+ Set_Last_Entity (Def_Id, Saved_Last_Entity);
- if Present (Last_Entity (Def_Id)) then
- Set_Next_Entity (Last_Entity (Def_Id), Empty);
- end if;
+ if Present (Last_Entity (Def_Id)) then
+ Set_Next_Entity (Last_Entity (Def_Id), Empty);
+ end if;
- -- Freeze all types referenced in the expression
+ -- Freeze all types referenced in the expression
- Freeze_References (Dup_Expr);
+ Freeze_References (Dup_Expr);
+ end;
+
+ else
+ Freeze_References (Expr);
+ end if;
end Freeze_Expr_Types;
+ ------------------------------
+ -- Freeze_Expr_Types_Before --
+ ------------------------------
+
+ procedure Freeze_Expr_Types_Before
+ (N : Node_Id;
+ Expr : Node_Id;
+ Def_Id : Entity_Id;
+ Typ : Entity_Id := Empty)
+ is
+ Dummy : List_Id := No_List;
+
+ begin
+ Freeze_Expr_Types
+ (Expr => Expr,
+ N => N,
+ Def_Id => Def_Id,
+ Result => Dummy,
+ Before => True,
+ Typ => Typ);
+ end Freeze_Expr_Types_Before;
+
-----------------------------
-- Freeze_Fixed_Point_Type --
-----------------------------
-- Should_Freeze_Type --
------------------------
- function Should_Freeze_Type
- (Typ : Entity_Id;
- E : Entity_Id;
- N : Node_Id) return Boolean
- is
- Decl : constant Node_Id :=
- (if Ekind (E) = E_Subprogram_Type and then No (Parent (E))
- then Empty
- else Original_Node (Unit_Declaration_Node (E)));
-
- function Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate
- (N : Node_Id) return Traverse_Result;
- -- Return Abandon if N is a dispatching call to a subprogram
- -- declared in the same scope as Typ, or a tagged result that
- -- needs specific expansion, or an aggregate whose type is Typ.
-
- function Check_Freezing is new
- Traverse_Func (Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate);
- -- Return Abandon if the input expression requires freezing Typ
-
- function Within_Simple_Return_Statement (N : Node_Id) return Boolean;
- -- Determine whether N is the expression of a simple return statement,
- -- or the dependent expression of a conditional expression which is
- -- the expression of a simple return statement, including recursively.
-
- -------------------------------------------------------
- -- Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate --
- -------------------------------------------------------
-
- function Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate
- (N : Node_Id) return Traverse_Result
- is
- begin
- if Nkind (N) = N_Function_Call
- and then Present (Controlling_Argument (N))
- and then Scope (Entity (Original_Node (Name (N)))) = Scope (Typ)
- then
- return Abandon;
-
- -- The expansion done in Expand_Simple_Function_Return will assign
- -- the tag to the result in this case.
-
- elsif Is_Conversion_Or_Reference_To_Formal (N)
- and then Within_Simple_Return_Statement (N)
- and then Etype (N) = Typ
- and then Is_Tagged_Type (Typ)
- and then not Is_Class_Wide_Type (Typ)
- then
- return Abandon;
-
- elsif Nkind (N) in N_Aggregate
- | N_Delta_Aggregate
- | N_Extension_Aggregate
- and then Base_Type (Etype (N)) = Base_Type (Typ)
- then
- return Abandon;
-
- else
- return OK;
- end if;
- end Is_Dispatching_Call_Or_Tagged_Result_Or_Aggregate;
-
- ------------------------------------
- -- Within_Simple_Return_Statement --
- ------------------------------------
-
- function Within_Simple_Return_Statement (N : Node_Id) return Boolean is
- Par : constant Node_Id := Parent (N);
-
- begin
- if Nkind (Par) = N_Simple_Return_Statement then
- return True;
-
- elsif Nkind (Par) = N_Case_Expression_Alternative then
- return Within_Simple_Return_Statement (Parent (Par));
-
- elsif Nkind (Par) = N_If_Expression
- and then N /= First (Expressions (Par))
- then
- return Within_Simple_Return_Statement (Par);
-
- else
- return False;
- end if;
- end Within_Simple_Return_Statement;
-
- -- Start of processing for Should_Freeze_Type
-
+ function Should_Freeze_Type (Typ : Entity_Id; N : Node_Id) return Boolean is
begin
return Within_Scope (Typ, Current_Scope)
or else (Nkind (N) = N_Subprogram_Renaming_Declaration
- and then Present (Corresponding_Formal_Spec (N)))
- or else (Present (Decl)
- and then Nkind (Decl) = N_Expression_Function
- and then Check_Freezing (Expression (Decl)) = Abandon);
+ and then Present (Corresponding_Formal_Spec (N)));
end Should_Freeze_Type;
------------------
-- so need to be similarly treated. Freeze_Expression takes care of
-- determining the proper insertion point for generated freeze actions.
- procedure Freeze_Expr_Types
- (Def_Id : Entity_Id;
- Typ : Entity_Id;
+ procedure Freeze_Expr_Types_Before
+ (N : Node_Id;
Expr : Node_Id;
- N : Node_Id);
- -- N is the body constructed for an expression function that is a
- -- completion, and Def_Id is the function being completed.
+ Def_Id : Entity_Id;
+ Typ : Entity_Id := Empty);
-- This procedure freezes before N all the types referenced in Expr,
- -- which is either the expression of the expression function, or
- -- the expression in a pre/post aspect that applies to Def_Id;
+ -- which is either the expression of the expression function Def_Id,
+ -- or the expression in a pre/post aspect that applies to Def_Id.
+
+ -- If Typ is present, it is the type used to preanalyze and resolve a
+ -- copy of Expr; if it is not, Expr is assumed to be already analyzed.
+
+ -- Check that the expression does not include references to deferred
+ -- constants without completion. We report this at the freeze point of
+ -- the function, to provide a better error message.
procedure Freeze_Fixed_Point_Type (Typ : Entity_Id);
-- Freeze fixed point type. For fixed-point types, we have to defer
Check_Ghost_Completion (Prev_Id => Spec_Id, Compl_Id => Body_Id);
- -- Mark the body as its formals as Ghost
+ -- Mark the body and its formals as Ghost
Mark_Ghost_Declaration_Or_Body (N, Policy, Level);
Install_Ghost_Region (Policy, N, Level);
end Mark_And_Set_Ghost_Body;
+ ----------------------------------------------------
+ -- Mark_And_Set_Ghost_Body_Of_Expression_Function --
+ ----------------------------------------------------
+
+ procedure Mark_And_Set_Ghost_Body_Of_Expression_Function
+ (N : Node_Id;
+ Spec_Id : Entity_Id)
+ is
+ Level : constant Entity_Id := Ghost_Assertion_Level (Spec_Id);
+
+ Policy : Name_Id;
+
+ begin
+ if Is_Checked_Ghost_Entity (Spec_Id) then
+ Policy := Name_Check;
+ elsif Is_Ignored_Ghost_Entity (Spec_Id) then
+ Policy := Name_Ignore;
+ else
+ Policy := No_Name;
+ end if;
+
+ -- Mark the body and its formals as Ghost
+
+ Mark_Ghost_Declaration_Or_Body (N, Policy, Level);
+
+ -- Install the appropriate Ghost region
+
+ Install_Ghost_Region (Policy, N, Level);
+ end Mark_And_Set_Ghost_Body_Of_Expression_Function;
+
-----------------------------------
-- Mark_And_Set_Ghost_Completion --
-----------------------------------
-- Install the Ghost mode of the body. This routine starts a Ghost region
-- and must be used with routine Restore_Ghost_Region.
+ procedure Mark_And_Set_Ghost_Body_Of_Expression_Function
+ (N : Node_Id;
+ Spec_Id : Entity_Id);
+ -- Mark the subprogram body N generated for an expression function Spec_Id
+ -- that is not a completion as Ghost when Spec_Id is a Ghost entity.
+ --
+ -- Install the Ghost mode of the body. This routine starts a Ghost region
+ -- and must be used with routine Restore_Ghost_Region.
+
procedure Mark_And_Set_Ghost_Completion
(N : Node_Id;
Prev_Id : Entity_Id);
Lib_Unit : Node_Id;
Pkg_Ent : Entity_Id;
- Save_Front_End_Inlining : constant Boolean := Front_End_Inlining;
+ Saved_Front_End_Inlining : constant Boolean := Front_End_Inlining;
-- This flag is used to disable front-end inlining when RTE is invoked.
-- This prevents the analysis of other runtime bodies when a particular
- -- spec is loaded through Rtsfind. This is both efficient, and prevents
- -- spurious visibility conflicts between use-visible user entities, and
+ -- spec is loaded through Rtsfind. This is efficient, and also prevents
+ -- spurious visibility conflicts between use-visible user entities and
-- entities in run-time packages.
+ Saved_In_Inlined_Body : constant Boolean := In_Inlined_Body;
+ -- This flag is used to preserve and reset In_Inlined_Body when RTE is
+ -- invoked.
+
-- Start of processing for RTE
begin
end if;
Front_End_Inlining := False;
+ In_Inlined_Body := False;
-- Load unit if unit not previously loaded
end if;
Maybe_Add_With (U);
- Front_End_Inlining := Save_Front_End_Inlining;
+
+ Front_End_Inlining := Saved_Front_End_Inlining;
+ In_Inlined_Body := Saved_In_Inlined_Body;
return Check_CRT (E, RE_Table (E));
end RTE;
Lib_Unit : Node_Id;
Pkg_Ent : Entity_Id;
- -- The following flag is used to disable front-end inlining when
+ Saved_Front_End_Inlining : constant Boolean := Front_End_Inlining;
+ -- This flags is used to disable front-end inlining when
-- RTE_Record_Component is invoked. This prevents the analysis of other
-- runtime bodies when a particular spec is loaded through Rtsfind. This
- -- is both efficient, and it prevents spurious visibility conflicts
- -- between use-visible user entities, and entities in run-time packages.
+ -- is efficient, and also prevents spurious visibility conflicts between
+ -- use-visible user entities and entities in run-time packages.
- Save_Front_End_Inlining : Boolean;
+ Saved_In_Inlined_Body : constant Boolean := In_Inlined_Body;
+ -- This flag is used to preserve and reset In_Inlined_Body when
+ -- RTE_Record_Component is invoked.
begin
-- Note: Contrary to subprogram RTE, there is no need to do any special
-- management with package system.ads because it has no record type
-- declarations.
- Save_Front_End_Inlining := Front_End_Inlining;
- Front_End_Inlining := False;
+ Front_End_Inlining := False;
+ In_Inlined_Body := False;
-- Load unit if unit not previously loaded
Maybe_Add_With (U);
- Front_End_Inlining := Save_Front_End_Inlining;
+ Front_End_Inlining := Saved_Front_End_Inlining;
+ In_Inlined_Body := Saved_In_Inlined_Body;
+
return Check_CRT (E, Found_E);
end RTE_Record_Component;
-- spec expressions). The profile of the subprogram is not
-- frozen at this point.
+ -- Taking the 'Access of an expression function freezes its
+ -- expression (RM 13.14(10.3)).
+
if not Preanalysis_Active then
- Freeze_Before (N, Entity (P), Do_Freeze_Profile => False);
+ if Is_Expression_Function (Entity (P)) then
+ Freeze_Expression (P);
+ else
+ Freeze_Before
+ (N, Entity (P), Do_Freeze_Profile => False);
+ end if;
end if;
-- If it is a type, there is nothing to resolve.
elsif Is_Overloadable (Entity (P)) then
if not Preanalysis_Active then
- Freeze_Before (N, Entity (P), Do_Freeze_Profile => False);
+ if Is_Expression_Function (Entity (P)) then
+ Freeze_Expression (P);
+ else
+ Freeze_Before
+ (N, Entity (P), Do_Freeze_Profile => False);
+ end if;
end if;
-- Nothing to do if prefix is a type name
Scop : constant Entity_Id := Scope (Subp_Id);
Subp_Decl : constant Node_Id :=
Unit_Declaration_Node (Subp_Id);
- Flag_Id : Entity_Id;
- Subp_Body : Node_Id;
+
+ Flag_Id : Entity_Id;
-- If the access has been taken and the body of the subprogram
-- has not been see yet, indirect calls must be protected with
Set_Scope (Flag_Id, Scop);
end if;
-
- -- Taking the 'Access of an expression function freezes its
- -- expression (RM 13.14 10.3/3). This does not apply to an
- -- expression function that acts as a completion because the
- -- generated body is immediately analyzed and the expression
- -- is automatically frozen.
-
- if Is_Expression_Function (Subp_Id)
- and then Present (Corresponding_Body (Subp_Decl))
- then
- Subp_Body :=
- Unit_Declaration_Node (Corresponding_Body (Subp_Decl));
-
- -- The body has already been analyzed when the expression
- -- function acts as a completion.
-
- if Analyzed (Subp_Body) then
- null;
-
- -- Attribute 'Access may appear within the generated body
- -- of the expression function subject to the attribute:
-
- -- function F is (... F'Access ...);
-
- -- If the expression function is on the scope stack, then
- -- the body is currently being analyzed. Do not reanalyze
- -- it because this will lead to infinite recursion.
-
- elsif In_Open_Scopes (Subp_Id) then
- null;
-
- -- If reference to the expression function appears in an
- -- inner scope, for example as an actual in an instance,
- -- this is not a freeze point either.
-
- elsif Scope (Subp_Id) /= Current_Scope then
- null;
-
- -- Dispatch tables are not a freeze point either
-
- elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
- and then Is_Dispatch_Table_Entity (Etype (Parent (N)))
- then
- null;
-
- -- Analyze the body of the expression function to freeze
- -- the expression.
-
- else
- Analyze (Subp_Body);
- end if;
- end if;
end;
end if;
-- An instantiation freezes all generic actuals, except for incomplete
-- types and subprograms that are not fully defined at the point of
- -- instantiation.
+ -- instantiation. If one of them is an expression function, then the
+ -- instantiation also freezes its expression (RM 13.14(10.2)).
declare
- Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze);
+ Elmt : Elmt_Id;
+ Expr : Node_Id;
begin
+ Elmt := First_Elmt (Actuals_To_Freeze);
while Present (Elmt) loop
- Freeze_Before (N, Node (Elmt));
+ -- For technical reasons, we need an expression attached to the
+ -- tree to freeze the expression of an expression function, so
+ -- we manufacture one on the fly.
+
+ if Is_Expression_Function (Node (Elmt)) then
+ Expr := New_Occurrence_Of (Node (Elmt), Sloc (N));
+ Set_Comes_From_Source (Expr);
+ Set_Entity (Expr, Node (Elmt));
+ Set_Parent (Expr, N);
+ Freeze_Expression (Expr);
+ else
+ Freeze_Before (N, Node (Elmt));
+ end if;
+
Next_Elmt (Elmt);
end loop;
end;
end if;
end if;
- -- If the object is a call to an expression function, this
- -- is a freezing point for it.
-
- if Is_Entity_Name (Match)
- and then Present (Entity (Match))
- and then Is_Expression_Function (Entity (Match))
- then
- Append_Elmt (Entity (Match), Actuals_To_Freeze);
- end if;
-
when N_Formal_Type_Declaration =>
if Assoc.Actual.Kind = Box_Actual then
Process_Box_Actual (Assoc.Un_Formal);
-- generated bodies that have not been analyzed yet), freeze all
-- types now. Note that in the latter case, the expander must take
-- care to attach the bodies at a proper place in the tree so as to
- -- not cause unwanted freezing at that point.
+ -- not cause unwanted freezing at that point. The exception is the
+ -- generated body of an expression function, which does not freeze.
-- It is also necessary to check for a case where both an expression
-- function is used and the current scope depends on an incomplete
Adjust_Decl;
- -- The generated body of an expression function does not freeze,
- -- unless it is a completion, in which case only the expression
- -- itself freezes. This is handled when the body itself is
- -- analyzed (see Freeze_Expr_Types, sem_ch6.adb).
-
Freeze_All (Freeze_From, Decl);
Freeze_From := Last_Entity (Current_Scope);
end if;
-- source (including the _Call primitive operation of RAS types,
-- which has to have the flag Comes_From_Source for other purposes):
-- we assume that the expander will provide the missing completion.
+
+ -- Likewise for a stand-alone expression function, whose body may be
+ -- generated outside of the package.
+
-- In case of previous errors, other expansion actions that provide
-- bodies for null procedures with not be invoked, so inhibit message
-- in those cases.
then
null;
+ elsif Is_Expression_Function (E) then
+ null;
+
elsif
Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
then
and then Has_Static_Predicate_Aspect (Exp_Type)
and then Preanalysis_Active
then
- null;
+ Analyze_Choices (Alternatives (N), Exp_Type);
-- Call Analyze_Choices and Check_Choices to do the rest of the work
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch4; use Sem_Ch4;
with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch9; use Sem_Ch9;
with Sem_Ch10; use Sem_Ch10;
-- Local variables
Asp : Node_Id;
+ F_Id : Node_Id;
+ F_Spec : Node_Id;
New_Body : Node_Id;
New_Spec : Node_Id;
Orig_N : Node_Id := Empty;
-- with the function body.
Ghost_Context_Checks_Disabled := True;
- Freeze_Expr_Types
- (Def_Id => Def_Id,
- Typ => Typ,
+ Freeze_Expr_Types_Before
+ (N => N,
Expr => Expr,
- N => N);
+ Def_Id => Def_Id,
+ Typ => Typ);
Ghost_Context_Checks_Disabled := False;
end if;
Def_Id := Defining_Entity (N);
Set_Is_Inlined (Def_Id);
+ Set_In_Private_Part (Def_Id, In_Private_Part (Scope (Def_Id)));
Typ := Etype (Def_Id);
+ -- Propagate the results of the resolution of the specification of
+ -- the declaration to the specification of the body, so that it is
+ -- not done again and potentially out of context.
+
+ Set_Result_Definition (New_Spec, New_Occurrence_Of (Typ, Loc));
+
+ F_Id := First_Formal (Def_Id);
+ F_Spec := First (Parameter_Specifications (New_Spec));
+ while Present (F_Spec) loop
+ if Nkind (Parameter_Type (F_Spec)) = N_Access_Definition then
+ Set_Subtype_Mark
+ (Parameter_Type (F_Spec),
+ New_Occurrence_Of
+ (Directly_Designated_Type (Etype (F_Id)), Loc));
+ elsif Null_Exclusion_Present (F_Spec) then
+ Set_Parameter_Type
+ (F_Spec, New_Occurrence_Of (Base_Type (Etype (F_Id)), Loc));
+ else
+ Set_Parameter_Type
+ (F_Spec, New_Occurrence_Of (Etype (F_Id), Loc));
+ end if;
+
+ Next_Formal (F_Id);
+ Next (F_Spec);
+ end loop;
+
-- Establish the linkages between the spec and the body. These are
-- used when the expression function acts as the prefix of attribute
-- 'Access in order to freeze the original expression which has been
Insert_After (N, New_Body);
-- To prevent premature freeze action, insert the new body at the end
- -- of the current declarations, or at the end of the package spec.
+ -- of the current declarative part or at the end of the specification
+ -- of the innermost package that is a library unit per RM 13.14(3/5).
-- However, resolve usage names now, to prevent spurious visibility
-- on later entities. Note that the function can now be called in
-- the current declarative part, which will appear to be prior to the
else
declare
- Decls : List_Id := List_Containing (N);
- Par : constant Node_Id := Parent (Decls);
+ Decls : List_Id := List_Containing (N);
+ Par : Node_Id := Parent (Decls);
begin
+ while Nkind (Par) = N_Package_Specification
+ and then not Is_Compilation_Unit (Defining_Entity (Par))
+ and then not Is_Generic_Instance (Defining_Entity (Par))
+ and then not Is_Generic_Unit (Defining_Entity (Par))
+ loop
+ Decls := List_Containing (Parent (Par));
+ Par := Parent (Decls);
+ end loop;
+
if Nkind (Par) = N_Package_Specification
and then Decls = Visible_Declarations (Par)
and then not Is_Empty_List (Private_Declarations (Par))
-- calls.
Set_Expression
- (Original_Node (Subprogram_Spec (Def_Id)),
- Make_Expr_Copy);
+ (Original_Node (Subprogram_Spec (Def_Id)), Make_Expr_Copy);
-- Mark static expression functions as inlined, to ensure
-- that even calls with nonstatic actuals will be inlined.
Conformant : Boolean;
Desig_View : Entity_Id := Empty;
Exch_Views : Elist_Id := No_Elist;
- Mask_Types : Elist_Id := No_Elist;
Prot_Typ : Entity_Id := Empty;
Spec_Decl : Node_Id := Empty;
Spec_Id : Entity_Id := Empty;
-- Determine whether subprogram Subp_Id is a primitive of a concurrent
-- type that implements an interface and has a private view.
- function Mask_Unfrozen_Types (Spec_Id : Entity_Id) return Elist_Id;
- -- N is the body generated for an expression function that is not a
- -- completion and Spec_Id the defining entity of its spec. Mark all
- -- the not-yet-frozen types referenced by the simple return statement
- -- of the function as formally frozen.
-
procedure Move_Pragmas (From : Node_Id; To : Node_Id);
-- Find all suitable source pragmas at the top of subprogram body
-- From's declarations and move them after arbitrary node To.
-- of an entity, we mark the entity as set in source to suppress any
-- warning on the stylized use of function stubs with a dummy return.
- procedure Unmask_Unfrozen_Types (Unmask_List : Elist_Id);
- -- Undo the transformation done by Mask_Unfrozen_Types
-
procedure Verify_Overriding_Indicator;
-- If there was a previous spec, the entity has been entered in the
-- current scope previously. If the body itself carries an overriding
return False;
end Is_Private_Concurrent_Primitive;
- -------------------------
- -- Mask_Unfrozen_Types --
- -------------------------
-
- function Mask_Unfrozen_Types (Spec_Id : Entity_Id) return Elist_Id is
- Result : Elist_Id := No_Elist;
-
- function Mask_Type_Refs (Node : Node_Id) return Traverse_Result;
- -- Mask all types referenced in the subtree rooted at Node as
- -- formally frozen.
-
- --------------------
- -- Mask_Type_Refs --
- --------------------
-
- function Mask_Type_Refs (Node : Node_Id) return Traverse_Result is
- procedure Mask_Type (Typ : Entity_Id);
- -- Mask a given type as formally frozen when outside the current
- -- scope, or else freeze the type.
-
- ---------------
- -- Mask_Type --
- ---------------
-
- procedure Mask_Type (Typ : Entity_Id) is
- begin
- -- Skip Itypes created by the preanalysis
-
- if Is_Itype (Typ)
- and then Scope_Within_Or_Same (Scope (Typ), Spec_Id)
- then
- return;
- end if;
-
- if not Is_Frozen (Typ) then
- if Scope (Typ) /= Current_Scope then
- Set_Is_Frozen (Typ);
- Append_New_Elmt (Typ, Result);
- else
- Freeze_Before (N, Typ);
- end if;
- end if;
- end Mask_Type;
-
- -- Start of processing for Mask_Type_Refs
-
- begin
- if Is_Entity_Name (Node) and then Present (Entity (Node)) then
- Mask_Type (Etype (Entity (Node)));
-
- if Ekind (Entity (Node)) in E_Component | E_Discriminant then
- Mask_Type (Scope (Entity (Node)));
- end if;
-
- elsif Nkind (Node) in N_Aggregate | N_Null | N_Type_Conversion
- and then Present (Etype (Node))
- then
- Mask_Type (Etype (Node));
- end if;
-
- return OK;
- end Mask_Type_Refs;
-
- procedure Mask_References is new Traverse_Proc (Mask_Type_Refs);
-
- -- Local variables
-
- Return_Stmt : constant Node_Id :=
- First (Statements (Handled_Statement_Sequence (N)));
-
- -- Start of processing for Mask_Unfrozen_Types
-
- begin
- pragma Assert (Nkind (Return_Stmt) = N_Simple_Return_Statement);
-
- Mask_References (Expression (Return_Stmt));
-
- return Result;
- end Mask_Unfrozen_Types;
-
------------------
-- Move_Pragmas --
------------------
end if;
end Set_Trivial_Subprogram;
- ---------------------------
- -- Unmask_Unfrozen_Types --
- ---------------------------
-
- procedure Unmask_Unfrozen_Types (Unmask_List : Elist_Id) is
- Elmt : Elmt_Id := First_Elmt (Unmask_List);
-
- begin
- while Present (Elmt) loop
- Set_Is_Frozen (Node (Elmt), False);
- Next_Elmt (Elmt);
- end loop;
- end Unmask_Unfrozen_Types;
-
---------------------------------
-- Verify_Overriding_Indicator --
---------------------------------
Ignore_SPARK_Mode_Pragmas_In_Instance;
-- Save the Ghost and SPARK mode-related data to restore on exit
+ Saved_In_Inlined_Body : Boolean;
+
-- Start of processing for Analyze_Subprogram_Body_Helper
begin
-- the mode now to ensure that any nodes generated during analysis
-- and expansion are properly marked as Ghost.
- Mark_And_Set_Ghost_Body (N, Spec_Id);
+ if Is_Expression_Function (Spec_Id) then
+ Mark_And_Set_Ghost_Body_Of_Expression_Function (N, Spec_Id);
+ else
+ Mark_And_Set_Ghost_Body (N, Spec_Id);
+ end if;
-- If the body completes the initial declaration of a compilation
-- unit which is subject to pragma Elaboration_Checks, set the
Compute_Returns_By_Ref (Spec_Id);
end if;
- -- In general, the spec will be frozen when we start analyzing the
- -- body. However, for internally generated operations, such as
- -- wrapper functions for inherited operations with controlling
- -- results, the spec may not have been frozen by the time we expand
- -- the freeze actions that include the bodies. In particular, extra
- -- formals for accessibility or for return-in-place may need to be
- -- generated. Freeze nodes, if any, are inserted before the current
- -- body. These freeze actions are also needed in Compile_Only mode to
- -- enable the proper back-end type annotations.
- -- They are necessary in any case to ensure proper elaboration order
- -- in gigi.
-
- if From_Expression_Function
- and then not Has_Completion (Spec_Id)
- and then Serious_Errors_Detected = 0
- and then (Expander_Active
- or else Operating_Mode = Check_Semantics
- or else Is_Ignored_Ghost_Entity_In_Codegen (Spec_Id))
- then
- -- The body generated for an expression function that is not a
- -- completion is a freeze point neither for the profile nor for
- -- anything else. That's why, in order to prevent any freezing
- -- during analysis, we need to mask types declared outside the
- -- expression (and in an outer scope) that are not yet frozen.
- -- This also needs to be done in the case of an ignored Ghost
- -- expression function, where the expander isn't active.
-
- -- A further complication arises if the expression function is
- -- a primitive operation of a tagged type: in that case the
- -- function entity must be frozen before the dispatch table for
- -- the type is constructed, so it will be frozen like other local
- -- entities, at the end of the current scope.
+ -- In most cases the spec is frozen when we start analyzing the body.
+ -- However, for some internally generated operations such as wrapper
+ -- functions for inherited operations with a controlling result, and
+ -- for expression functions, it has not necessarily been frozen yet.
+ -- In particular, extra formals for accessibility or build-in-place
+ -- return purposes may still need to be generated. Freeze nodes are
+ -- inserted before the body, and are necessary to ensure the proper
+ -- elaboration order in the code generator.
- if not Is_Dispatching_Operation (Spec_Id) then
- Set_Is_Frozen (Spec_Id);
- end if;
+ -- A further complication arises when the expression function is a
+ -- primitive operation of a tagged type: in that case the function
+ -- entity must be frozen before the dispatch table for the type is
+ -- built, but this freezing must not freeze the tagged type itself.
- Mask_Types := Mask_Unfrozen_Types (Spec_Id);
-
- elsif not Is_Frozen (Spec_Id)
- and then Serious_Errors_Detected = 0
- then
+ if not Is_Frozen (Spec_Id) and then Serious_Errors_Detected = 0 then
Set_Has_Delayed_Freeze (Spec_Id);
Create_Extra_Formals (Spec_Id, Related_Nod => N);
- Freeze_Before (N, Spec_Id);
+ Freeze_Before (N, Spec_Id,
+ Do_Freeze_Profile => not Is_Dispatching_Operation (Spec_Id));
end if;
end if;
then
Conformant := True;
- -- Finally, a body generated for an expression function copies
+ -- The body generated for a stand-alone expression function copies
-- the profile of the function and no check is needed either.
elsif Is_Expression_Function (Spec_Id) then
Build_Subprogram_Instance_Renamings (N, Current_Scope);
end if;
- Push_Scope (Spec_Id);
+ -- The body of a stand-alone expression function may be generated
+ -- out of context like an inlined body, so we set In_Inlined_Body
+ -- when analyzing it to bypass visibility constraints on the types
+ -- of operators (the constraints have already been checked during
+ -- the preanalysis of the expression but, unlike resolution per se
+ -- which is not redone, they are checked again to set the Etype).
+
+ if Is_Expression_Function (Spec_Id) then
+ Saved_In_Inlined_Body := In_Inlined_Body;
+ In_Inlined_Body := True;
+
+ -- Moreover, if the expression function was declared in the
+ -- private part of its package, we need to temporarily make
+ -- the full view of the private types visible.
+
+ if Scope (Spec_Id) /= Current_Scope
+ and then In_Private_Part (Spec_Id)
+ then
+ declare
+ S : constant Entity_Id := Scope (Spec_Id);
+
+ Ent : Entity_Id;
+
+ begin
+ Ent := First_Entity (S);
+ while Present (Ent)
+ and then Ent /= First_Private_Entity (S)
+ loop
+ if Is_Private_Base_Type (Ent)
+ and then Present (Full_View (Ent))
+ and then Comes_From_Source (Full_View (Ent))
+ and then Scope (Full_View (Ent)) = Scope (Ent)
+ and then Ekind (Full_View (Ent)) /= E_Incomplete_Type
+ then
+ Exchange_Declarations (Ent);
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end;
+ end if;
-- Make sure that the subprogram is immediately visible. For
-- child units that have no separate spec this is indispensable.
-- Otherwise it is safe albeit redundant.
- Set_Is_Immediately_Visible (Spec_Id);
+ else
+ Set_Is_Immediately_Visible (Spec_Id);
+ end if;
+
+ Push_Scope (Spec_Id);
end if;
Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
Update_Use_Clause_Chain;
End_Scope;
+ -- Cleanup for the body of a stand-alone expression function
+
+ if Present (Spec_Id) and then Is_Expression_Function (Spec_Id) then
+ In_Inlined_Body := Saved_In_Inlined_Body;
+
+ if Scope (Spec_Id) /= Current_Scope
+ and then In_Private_Part (Spec_Id)
+ then
+ declare
+ S : constant Entity_Id := Scope (Spec_Id);
+
+ Ent : Entity_Id;
+
+ begin
+ Ent := First_Private_Entity (S);
+ while Present (Ent) loop
+ if Is_Private_Base_Type (Ent)
+ and then Present (Full_View (Ent))
+ then
+ Exchange_Declarations (Ent);
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end;
+ end if;
+ end if;
+
-- If we are compiling an entry wrapper, remove the enclosing
-- synchronized object from the stack.
Restore_Limited_Views (Exch_Views);
end if;
- if Present (Mask_Types) then
- Unmask_Unfrozen_Types (Mask_Types);
- end if;
-
if Present (Desig_View) then
Set_Directly_Designated_Type (Etype (Spec_Id), Desig_View);
end if;
else
Report_Conflict (S, E);
+
+ -- Prevent cascaded error about missing body
+
+ if Is_Package_Or_Generic_Package (E) then
+ Set_Has_Completion (E);
+ end if;
+
return;
end if;
-- one entity on its visibility chain, and recurses on the visible part if
-- the entity is an inner package.
- function Is_Private_Base_Type (E : Entity_Id) return Boolean;
- -- True for a private type that is not a subtype
-
function Is_Visible_Dependent (Dep : Entity_Id) return Boolean;
-- If the private dependent is a private type whose full view is derived
-- from the parent type, its full properties are revealed only if we are in
procedure Install_Visible_Declarations (P : Entity_Id);
procedure Install_Private_Declarations (P : Entity_Id);
-
-- On entrance to a package body, make declarations in package spec
-- immediately visible.
--
-- but is deferred until the compilation of the private part of the
-- child for public child packages.
+ function Is_Private_Base_Type (E : Entity_Id) return Boolean;
+ -- True for a private type that is not a subtype
+
function Unit_Requires_Body
(Pack_Id : Entity_Id;
Do_Abstract_States : Boolean := False) return Boolean;
Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec);
end if;
- -- AI12-0132: a renames-as-body freezes the expression of any
- -- expression function that it renames.
+ -- RM 13.14(5.2/4): At the occurrence of a renames-as-body whose
+ -- name denotes an expression function, the return expression of
+ -- the expression function causes freezing.
- if Is_Entity_Name (Nam)
+ if Comes_From_Source (N)
+ and then Is_Entity_Name (Nam)
and then Is_Expression_Function (Entity (Nam))
and then not Inside_A_Generic
then
- Freeze_Expr_Types
- (Def_Id => Entity (Nam),
- Typ => Etype (Entity (Nam)),
- Expr =>
- Expression
- (Original_Node (Unit_Declaration_Node (Entity (Nam)))),
- N => N);
+ Freeze_Expression (Nam);
end if;
-- Normal subprogram renaming (not renaming as body)
-- default expression mode (the Freeze_Expression routine tests this
-- flag and only freezes static types if it is set).
- -- Ada 2012 (AI05-177): The declaration of an expression function
- -- does not cause freezing, but we never reach here in that case.
- -- Here we are resolving the corresponding expanded body, so we do
- -- need to perform normal freezing.
-
-- As elsewhere we do not emit freeze node within a generic.
if not Inside_A_Generic then
-- conditions of subsequent functions or expression functions. Such
-- calls do not freeze when they appear within generated bodies,
-- (including the body of another expression function) which would
- -- place the freeze node in the wrong scope. An expression function
- -- is frozen in the usual fashion, by the appearance of a real body,
- -- or at the end of a declarative part. However an implicit call to
+ -- place the freeze node in the wrong scope. But an implicit call to
-- an expression function may appear when it is part of a default
-- expression in a call to an initialization procedure, and must be
-- frozen now, even if the body is inserted at a later point.
- -- Otherwise, the call freezes the expression if expander is active,
- -- for example as part of an object declaration.
if Is_Entity_Name (Subp)
and then not In_Spec_Expression
and then not Is_Expression_Function_Or_Completion (Current_Scope)
- and then not (Chars (Current_Scope) = Name_uWrapped_Statements
- and then Is_Expression_Function_Or_Completion
- (Scope (Current_Scope)))
- and then
- (not Is_Expression_Function_Or_Completion (Entity (Subp))
- or else Expander_Active)
+ and then not
+ (Chars (Current_Scope) = Name_uWrapped_Statements
+ and then
+ Is_Expression_Function_Or_Completion (Scope (Current_Scope)))
then
if Is_Expression_Function (Entity (Subp)) then
- -- Force freeze of expression function in call
+ -- Force freezing of expression function in call
Set_Comes_From_Source (Subp, True);
Set_Must_Not_Freeze (Subp, False);
procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
begin
+ -- The immediate case is an incomplete type
+
if Ekind (T) = E_Incomplete_Type then
-- Ada 2005 (AI-50217): If the type is available through a limited
("premature usage of incomplete}", N, First_Subtype (T));
end if;
- -- Need comments for these tests ???
+ -- The other case is a type with a private component (including itself)
+ -- that has not yet received a full declaration. But we exclude formal
+ -- types, as well as references in generic units to entities declared
+ -- outside of them, and all references in spec expressions.
elsif Has_Private_Component (T)
and then not Is_Generic_Type (Root_Type (T))
+ and then (not Is_Generic_Unit (Current_Scope)
+ or else Scope_Within_Or_Same (Scope (T), Current_Scope))
and then not In_Spec_Expression
then
-- Special case: if T is the anonymous type created for a single
Subp_Decl := Unit_Declaration_Node (Corresponding_Body (Subp_Decl));
end if;
- return Original_Node (Expression (Original_Node (Subp_Decl)));
+ return Expression (Original_Node (Subp_Decl));
end Expression_Of_Expression_Function;
-------------------------------
and then Present (Subprogram_Body (Subp))
and then Was_Expression_Function (Subprogram_Body (Subp))
then
- Return_Expr := Expression_Of_Expression_Function (Subp);
+ Return_Expr :=
+ Original_Node (Expression_Of_Expression_Function (Subp));
-- The returned object must not have a qualified expression and its
-- nominal subtype must be statically compatible with the result
projects / thirdparty / gcc.git / commitdiff
