Chars =>
New_External_Name (Chars (Def_Id), Suffix => "L"));
- Level_Expr : Node_Id;
Level_Decl : Node_Id;
+ Level_Expr : Node_Id;
begin
Set_Ekind (Level, Ekind (Def_Id));
Set_Etype (Level, Standard_Natural);
Set_Scope (Level, Scope (Def_Id));
- if No (Expr) then
-
- -- Set accessibility level of null
+ -- Set accessibility level of null
+ if No (Expr) then
Level_Expr :=
Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
+ -- When the expression of the object is a function which returns
+ -- an anonymous access type the master of the call is the object
+ -- being initialized instead of the type.
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type
+ then
+ Level_Expr := Make_Integer_Literal (Loc,
+ Object_Access_Level (Def_Id));
+
+ -- General case
+
else
Level_Expr := Dynamic_Accessibility_Level (Expr);
end if;
-- Expand simple return from function. In the case where we are returning
-- from a function body this is called by Expand_N_Simple_Return_Statement.
- function Has_Unconstrained_Access_Discriminants
- (Subtyp : Entity_Id) return Boolean;
- -- Returns True if the given subtype is unconstrained and has one or more
- -- access discriminants.
-
procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id);
-- Insert the Post_Call list previously produced by routine Expand_Actuals
-- or Expand_Call_Helper into the tree.
end if;
end Freeze_Subprogram;
- --------------------------------------------
- -- Has_Unconstrained_Access_Discriminants --
- --------------------------------------------
-
- function Has_Unconstrained_Access_Discriminants
- (Subtyp : Entity_Id) return Boolean
- is
- Discr : Entity_Id;
-
- begin
- if Has_Discriminants (Subtyp)
- and then not Is_Constrained (Subtyp)
- then
- Discr := First_Discriminant (Subtyp);
- while Present (Discr) loop
- if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
- return True;
- end if;
-
- Next_Discriminant (Discr);
- end loop;
- end if;
-
- return False;
- end Has_Unconstrained_Access_Discriminants;
-
------------------------------
-- Insert_Post_Call_Actions --
------------------------------
return Requires_Transient_Scope (Func_Typ);
end Needs_BIP_Alloc_Form;
- --------------------------------------
- -- Needs_Result_Accessibility_Level --
- --------------------------------------
-
- function Needs_Result_Accessibility_Level
- (Func_Id : Entity_Id) return Boolean
- is
- Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
-
- function Has_Unconstrained_Access_Discriminant_Component
- (Comp_Typ : Entity_Id) return Boolean;
- -- Returns True if any component of the type has an unconstrained access
- -- discriminant.
-
- -----------------------------------------------------
- -- Has_Unconstrained_Access_Discriminant_Component --
- -----------------------------------------------------
-
- function Has_Unconstrained_Access_Discriminant_Component
- (Comp_Typ : Entity_Id) return Boolean
- is
- begin
- if not Is_Limited_Type (Comp_Typ) then
- return False;
-
- -- Only limited types can have access discriminants with
- -- defaults.
-
- elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then
- return True;
-
- elsif Is_Array_Type (Comp_Typ) then
- return Has_Unconstrained_Access_Discriminant_Component
- (Underlying_Type (Component_Type (Comp_Typ)));
-
- elsif Is_Record_Type (Comp_Typ) then
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Component (Comp_Typ);
- while Present (Comp) loop
- if Has_Unconstrained_Access_Discriminant_Component
- (Underlying_Type (Etype (Comp)))
- then
- return True;
- end if;
-
- Next_Component (Comp);
- end loop;
- end;
- end if;
-
- return False;
- end Has_Unconstrained_Access_Discriminant_Component;
-
- Disable_Coextension_Cases : constant Boolean := True;
- -- Flag used to temporarily disable a "True" result for types with
- -- access discriminants and related coextension cases.
-
- -- Start of processing for Needs_Result_Accessibility_Level
-
- begin
- -- False if completion unavailable (how does this happen???)
-
- if not Present (Func_Typ) then
- return False;
-
- -- False if not a function, also handle enum-lit renames case
-
- elsif Func_Typ = Standard_Void_Type
- or else Is_Scalar_Type (Func_Typ)
- then
- return False;
-
- -- Handle a corner case, a cross-dialect subp renaming. For example,
- -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
- -- an Ada 2005 (or earlier) unit references predefined run-time units.
-
- elsif Present (Alias (Func_Id)) then
-
- -- Unimplemented: a cross-dialect subp renaming which does not set
- -- the Alias attribute (e.g., a rename of a dereference of an access
- -- to subprogram value). ???
-
- return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));
-
- -- Remaining cases require Ada 2012 mode
-
- elsif Ada_Version < Ada_2012 then
- return False;
-
- -- Handle the situation where a result is an anonymous access type
- -- RM 3.10.2 (10.3/3).
-
- elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then
- return True;
-
- -- The following cases are related to coextensions and do not fully
- -- cover everything mentioned in RM 3.10.2 (12) ???
-
- -- Temporarily disabled ???
-
- elsif Disable_Coextension_Cases then
- return False;
-
- -- In the case of, say, a null tagged record result type, the need for
- -- this extra parameter might not be obvious so this function returns
- -- True for all tagged types for compatibility reasons.
-
- -- A function with, say, a tagged null controlling result type might
- -- be overridden by a primitive of an extension having an access
- -- discriminant and the overrider and overridden must have compatible
- -- calling conventions (including implicitly declared parameters).
-
- -- Similarly, values of one access-to-subprogram type might designate
- -- both a primitive subprogram of a given type and a function which is,
- -- for example, not a primitive subprogram of any type. Again, this
- -- requires calling convention compatibility. It might be possible to
- -- solve these issues by introducing wrappers, but that is not the
- -- approach that was chosen.
-
- elsif Is_Tagged_Type (Func_Typ) then
- return True;
-
- elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
- return True;
-
- elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
- return True;
-
- -- False for all other cases
-
- else
- return False;
- end if;
- end Needs_Result_Accessibility_Level;
-
-------------------------------------
-- Replace_Renaming_Declaration_Id --
-------------------------------------
function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean;
-- Return True if the function returns an object of a type that has tasks.
- function Needs_Result_Accessibility_Level
- (Func_Id : Entity_Id) return Boolean;
- -- Ada 2012 (AI05-0234): Return True if the function needs an implicit
- -- 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
end if;
end if;
+ -- Check if the operand is deeper than the target type, taking
+ -- care to avoid the case where we are converting a result of a
+ -- function returning an anonymous access type since the "master
+ -- of the call" would be target type of the conversion in all
+ -- cases - see RM 10.3/3.
+
elsif Type_Access_Level (Opnd_Type) >
Deepest_Type_Access_Level (Target_Type)
+ and then not (Nkind (Associated_Node_For_Itype (Opnd_Type)) =
+ N_Function_Specification)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
end if;
end Has_Tagged_Component;
+ --------------------------------------------
+ -- Has_Unconstrained_Access_Discriminants --
+ --------------------------------------------
+
+ function Has_Unconstrained_Access_Discriminants
+ (Subtyp : Entity_Id) return Boolean
+ is
+ Discr : Entity_Id;
+
+ begin
+ if Has_Discriminants (Subtyp)
+ and then not Is_Constrained (Subtyp)
+ then
+ Discr := First_Discriminant (Subtyp);
+ while Present (Discr) loop
+ if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
+ return True;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+ end if;
+
+ return False;
+ end Has_Unconstrained_Access_Discriminants;
+
-----------------------------
-- Has_Undefined_Reference --
-----------------------------
and then Ekind_In (Scop, E_Function,
E_Operator,
E_Subprogram_Type)
- and then Present (Extra_Accessibility_Of_Result (Scop));
+ and then Needs_Result_Accessibility_Level (Scop);
end;
end Is_Special_Aliased_Formal_Access;
end if;
end Needs_One_Actual;
+ --------------------------------------
+ -- Needs_Result_Accessibility_Level --
+ --------------------------------------
+
+ function Needs_Result_Accessibility_Level
+ (Func_Id : Entity_Id) return Boolean
+ is
+ Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
+
+ function Has_Unconstrained_Access_Discriminant_Component
+ (Comp_Typ : Entity_Id) return Boolean;
+ -- Returns True if any component of the type has an unconstrained access
+ -- discriminant.
+
+ -----------------------------------------------------
+ -- Has_Unconstrained_Access_Discriminant_Component --
+ -----------------------------------------------------
+
+ function Has_Unconstrained_Access_Discriminant_Component
+ (Comp_Typ : Entity_Id) return Boolean
+ is
+ begin
+ if not Is_Limited_Type (Comp_Typ) then
+ return False;
+
+ -- Only limited types can have access discriminants with
+ -- defaults.
+
+ elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then
+ return True;
+
+ elsif Is_Array_Type (Comp_Typ) then
+ return Has_Unconstrained_Access_Discriminant_Component
+ (Underlying_Type (Component_Type (Comp_Typ)));
+
+ elsif Is_Record_Type (Comp_Typ) then
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Comp_Typ);
+ while Present (Comp) loop
+ if Has_Unconstrained_Access_Discriminant_Component
+ (Underlying_Type (Etype (Comp)))
+ then
+ return True;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Has_Unconstrained_Access_Discriminant_Component;
+
+ Disable_Coextension_Cases : constant Boolean := True;
+ -- Flag used to temporarily disable a "True" result for types with
+ -- access discriminants and related coextension cases.
+
+ -- Start of processing for Needs_Result_Accessibility_Level
+
+ begin
+ -- False if completion unavailable (how does this happen???)
+
+ if not Present (Func_Typ) then
+ return False;
+
+ -- False if not a function, also handle enum-lit renames case
+
+ elsif Func_Typ = Standard_Void_Type
+ or else Is_Scalar_Type (Func_Typ)
+ then
+ return False;
+
+ -- Handle a corner case, a cross-dialect subp renaming. For example,
+ -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
+ -- an Ada 2005 (or earlier) unit references predefined run-time units.
+
+ elsif Present (Alias (Func_Id)) then
+
+ -- Unimplemented: a cross-dialect subp renaming which does not set
+ -- the Alias attribute (e.g., a rename of a dereference of an access
+ -- to subprogram value). ???
+
+ return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));
+
+ -- Remaining cases require Ada 2012 mode
+
+ elsif Ada_Version < Ada_2012 then
+ return False;
+
+ -- Handle the situation where a result is an anonymous access type
+ -- RM 3.10.2 (10.3/3).
+
+ elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then
+ return True;
+
+ -- The following cases are related to coextensions and do not fully
+ -- cover everything mentioned in RM 3.10.2 (12) ???
+
+ -- Temporarily disabled ???
+
+ elsif Disable_Coextension_Cases then
+ return False;
+
+ -- In the case of, say, a null tagged record result type, the need for
+ -- this extra parameter might not be obvious so this function returns
+ -- True for all tagged types for compatibility reasons.
+
+ -- A function with, say, a tagged null controlling result type might
+ -- be overridden by a primitive of an extension having an access
+ -- discriminant and the overrider and overridden must have compatible
+ -- calling conventions (including implicitly declared parameters).
+
+ -- Similarly, values of one access-to-subprogram type might designate
+ -- both a primitive subprogram of a given type and a function which is,
+ -- for example, not a primitive subprogram of any type. Again, this
+ -- requires calling convention compatibility. It might be possible to
+ -- solve these issues by introducing wrappers, but that is not the
+ -- approach that was chosen.
+
+ elsif Is_Tagged_Type (Func_Typ) then
+ return True;
+
+ elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
+ return True;
+
+ elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
+ return True;
+
+ -- False for all other cases
+
+ else
+ return False;
+ end if;
+ end Needs_Result_Accessibility_Level;
+
---------------------------------
-- Needs_Simple_Initialization --
---------------------------------
-- function is used to check if "=" has to be expanded into a bunch
-- component comparisons.
+ function Has_Unconstrained_Access_Discriminants
+ (Subtyp : Entity_Id) return Boolean;
+ -- Returns True if the given subtype is unconstrained and has one or more
+ -- access discriminants.
+
function Has_Undefined_Reference (Expr : Node_Id) return Boolean;
-- Given arbitrary expression Expr, determine whether it contains at
-- least one name whose entity is Any_Id.
-- syntactic ambiguity that results from an indexing of a function call
-- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y).
+ function Needs_Result_Accessibility_Level
+ (Func_Id : Entity_Id) return Boolean;
+ -- Ada 2012 (AI05-0234): Return True if the function needs an implicit
+ -- parameter to identify the accessibility level of the function result
+ -- "determined by the point of call".
+
function Needs_Simple_Initialization
(Typ : Entity_Id;
Consider_IS : Boolean := True) return Boolean;
-- Establish the entity E as the currently visible definition of its
-- associated name (i.e. the Node_Id associated with its name).
+ procedure Set_Debug_Info_Defining_Id (N : Node_Id);
+ -- Call Set_Debug_Info_Needed on Defining_Identifier (N) if it comes
+ -- from source.
+
procedure Set_Debug_Info_Needed (T : Entity_Id);
-- Sets the Debug_Info_Needed flag on entity T , and also on any entities
-- that are needed by T (for an object, the type of the object is needed,
-- This routine should always be used instead of Set_Needs_Debug_Info to
-- ensure that subsidiary entities are properly handled.
- procedure Set_Debug_Info_Defining_Id (N : Node_Id);
- -- Call Set_Debug_Info_Needed on Defining_Identifier (N) if it comes
- -- from source.
-
procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id);
-- This procedure has the same calling sequence as Set_Entity, but it
-- performs additional checks as follows:
projects / gcc.git / commitdiff