+2017-09-08 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.ads (Make_Build_In_Place_Iface_Call_In_Allocator): New
+ subprogram.
+ (Make_Build_In_Place_Iface_Call_In_Anonymous_Context): New subprogram.
+ (Make_Build_In_Place_Iface_Call_In_Object_Declaration): New
+ subprogram.
+ (Unqual_BIP_Iface_Function_Call): New subprogram.
+ * exp_ch6.adb (Replace_Renaming_Declaration_Id): New
+ subprogram containing code that was previously inside
+ Make_Build_In_Place_Call_In_Object_Declaration since it is also
+ required for one of the new subprograms.
+ (Expand_Actuals):
+ Invoke Make_Build_In_Place_Iface_Call_In_Anonymous_Context
+ (Expand_N_Extended_Return_Statement): Extend the
+ cases covered by an assertion on expected BIP object
+ declarations.
+ (Make_Build_In_Place_Call_In_Assignment):
+ Removing unused code; found working on this ticket.
+ (Make_Build_In_Place_Call_In_Object_Declaration): Move the code
+ that replaces the internal name of the renaming declaration
+ into the new subprogram Replace_Renaming_Declaration_Id.
+ (Make_Build_In_Place_Iface_Call_In_Allocator): New subprogram.
+ (Make_Build_In_Place_Iface_Call_In_Anonymous_Context):
+ New subprogram.
+ (Make_Build_In_Place_Iface_Call_In_Object_Declaration): New
+ subprogram.
+ (Unqual_BIP_Iface_Function_Call): New subprogram.
+ * exp_ch3.adb (Expand_N_Object_Declaration): Invoke the new
+ subprogram Make_Build_In_Place_Iface_Call_In_Object_Declaration.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Invoke the new
+ subprogram Make_Build_In_Place_Iface_Call_In_Anonymous_Context.
+ * exp_ch4.adb (Expand_Allocator_Expression): Invoke the new
+ subprogram Make_Build_In_Place_Iface_Call_In_Allocator.
+ (Expand_N_Indexed_Component): Invoke the new subprogram
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context.
+ (Expand_N_Selected_Component): Invoke the new subprogram
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context.
+ (Expand_N_Slice): Invoke the new subprogram
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context.
+ * exp_ch8.adb (Expand_N_Object_Renaming_Declaration):
+ Invoke the new subprogram
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context.
+
+2017-09-08 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Expand_Interface_Conversion): Fix handling of
+ access to interface types. Remove also the accessibility check.
+
+2017-09-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch6.adb (Freeze_Expr_Types): Really freeze
+ all the types that are referenced by the expression.
+ (Analyze_Expression_Function): Call Freeze_Expr_Types for
+ a completion instead of manually freezing the type of the
+ expression.
+ (Analyze_Subprogram_Body_Helper): Do not call Freeze_Expr_Types here.
+
+2017-09-08 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_prag.adb (Replace_Discriminals_Of_Protected_Op):
+ New procedure, auxiliary to Expand_Pragma_Check, to handle
+ references to the discriminants of a protected type within a
+ precondition of a protected operation. This is needed because
+ the original precondition has been analyzed in the context of
+ the protected declaration, but in the body of the operation
+ references to the discriminants have been replaved by references
+ to the discriminants of the target object, and these references
+ are only created when expanding the protected body.
+
2017-09-08 Yannick Moy <moy@adacore.com>
* sem_prag.adb (Analyze_Pragma): Issue more precise error messages on
function Underlying_Type (Id : E) return E is
begin
- -- For record_with_private the underlying type is always the direct
- -- full view. Never try to take the full view of the parent it
- -- doesn't make sense.
+ -- For record_with_private the underlying type is always the direct full
+ -- view. Never try to take the full view of the parent it does not make
+ -- sense.
if Ekind (Id) = E_Record_Type_With_Private then
return Full_View (Id);
- -- If we have a class-wide type that comes from the limited view then
- -- we return the Underlying_Type of its nonlimited view.
+ -- If we have a class-wide type that comes from the limited view then we
+ -- return the Underlying_Type of its nonlimited view.
elsif Ekind (Id) = E_Class_Wide_Type
and then From_Limited_With (Id)
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.
+ -- If we have an incomplete or private type with a full view, then we
+ -- return the Underlying_Type of this full view.
if Present (Full_View (Id)) then
if Id = Full_View (Id) then
elsif Etype (Id) /= Id then
return Underlying_Type (Etype (Id));
- -- Otherwise we have an incomplete or private type that has
- -- no full view, which means that we have not encountered the
- -- completion, so return Empty to indicate the underlying type
- -- is not yet known.
+ -- Otherwise we have an incomplete or private type that has no full
+ -- view, which means that we have not encountered the completion, so
+ -- return Empty to indicate the underlying type is not yet known.
else
return Empty;
and then Is_Build_In_Place_Function_Call (Pref)
then
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
+ -- containing build-in-place function calls whose returned object covers
+ -- interface types.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (Pref))
+ then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
end if;
-- If prefix is a protected type name, this is a reference to the
return;
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for
+ -- expressions containing a build-in-place function call whose
+ -- returned object covers interface types, and Expr_Q has calls to
+ -- Ada.Tags.Displace to displace the pointer to the returned build-
+ -- in-place object to reference the secondary dispatch table of a
+ -- covered interface type.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
+ then
+ Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q);
+
+ -- The previous call expands the expression initializing the
+ -- built-in-place object into further code that will be analyzed
+ -- later. No further expansion needed here.
+
+ return;
+
-- Ada 2005 (AI-251): Rewrite the expression that initializes a
-- class-wide interface object to ensure that we copy the full
-- object, unless we are targetting a VM where interfaces are handled
Make_Build_In_Place_Call_In_Allocator (N, Exp);
Apply_Accessibility_Check (N, Built_In_Place => True);
return;
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for
+ -- expressions containing a build-in-place function call whose
+ -- returned object covers interface types, and Expr has calls to
+ -- Ada.Tags.Displace to displace the pointer to the returned build-
+ -- in-place object to reference the secondary dispatch table of a
+ -- covered interface type.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (Exp))
+ then
+ Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp);
+ Apply_Accessibility_Check (N, Built_In_Place => True);
+ return;
end if;
-- Actions inserted before:
and then Is_Build_In_Place_Function_Call (P)
then
Make_Build_In_Place_Call_In_Anonymous_Context (P);
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
+ -- containing build-in-place function calls whose returned object covers
+ -- interface types.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (P))
+ then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
end if;
-- If the prefix is an access type, then we unconditionally rewrite if
and then Is_Build_In_Place_Function_Call (P)
then
Make_Build_In_Place_Call_In_Anonymous_Context (P);
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
+ -- containing build-in-place function calls whose returned object covers
+ -- interface types.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (P))
+ then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
end if;
-- Gigi cannot handle unchecked conversions that are the prefix of a
and then Is_Build_In_Place_Function_Call (Pref)
then
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
+ -- containing build-in-place function calls whose returned object covers
+ -- interface types.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (Pref))
+ then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
end if;
-- The remaining case to be handled is packed slices. We can leave
end if;
else
-
- -- Initial value is smallest value in predicate.
+ -- Initial value is smallest value in predicate
if Is_Itype (Ltype) then
D :=
end if;
S :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Loop_Id, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ltype, Loc),
- Attribute_Name => Name_Next,
- Expressions => New_List (
- New_Occurrence_Of (Loop_Id, Loc))));
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Loop_Id, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ltype, Loc),
+ Attribute_Name => Name_Next,
+ Expressions => New_List (
+ New_Occurrence_Of (Loop_Id, Loc))));
Set_Suppress_Assignment_Checks (S);
end;
with Einfo; use Einfo;
with Errout; use Errout;
with Elists; use Elists;
+with Expander; use Expander;
with Exp_Aggr; use Exp_Aggr;
with Exp_Atag; use Exp_Atag;
with Exp_Ch2; use Exp_Ch2;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Inline; use Inline;
+with Itypes; use Itypes;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
-- Insert the Post_Call list previously produced by routine Expand_Actuals
-- or Expand_Call_Helper into the tree.
+ procedure Replace_Renaming_Declaration_Id
+ (New_Decl : Node_Id;
+ Orig_Decl : Node_Id);
+ -- Replace the internal identifier of the new renaming declaration New_Decl
+ -- with the identifier of its original declaration Orig_Decl exchanging the
+ -- entities containing their defining identifiers to ensure the correct
+ -- replacement of the object declaration by the object renaming declaration
+ -- to avoid homograph conflicts (since the object declaration's defining
+ -- identifier was already entered in the current scope). The Next_Entity
+ -- links of the two entities are also swapped since the entities are part
+ -- of the return scope's entity list and the list structure would otherwise
+ -- be corrupted. The homonym chain is preserved as well.
+
procedure Rewrite_Function_Call_For_C (N : Node_Id);
-- When generating C code, replace a call to a function that returns an
-- array into the generated procedure with an additional out parameter.
if Is_Build_In_Place_Function_Call (Actual) then
Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for
+ -- actuals containing build-in-place function calls whose returned
+ -- object covers interface types.
+
+ elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual);
end if;
Apply_Constraint_Check (Actual, E_Formal);
then
pragma Assert
(Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration
- and then Is_Build_In_Place_Function_Call
- (Expression (Original_Node (Ret_Obj_Decl))));
+ and then
+
+ -- It is a regular BIP object declaration
+
+ (Is_Build_In_Place_Function_Call
+ (Expression (Original_Node (Ret_Obj_Decl)))
+
+ -- It is a BIP object declaration that displaces the pointer
+ -- to the object to reference a convered interface type.
+
+ or else
+ Present (Unqual_BIP_Iface_Function_Call
+ (Expression (Original_Node (Ret_Obj_Decl))))));
-- Return the build-in-place result by reference
Ptr_Typ_Decl : Node_Id;
New_Expr : Node_Id;
Result_Subt : Entity_Id;
- Target : Node_Id;
begin
-- If the call has already been processed to add build-in-place actuals
Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl);
Rewrite (Assign, Make_Null_Statement (Loc));
-
- -- Retrieve the target of the assignment
-
- if Nkind (Lhs) = N_Selected_Component then
- Target := Selector_Name (Lhs);
- elsif Nkind (Lhs) = N_Type_Conversion then
- Target := Expression (Lhs);
- else
- Target := Lhs;
- end if;
-
- -- If we are assigning to a return object or this is an expression of
- -- an extension aggregate, the target should either be an identifier
- -- or a simple expression. All other cases imply a different scenario.
-
- if Nkind (Target) in N_Has_Entity then
- Target := Entity (Target);
- else
- return;
- end if;
end Make_Build_In_Place_Call_In_Assignment;
----------------------------------------------------
end if;
Analyze (Obj_Decl);
-
- -- Replace the internal identifier of the renaming declaration's
- -- entity with identifier of the original object entity. We also
- -- have to exchange the entities containing their defining
- -- identifiers to ensure the correct replacement of the object
- -- declaration by the object renaming declaration to avoid
- -- homograph conflicts (since the object declaration's defining
- -- identifier was already entered in current scope). The
- -- Next_Entity links of the two entities also have to be swapped
- -- since the entities are part of the return scope's entity list
- -- and the list structure would otherwise be corrupted. Finally,
- -- the homonym chain must be preserved as well.
-
- declare
- Ren_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
- Next_Id : constant Entity_Id := Next_Entity (Ren_Id);
-
- begin
- Set_Chars (Ren_Id, Chars (Obj_Def_Id));
-
- -- Swap next entity links in preparation for exchanging
- -- entities.
-
- Set_Next_Entity (Ren_Id, Next_Entity (Obj_Def_Id));
- Set_Next_Entity (Obj_Def_Id, Next_Id);
- Set_Homonym (Ren_Id, Homonym (Obj_Def_Id));
-
- Exchange_Entities (Ren_Id, Obj_Def_Id);
-
- -- Preserve source indication of original declaration, so that
- -- xref information is properly generated for the right entity.
-
- Preserve_Comes_From_Source (Obj_Decl, Original_Node (Obj_Decl));
- Preserve_Comes_From_Source
- (Obj_Def_Id, Original_Node (Obj_Decl));
-
- Set_Comes_From_Source (Ren_Id, False);
- end;
+ Replace_Renaming_Declaration_Id
+ (Obj_Decl, Original_Node (Obj_Decl));
end if;
end;
end if;
end Make_Build_In_Place_Call_In_Object_Declaration;
+ -------------------------------------------------
+ -- Make_Build_In_Place_Iface_Call_In_Allocator --
+ -------------------------------------------------
+
+ procedure Make_Build_In_Place_Iface_Call_In_Allocator
+ (Allocator : Node_Id;
+ Function_Call : Node_Id)
+ is
+ BIP_Func_Call : constant Node_Id :=
+ Unqual_BIP_Iface_Function_Call (Function_Call);
+ Loc : constant Source_Ptr := Sloc (Function_Call);
+
+ Anon_Type : Entity_Id;
+ Tmp_Decl : Node_Id;
+ Tmp_Id : Entity_Id;
+
+ begin
+ -- No action of the call has already been processed
+
+ if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
+ return;
+ end if;
+
+ Tmp_Id := Make_Temporary (Loc, 'D');
+
+ -- Insert a temporary before N initialized with the BIP function call
+ -- without its enclosing type conversions and analyze it without its
+ -- expansion. This temporary facilitates us reusing the BIP machinery,
+ -- which takes care of adding the extra build-in-place actuals and
+ -- transforms this object declaration into an object renaming
+ -- declaration.
+
+ Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call);
+ Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call));
+ Set_Etype (Anon_Type, Anon_Type);
+
+ Tmp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tmp_Id,
+ Object_Definition => New_Occurrence_Of (Anon_Type, Loc),
+ Expression =>
+ Make_Allocator (Loc,
+ Expression =>
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
+ Expression => New_Copy_Tree (BIP_Func_Call))));
+
+ Expander_Mode_Save_And_Set (False);
+ Insert_Action (Allocator, Tmp_Decl);
+ Expander_Mode_Restore;
+
+ Make_Build_In_Place_Call_In_Allocator
+ (Allocator => Expression (Tmp_Decl),
+ Function_Call => Expression (Expression (Tmp_Decl)));
+
+ Rewrite (Allocator, New_Occurrence_Of (Tmp_Id, Loc));
+ end Make_Build_In_Place_Iface_Call_In_Allocator;
+
+ ---------------------------------------------------------
+ -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context --
+ ---------------------------------------------------------
+
+ procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context
+ (Function_Call : Node_Id)
+ is
+ BIP_Func_Call : constant Node_Id :=
+ Unqual_BIP_Iface_Function_Call (Function_Call);
+ Loc : constant Source_Ptr := Sloc (Function_Call);
+
+ Tmp_Decl : Node_Id;
+ Tmp_Id : Entity_Id;
+
+ begin
+ -- No action of the call has already been processed
+
+ if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
+ return;
+ end if;
+
+ pragma Assert (Needs_Finalization (Etype (BIP_Func_Call)));
+
+ -- Insert a temporary before the call initialized with function call to
+ -- reuse the BIP machinery which takes care of adding the extra build-in
+ -- place actuals and transforms this object declaration into an object
+ -- renaming declaration.
+
+ Tmp_Id := Make_Temporary (Loc, 'D');
+
+ Tmp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tmp_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Function_Call), Loc),
+ Expression => Relocate_Node (Function_Call));
+
+ Expander_Mode_Save_And_Set (False);
+ Insert_Action (Function_Call, Tmp_Decl);
+ Expander_Mode_Restore;
+
+ Make_Build_In_Place_Iface_Call_In_Object_Declaration
+ (Obj_Decl => Tmp_Decl,
+ Function_Call => Expression (Tmp_Decl));
+ end Make_Build_In_Place_Iface_Call_In_Anonymous_Context;
+
+ ----------------------------------------------------------
+ -- Make_Build_In_Place_Iface_Call_In_Object_Declaration --
+ ----------------------------------------------------------
+
+ procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration
+ (Obj_Decl : Node_Id;
+ Function_Call : Node_Id)
+ is
+ BIP_Func_Call : constant Node_Id :=
+ Unqual_BIP_Iface_Function_Call (Function_Call);
+ Loc : constant Source_Ptr := Sloc (Function_Call);
+ Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
+
+ Tmp_Decl : Node_Id;
+ Tmp_Id : Entity_Id;
+
+ begin
+ -- No action of the call has already been processed
+
+ if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
+ return;
+ end if;
+
+ Tmp_Id := Make_Temporary (Loc, 'D');
+
+ -- Insert a temporary before N initialized with the BIP function call
+ -- without its enclosing type conversions and analyze it without its
+ -- expansion. This temporary facilitates us reusing the BIP machinery,
+ -- which takes care of adding the extra build-in-place actuals and
+ -- transforms this object declaration into an object renaming
+ -- declaration.
+
+ Tmp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tmp_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
+ Expression => New_Copy_Tree (BIP_Func_Call));
+
+ Expander_Mode_Save_And_Set (False);
+ Insert_Action (Obj_Decl, Tmp_Decl);
+ Expander_Mode_Restore;
+
+ Make_Build_In_Place_Call_In_Object_Declaration
+ (Obj_Decl => Tmp_Decl,
+ Function_Call => Expression (Tmp_Decl));
+
+ pragma Assert (Nkind (Tmp_Decl) = N_Object_Renaming_Declaration);
+
+ -- Replace the original build-in-place function call by a reference to
+ -- the resulting temporary object renaming declaration. In this way,
+ -- all the interface conversions performed in the original Function_Call
+ -- on the build-in-place object are preserved.
+
+ Rewrite (BIP_Func_Call, New_Occurrence_Of (Tmp_Id, Loc));
+
+ -- Replace the original object declaration by an internal object
+ -- renaming declaration. This leaves the generated code more clean (the
+ -- build-in-place function call in an object renaming declaration and
+ -- displacements of the pointer to the build-in-place object in another
+ -- renaming declaration) and allows us to invoke the routine that takes
+ -- care of replacing the identifier of the renaming declaration (routine
+ -- originally developed for the regular build-in-place management).
+
+ Rewrite (Obj_Decl,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'D'),
+ Subtype_Mark => New_Occurrence_Of (Etype (Obj_Id), Loc),
+ Name => Function_Call));
+ Analyze (Obj_Decl);
+
+ Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl));
+ end Make_Build_In_Place_Iface_Call_In_Object_Declaration;
+
--------------------------------------------
-- Make_CPP_Constructor_Call_In_Allocator --
--------------------------------------------
end if;
end Needs_Result_Accessibility_Level;
+ -------------------------------------
+ -- Replace_Renaming_Declaration_Id --
+ -------------------------------------
+
+ procedure Replace_Renaming_Declaration_Id
+ (New_Decl : Node_Id;
+ Orig_Decl : Node_Id)
+ is
+ New_Id : constant Entity_Id := Defining_Entity (New_Decl);
+ Orig_Id : constant Entity_Id := Defining_Entity (Orig_Decl);
+
+ begin
+ Set_Chars (New_Id, Chars (Orig_Id));
+
+ -- Swap next entity links in preparation for exchanging entities
+
+ declare
+ Next_Id : constant Entity_Id := Next_Entity (New_Id);
+ begin
+ Set_Next_Entity (New_Id, Next_Entity (Orig_Id));
+ Set_Next_Entity (Orig_Id, Next_Id);
+ end;
+
+ Set_Homonym (New_Id, Homonym (Orig_Id));
+ Exchange_Entities (New_Id, Orig_Id);
+
+ -- Preserve source indication of original declaration, so that xref
+ -- information is properly generated for the right entity.
+
+ Preserve_Comes_From_Source (New_Decl, Orig_Decl);
+ Preserve_Comes_From_Source (Orig_Id, Orig_Decl);
+
+ Set_Comes_From_Source (New_Id, False);
+ end Replace_Renaming_Declaration_Id;
+
---------------------------------
-- Rewrite_Function_Call_For_C --
---------------------------------
end loop;
end Set_Enclosing_Sec_Stack_Return;
+ ------------------------------------
+ -- Unqual_BIP_Iface_Function_Call --
+ ------------------------------------
+
+ function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id is
+ Has_Pointer_Displacement : Boolean := False;
+ On_Object_Declaration : Boolean := False;
+ -- Remember if processing the renaming expressions on recursion we have
+ -- traversed an object declaration, since we can traverse many object
+ -- declaration renamings but just one regular object declaration.
+
+ function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id;
+ -- Search for a build-in-place function call skipping any qualification
+ -- including qualified expressions, type conversions, references, calls
+ -- to displace the pointer to the object, and renamings. Return Empty if
+ -- no build-in-place function call is found.
+
+ ------------------------------
+ -- Unqual_BIP_Function_Call --
+ ------------------------------
+
+ function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id is
+ begin
+ -- Recurse to handle case of multiple levels of qualification and/or
+ -- conversion.
+
+ if Nkind_In (Expr, N_Qualified_Expression,
+ N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ then
+ return Unqual_BIP_Function_Call (Expression (Expr));
+
+ -- Recurse to handle case of multiple levels of references and
+ -- explicit dereferences.
+
+ elsif Nkind_In (Expr, N_Attribute_Reference,
+ N_Explicit_Dereference,
+ N_Reference)
+ then
+ return Unqual_BIP_Function_Call (Prefix (Expr));
+
+ -- Recurse on object renamings
+
+ elsif Nkind (Expr) = N_Identifier
+ and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
+ and then Nkind (Parent (Entity (Expr))) =
+ N_Object_Renaming_Declaration
+ and then Present (Renamed_Object (Entity (Expr)))
+ then
+ return Unqual_BIP_Function_Call (Renamed_Object (Entity (Expr)));
+
+ -- Recurse on the initializing expression of the first reference of
+ -- an object declaration.
+
+ elsif not On_Object_Declaration
+ and then Nkind (Expr) = N_Identifier
+ and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
+ and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
+ and then Present (Expression (Parent (Entity (Expr))))
+ then
+ On_Object_Declaration := True;
+ return
+ Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr))));
+
+ -- Recurse to handle calls to displace the pointer to the object to
+ -- reference a secondary dispatch table.
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Nkind (Name (Expr)) in N_Has_Entity
+ and then RTU_Loaded (Ada_Tags)
+ and then RTE_Available (RE_Displace)
+ and then Is_RTE (Entity (Name (Expr)), RE_Displace)
+ then
+ Has_Pointer_Displacement := True;
+ return
+ Unqual_BIP_Function_Call (First (Parameter_Associations (Expr)));
+
+ -- Normal case: check if the inner expression is a BIP function call
+ -- and the pointer to the object is displaced.
+
+ elsif Has_Pointer_Displacement
+ and then Is_Build_In_Place_Function_Call (Expr)
+ then
+ return Expr;
+
+ else
+ return Empty;
+ end if;
+ end Unqual_BIP_Function_Call;
+
+ -- Start of processing for Unqual_BIP_Iface_Function_Call
+
+ begin
+ return Unqual_BIP_Function_Call (Expr);
+ end Unqual_BIP_Iface_Function_Call;
+
end Exp_Ch6;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression
-- node applied to such a function call.
+ procedure Make_Build_In_Place_Iface_Call_In_Allocator
+ (Allocator : Node_Id;
+ Function_Call : Node_Id);
+ -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that
+ -- occurs as the expression initializing an allocator, by passing access
+ -- to the allocated object as an additional parameter of the function call.
+ -- Function_Call must denote an expression containing a BIP function call
+ -- and an enclosing call to Ada.Tags.Displace to displace the pointer to
+ -- the returned BIP object to reference the secondary dispatch table of
+ -- an interface.
+
+ procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context
+ (Function_Call : Node_Id);
+ -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that
+ -- occurs in a context that does not provide a separate object. A temporary
+ -- object is created to act as the return object and an access to the
+ -- temporary is passed as an additional parameter of the call. This occurs
+ -- in contexts such as subprogram call actuals and object renamings.
+ -- Function_Call must denote an expression containing a BIP function call
+ -- and an enclosing call to Ada.Tags.Displace to displace the pointer to
+ -- the returned BIP object to reference the secondary dispatch table of
+ -- an interface.
+
+ procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration
+ (Obj_Decl : Node_Id;
+ Function_Call : Node_Id);
+ -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that
+ -- occurs as the expression initializing an object declaration by passsing
+ -- access to the declared object as an additional parameter of the function
+ -- call. Function_Call must denote an expression containing a BIP function
+ -- call and an enclosing call to Ada.Tags.Displace to displace the pointer
+ -- to the returned BIP object to reference the secondary dispatch table of
+ -- an interface.
+
procedure Make_CPP_Constructor_Call_In_Allocator
(Allocator : Node_Id;
Function_Call : Node_Id);
-- parameter to identify the accessibility level of the function result
-- "determined by the point of call".
+ function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id;
+ -- Return the inner BIP function call removing any qualification from Expr
+ -- including qualified expressions, type conversions, references, unchecked
+ -- conversions and calls to displace the pointer to the object, if Expr is
+ -- an expression containing a call displacing the pointer to the BIP object
+ -- to reference the secondary dispatch table of an interface; otherwise
+ -- return Empty.
+
end Exp_Ch6;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
and then Is_Build_In_Place_Function_Call (Nam)
then
Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
+
+ -- Ada 2005 (AI-318-02): Specialization of previous case for renaming
+ -- containing build-in-place function calls whose returned object covers
+ -- interface types.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (Nam))
+ then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam);
end if;
-- Create renaming entry for debug information. Mark the entity as
E : Entity_Id := Typ;
begin
- -- Handle access to class-wide interface types
+ -- Handle access types
if Is_Access_Type (E) then
- E := Etype (Directly_Designated_Type (E));
+ E := Directly_Designated_Type (E);
end if;
-- Handle class-wide types. This conversion can appear explicitly in
if Is_Access_Type (Etype (Expression (N))) then
- Apply_Accessibility_Check
- (N => Expression (N),
- Typ => Etype (N),
- Insert_Node => N);
-
-- Generate: Func (Address!(Expression))
Rewrite (N,
-- Assert_Failure, so that coverage analysis tools can relate the
-- call to the failed check.
+ procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id);
+ -- Discriminants of the enclosing protected object may be referenced
+ -- in the expression of a precondition of a protected operation.
+ -- In the body of the operation these references must be replaced by
+ -- the discriminal created for them, which area renamings of the
+ -- discriminants of the object that is the target of the operation.
+ -- This replacement is done by visibility when the references appear
+ -- in the subprogram body, but in the case of a condition which appears
+ -- on the specification of the subprogram it has be done separately
+ -- because the condition has been replaced by a Check pragma and
+ -- analyzed earlier, before the creation of the discriminal renaming
+ -- declarations that are added to the subprogram body.
+
+ ------------------------------------------
+ -- Replace_Discriminals_Of_Protected_Op --
+ ------------------------------------------
+
+ procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id) is
+ function Find_Corresponding_Discriminal (E : Entity_Id)
+ return Entity_Id;
+ -- Find the local entity that renames a discriminant of the
+ -- enclosing protected type, and has a matching name.
+
+ ------------------------------------
+ -- find_Corresponding_Discriminal --
+ ------------------------------------
+
+ function Find_Corresponding_Discriminal (E : Entity_Id)
+ return Entity_Id
+ is
+ R : Entity_Id;
+
+ begin
+ R := First_Entity (Current_Scope);
+
+ while Present (R) loop
+ if Nkind (Parent (R)) = N_Object_Renaming_Declaration
+ and then Present (Discriminal_Link (R))
+ and then Chars (Discriminal_Link (R)) = Chars (E)
+ then
+ return R;
+ end if;
+
+ Next_Entity (R);
+ end loop;
+
+ return Empty;
+ end Find_Corresponding_Discriminal;
+
+ function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
+ -- Replace a reference to a discriminant of the original protected
+ -- type by the local renaming declaration of the discriminant of
+ -- the target object.
+
+ -----------------------
+ -- Replace_Discr_Ref --
+ -----------------------
+
+ function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
+ R : Entity_Id;
+
+ begin
+ if Is_Entity_Name (N)
+ and then Present (Discriminal_Link (Entity (N)))
+ then
+ R := Find_Corresponding_Discriminal (Entity (N));
+ Rewrite (N, New_Occurrence_Of (R, Sloc (N)));
+ end if;
+ return OK;
+ end Replace_Discr_Ref;
+
+ procedure Replace_Discriminant_References is
+ new Traverse_Proc (Replace_Discr_Ref);
+
+ begin
+ Replace_Discriminant_References (Expr);
+ end Replace_Discriminals_Of_Protected_Op;
+
begin
-- Nothing to do if pragma is ignored
end;
end if;
+ -- For a precondition, replace references to discriminants of a
+ -- protected type with the local discriminals.
+
+ if Is_Protected_Type (Scope (Current_Scope))
+ and then Has_Discriminants (Scope (Current_Scope))
+ and then From_Aspect_Specification (N)
+ then
+ Replace_Discriminals_Of_Protected_Op (Cond);
+ end if;
+
-- Now rewrite as an if statement
Rewrite (N,
if Present (Priv_Typ) then
Typ_Decl := Declaration_Node (Priv_Typ);
- -- Derived types with the full view as parent do not have a partial
- -- view. Insert the invariant procedure after the derived type.
-- Anonymous arrays in object declarations have no explicit declaration
-- so use the related object declaration as the insertion point.
elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then
Typ_Decl := Associated_Node_For_Itype (Work_Typ);
+ -- Derived types with the full view as parent do not have a partial
+ -- view. Insert the invariant procedure after the derived type.
+
else
Typ_Decl := Declaration_Node (Full_Typ);
end if;
-- types.
function Has_Some_Contract (Id : Entity_Id) return Boolean;
- -- Returns True if subprogram Id has any contract (Pre, Post,
- -- Global, Depends, etc.) The presence of Extensions_Visible
- -- or Volatile_Function is also considered as a contract here.
+ -- Return True if subprogram Id has any contract. The presence of
+ -- Extensions_Visible or Volatile_Function is also considered as a
+ -- contract here.
function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
- -- Returns True if subprogram Id defines a compilation unit
+ -- Return True if subprogram Id defines a compilation unit
-- Shouldn't this be in Sem_Aux???
function In_Package_Spec (Id : Node_Id) return Boolean;
- -- Returns True if subprogram Id is defined in the package
- -- specification, either its visible or private part.
+ -- Return True if subprogram Id is defined in the package specification,
+ -- either its visible or private part.
---------------------------------------------------
-- Has_Formal_With_Discriminant_Dependent_Fields --
---------------------------------------------------
function Has_Formal_With_Discriminant_Dependent_Fields
- (Id : Entity_Id) return Boolean is
-
+ (Id : Entity_Id) return Boolean
+ is
function Has_Discriminant_Dependent_Component
(Typ : Entity_Id) return Boolean;
- -- Determine whether unconstrained record type Typ has at least
- -- one component that depends on a discriminant.
+ -- Determine whether unconstrained record type Typ has at least one
+ -- component that depends on a discriminant.
------------------------------------------
-- Has_Discriminant_Dependent_Component --
Comp : Entity_Id;
begin
- -- Inspect all components of the record type looking for one
- -- that depends on a discriminant.
+ -- Inspect all components of the record type looking for one that
+ -- depends on a discriminant.
Comp := First_Component (Typ);
while Present (Comp) loop
procedure Try_One_Interp (T1 : Entity_Id) is
begin
-
-- If the operator is an expanded name, then the type of the operand
-- must be defined in the corresponding scope. If the type is
-- universal, the context will impose the correct type. Note that we
-- Note that we avoid returning if we are currently within a
-- generic instance due to the fact that the generic package
-- declaration has already been successfully analyzed and
- -- Defined_In_Scope expects the base type to be defined within the
- -- instance which will never be the case.
+ -- Defined_In_Scope expects the base type to be defined within
+ -- the instance which will never be the case.
if Defined_In_Scope (T1, Scop)
or else In_Instance
LocX : constant Source_Ptr := Sloc (Expr);
Spec : constant Node_Id := Specification (N);
+ procedure Freeze_Expr_Types (Spec_Id : Entity_Id);
+ -- N is an expression function that is a completion and Spec_Id its
+ -- defining entity. Freeze before N all the types referenced by the
+ -- expression of the function.
+
+ -----------------------
+ -- Freeze_Expr_Types --
+ -----------------------
+
+ procedure Freeze_Expr_Types (Spec_Id : Entity_Id) 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.
+
+ function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result;
+ -- Freeze all types referenced in the subtree rooted at Node
+
+ -----------------------
+ -- Cloned_Expression --
+ -----------------------
+
+ function Cloned_Expression return Node_Id is
+ function Clone_Id (Node : Node_Id) return Traverse_Result;
+ -- Tree traversal routine that clones the defining identifier of
+ -- iterator and loop parameter specification nodes.
+
+ ----------------
+ -- Check_Node --
+ ----------------
+
+ function Clone_Id (Node : Node_Id) return Traverse_Result is
+ begin
+ if Nkind_In (Node, N_Iterator_Specification,
+ N_Loop_Parameter_Specification)
+ then
+ Set_Defining_Identifier (Node,
+ New_Copy (Defining_Identifier (Node)));
+ end if;
+
+ return OK;
+ end Clone_Id;
+
+ procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id);
+
+ -- Local variable
+
+ Dup_Expr : constant Node_Id := New_Copy_Tree (Expr);
+
+ -- Start of processing for Cloned_Expression
+
+ begin
+ -- We must duplicate the expression with semantic information to
+ -- inherit the decoration of global entities in generic instances.
+ -- Set the parent of the new node to be the parent of the original
+ -- to get the proper context, which is needed for complete error
+ -- reporting and for semantic analysis.
+
+ Set_Parent (Dup_Expr, Parent (Expr));
+
+ -- Replace the defining identifier of iterators and loop param
+ -- specifications by a clone to ensure that the cloned expression
+ -- and the original expression don't have shared identifiers;
+ -- otherwise, as part of the preanalysis of the expression, these
+ -- shared identifiers may be left decorated with itypes which
+ -- will not be available in the tree passed to the backend.
+
+ Clone_Def_Ids (Dup_Expr);
+
+ return Dup_Expr;
+ end Cloned_Expression;
+
+ ----------------------
+ -- Freeze_Type_Refs --
+ ----------------------
+
+ function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is
+
+ procedure Check_And_Freeze_Type (Typ : Entity_Id);
+ -- Check that Typ is fully declared and freeze it if so
+
+ ---------------------------
+ -- Check_And_Freeze_Type --
+ ---------------------------
+
+ procedure Check_And_Freeze_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;
+
+ -- This provides a better error message than generating
+ -- primitives whose compilation fails much later. Refine
+ -- the error message if possible.
+
+ Check_Fully_Declared (Typ, Node);
+
+ if Error_Posted (Node) then
+ if Has_Private_Component (Typ)
+ and then not Is_Private_Type (Typ)
+ then
+ Error_Msg_NE
+ ("\type& has private component", Node, Typ);
+ end if;
+
+ else
+ Freeze_Before (N, Typ);
+ end if;
+ end Check_And_Freeze_Type;
+
+ -- Start of processing for Freeze_Type_Refs
+
+ begin
+ -- Check that a type referenced by an entity can be frozen
+
+ if Is_Entity_Name (Node) and then Present (Entity (Node)) then
+ Check_And_Freeze_Type (Etype (Entity (Node)));
+
+ -- Check that the enclosing record type can be frozen
+
+ if Ekind_In (Entity (Node), E_Component, E_Discriminant) then
+ Check_And_Freeze_Type (Scope (Entity (Node)));
+ end if;
+
+ -- Freezing an access type does not freeze the designated type,
+ -- but freezing conversions between access to interfaces requires
+ -- that the interface types themselves be frozen, so that dispatch
+ -- table entities are properly created.
+
+ -- Unclear whether a more general rule is needed ???
+
+ elsif Nkind (Node) = N_Type_Conversion
+ and then Is_Access_Type (Etype (Node))
+ and then Is_Interface (Designated_Type (Etype (Node)))
+ then
+ Check_And_Freeze_Type (Designated_Type (Etype (Node)));
+ end if;
+
+ -- No point in posting several errors on the same expression
+
+ if Serious_Errors_Detected > 0 then
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Freeze_Type_Refs;
+
+ procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs);
+
+ -- Local variables
+
+ Saved_First_Entity : constant Entity_Id := First_Entity (Spec_Id);
+ Saved_Last_Entity : constant Entity_Id := Last_Entity (Spec_Id);
+ Dup_Expr : constant Node_Id := Cloned_Expression;
+
+ -- Start of processing for Freeze_Expr_Types
+
+ begin
+ -- Preanalyze a duplicate of the expression to have available the
+ -- minimum decoration needed to locate referenced unfrozen types
+ -- without adding any decoration to the function expression. This
+ -- preanalysis is performed with errors disabled to avoid reporting
+ -- spurious errors on Ghost entities (since the expression is not
+ -- fully analyzed).
+
+ Push_Scope (Spec_Id);
+ Install_Formals (Spec_Id);
+ Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+
+ Preanalyze_Spec_Expression (Dup_Expr, Etype (Spec_Id));
+
+ Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+ End_Scope;
+
+ -- Restore certain attributes of Spec_Id since the preanalysis may
+ -- have introduced itypes to this scope, thus modifying attributes
+ -- First_Entity and Last_Entity.
+
+ Set_First_Entity (Spec_Id, Saved_First_Entity);
+ Set_Last_Entity (Spec_Id, Saved_Last_Entity);
+
+ if Present (Last_Entity (Spec_Id)) then
+ Set_Next_Entity (Last_Entity (Spec_Id), Empty);
+ end if;
+
+ -- Freeze all types referenced in the expression
+
+ Freeze_References (Dup_Expr);
+ end Freeze_Expr_Types;
+
+ -- Local variables
+
Asp : Node_Id;
- Def_Id : Entity_Id;
New_Body : Node_Id;
New_Spec : Node_Id;
Orig_N : Node_Id;
Ret : Node_Id;
- Ret_Type : Entity_Id;
- Prev : Entity_Id;
+ Def_Id : Entity_Id;
+ Prev : Entity_Id;
-- If the expression is a completion, Prev is the entity whose
-- declaration is completed. Def_Id is needed to analyze the spec.
+ -- Start of processing for Analyze_Expression_Function
+
begin
-- This is one of the occasions on which we transform the tree during
-- semantic analysis. If this is a completion, transform the expression
end if;
end if;
- Ret := Make_Simple_Return_Statement (LocX, Expression (N));
+ Ret := Make_Simple_Return_Statement (LocX, Expr);
New_Body :=
Make_Subprogram_Body (Loc,
-- to be inlined.
elsif Present (Prev)
- and then Comes_From_Source (Parent (Prev))
+ and then Is_Overloadable (Prev)
and then not Is_Formal_Subprogram (Prev)
+ and then Comes_From_Source (Parent (Prev))
then
Set_Has_Completion (Prev, False);
Set_Is_Inlined (Prev);
- Ret_Type := Etype (Prev);
- -- An expression function which acts as a completion freezes the
- -- expression. This means freezing the return type, and if it is
- -- an access type, freezing its designated type as well.
+ -- AI12-0103: Expression functions that are a completion freeze their
+ -- expression but don't freeze anything else (unlike regular bodies).
-- Note that we cannot defer this freezing to the analysis of the
-- expression itself, because a freeze node might appear in a nested
-- scope, leading to an elaboration order issue in gigi.
- Freeze_Before (N, Ret_Type);
-
- -- An entity can only be frozen if it is complete, so if the type
- -- is still unfrozen it must still be incomplete in some way, e.g.
- -- a private type without a full view, or a type derived from such
- -- in an enclosing scope. Except in a generic context (where the
- -- type may be a generic formal or derived from such), such use of
- -- an incomplete type is an error. On the other hand, if this is a
- -- limited view of a type, the type is declared in another unit and
- -- frozen there. We must be in a context seeing the nonlimited view
- -- of the type, which will be installed when the body is compiled.
-
- if not Is_Frozen (Ret_Type)
- and then not Is_Generic_Type (Root_Type (Ret_Type))
- and then not Inside_A_Generic
- then
- if From_Limited_With (Ret_Type)
- and then Present (Non_Limited_View (Ret_Type))
- then
- null;
- else
- Error_Msg_NE
- ("premature use of private type&",
- Result_Definition (Specification (N)), Ret_Type);
- end if;
- end if;
+ Freeze_Expr_Types (Def_Id);
-- For navigation purposes, indicate that the function is a body
-- limited views with the non-limited ones. Return the list of changes
-- to be used to undo the transformation.
- procedure Freeze_Expr_Types (Spec_Id : Entity_Id);
- -- AI12-0103: N is the body associated with an expression function that
- -- is a completion, and Spec_Id is its defining entity. Freeze before N
- -- all the types referenced by the expression of the function.
-
function Is_Private_Concurrent_Primitive
(Subp_Id : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id is a primitive of a concurrent
return Result;
end Exchange_Limited_Views;
- -----------------------
- -- Freeze_Expr_Types --
- -----------------------
-
- procedure Freeze_Expr_Types (Spec_Id : Entity_Id) 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.
-
- function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result;
- -- Freeze all types referenced in the subtree rooted at Node
-
- -----------------------
- -- Cloned_Expression --
- -----------------------
-
- function Cloned_Expression return Node_Id is
- function Clone_Id (Node : Node_Id) return Traverse_Result;
- -- Tree traversal routine that clones the defining identifier of
- -- iterator and loop parameter specification nodes.
-
- ----------------
- -- Check_Node --
- ----------------
-
- function Clone_Id (Node : Node_Id) return Traverse_Result is
- begin
- if Nkind_In (Node, N_Iterator_Specification,
- N_Loop_Parameter_Specification)
- then
- Set_Defining_Identifier (Node,
- New_Copy (Defining_Identifier (Node)));
- end if;
-
- return OK;
- end Clone_Id;
-
- -------------------
- -- Clone_Def_Ids --
- -------------------
-
- procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id);
-
- -- Local variables
-
- Return_Stmt : constant Node_Id :=
- First
- (Statements (Handled_Statement_Sequence (N)));
- Dup_Expr : Node_Id;
-
- -- Start of processing for Cloned_Expression
-
- begin
- pragma Assert (Nkind (Return_Stmt) = N_Simple_Return_Statement);
-
- -- We must duplicate the expression with semantic information to
- -- inherit the decoration of global entities in generic instances.
- -- Set the parent of the new node to be the parent of the original
- -- to get the proper context, which is needed for complete error
- -- reporting and for semantic analysis.
-
- Dup_Expr := New_Copy_Tree (Expression (Return_Stmt));
- Set_Parent (Dup_Expr, Return_Stmt);
-
- -- Replace the defining identifier of iterators and loop param
- -- specifications by a clone to ensure that the cloned expression
- -- and the original expression don't have shared identifiers;
- -- otherwise, as part of the preanalysis of the expression, these
- -- shared identifiers may be left decorated with itypes which
- -- will not be available in the tree passed to the backend.
-
- Clone_Def_Ids (Dup_Expr);
-
- return Dup_Expr;
- end Cloned_Expression;
-
- ----------------------
- -- Freeze_Type_Refs --
- ----------------------
-
- function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is
- begin
- if Nkind (Node) = N_Identifier
- and then Present (Entity (Node))
- then
- if Is_Type (Entity (Node)) then
- Freeze_Before (N, Entity (Node));
-
- elsif Ekind_In (Entity (Node), E_Component,
- E_Discriminant)
- then
- declare
- Rec : constant Entity_Id := Scope (Entity (Node));
- begin
-
- -- Check that the enclosing record type can be frozen.
- -- This provides a better error message than generating
- -- primitives whose compilation fails much later. Refine
- -- the error message if possible.
-
- Check_Fully_Declared (Rec, Node);
-
- if Error_Posted (Node) then
- if Has_Private_Component (Rec) then
- Error_Msg_NE
- ("\type& has private component", Node, Rec);
- end if;
-
- else
- Freeze_Before (N, Rec);
- end if;
- end;
- end if;
-
- -- Freezing an access type does not freeze the designated type,
- -- but freezing conversions between access to interfaces requires
- -- that the interface types themselves be frozen, so that dispatch
- -- table entities are properly created.
-
- -- Unclear whether a more general rule is needed ???
-
- elsif Nkind (Node) = N_Type_Conversion
- and then Is_Access_Type (Etype (Node))
- and then Is_Interface (Designated_Type (Etype (Node)))
- then
- Freeze_Before (N, Designated_Type (Etype (Node)));
- end if;
-
- return OK;
- end Freeze_Type_Refs;
-
- procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs);
-
- -- Local variables
-
- Saved_First_Entity : constant Entity_Id := First_Entity (Spec_Id);
- Saved_Last_Entity : constant Entity_Id := Last_Entity (Spec_Id);
- Dup_Expr : constant Node_Id := Cloned_Expression;
-
- -- Start of processing for Freeze_Expr_Types
-
- begin
- -- Preanalyze a duplicate of the expression to have available the
- -- minimum decoration needed to locate referenced unfrozen types
- -- without adding any decoration to the function expression. This
- -- preanalysis is performed with errors disabled to avoid reporting
- -- spurious errors on Ghost entities (since the expression is not
- -- fully analyzed).
-
- Push_Scope (Spec_Id);
- Install_Formals (Spec_Id);
- Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
-
- Preanalyze_Spec_Expression (Dup_Expr, Etype (Spec_Id));
-
- Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
- End_Scope;
-
- -- Restore certain attributes of Spec_Id since the preanalysis may
- -- have introduced itypes to this scope, thus modifying attributes
- -- First_Entity and Last_Entity.
-
- Set_First_Entity (Spec_Id, Saved_First_Entity);
- Set_Last_Entity (Spec_Id, Saved_Last_Entity);
-
- if Present (Last_Entity (Spec_Id)) then
- Set_Next_Entity (Last_Entity (Spec_Id), Empty);
- end if;
-
- -- Freeze all types referenced in the expression
-
- Freeze_References (Dup_Expr);
- end Freeze_Expr_Types;
-
-------------------------------------
-- Is_Private_Concurrent_Primitive --
-------------------------------------
then
Set_Has_Delayed_Freeze (Spec_Id);
Freeze_Before (N, Spec_Id);
-
- -- AI12-0103: At the occurrence of an expression function
- -- declaration that is a completion, its expression causes
- -- freezing.
-
- if Has_Completion (Spec_Id)
- and then Nkind (N) = N_Subprogram_Body
- and then Was_Expression_Function (N)
- then
- Freeze_Expr_Types (Spec_Id);
- end if;
end if;
end if;
then
declare
Name : constant String :=
- Get_Name_String (Chars (Variant));
+ Get_Name_String (Chars (Variant));
begin
-- It is a common mistake to write "Increasing" for
-- "Increases" or "Decreasing" for "Decreases". Recognize
git://gcc.gnu.org / gcc.git / commitdiff