package body Accessibility is
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Apply_Accessibility_Check_For_Anonymous
+ (Exp : Node_Id;
+ Func : Entity_Id;
+ Insert_Node : Node_Id);
+ -- If the result type of the function is an anonymous access type, insert
+ -- a check that the accessibility level of the entity designated by the
+ -- result is not deeper than the level of the master of the call. Exp is
+ -- an expression being returned from Func.
+
+ procedure Apply_Accessibility_Check_For_Class_Wide
+ (Exp : Node_Id;
+ Func : Entity_Id);
+ -- Ada 2005 (AI95-344): If the result type is class-wide, insert a check
+ -- that the level of the return expression's underlying type is not deeper
+ -- than the level of the master enclosing the function. Always generate the
+ -- check when the type of the return expression is class-wide, when it's a
+ -- type conversion, or when it's a formal parameter. Otherwise suppress the
+ -- check in the case where the return expression has a specific type whose
+ -- level is known not to be statically deeper than the result type of the
+ -- function. Exp is an expression being returned from Func.
+
+ procedure Apply_Accessibility_Check_For_Discriminant
+ (Exp : Node_Id;
+ Func : Entity_Id);
+ -- If the result type of the function has access discriminants, insert
+ -- checks that the accessibility level of each entity designated by an
+ -- access discriminant of the result is not deeper than the level of the
+ -- master of the call. Exp is an expression being returned from Func.
+
---------------------------
-- Accessibility_Message --
---------------------------
-- First deal with function calls in Ada 95
if Nkind (N) = N_Function_Call
- and then Ada_Version < Ada_2005
+ and then Ada_Version <= Ada_95
then
-- With a return by reference, we either get the accessibility of
-- the function or, in case of an indirect call, the accessibility
-- access discriminant constraint of a return object (signified
-- by In_Return_Context) on the side of the callee.
- if Nkind (N) = N_Function_Call
- and then (In_Return_Value (N) or else In_Return_Context)
- then
+ if In_Return_Value (N) or else In_Return_Context then
declare
Extra_Formal : constant Entity_Id :=
Extra_Accessibility_Of_Result (Current_Subprogram);
-- Perform the processing on the expression
case Nkind (E) is
+ -- The accessibility level of the literal null is the library level
+
+ when N_Null =>
+ return Make_Level_Literal (Scope_Depth (Standard_Standard));
+
-- The level of an aggregate is that of the innermost master that
-- evaluates it as defined in RM 3.10.2 (10/4).
(Innermost_Master_Scope_Depth
(Enclosing_Declaration (Expr)));
- -- Unchecked or unrestricted attributes have unlimited depth
+ -- Return the library level to null out the check for the Address,
+ -- Deref, Unchecked_Access and Unrestricted_Access attributes.
elsif Attribute_Name (E) in Name_Address
+ | Name_Deref
| Name_Unchecked_Access
| Name_Unrestricted_Access
then
if (In_Return_Value (E) or else In_Return_Context)
and then Level /= Dynamic_Level
then
- return Make_Level_Literal
- (Scope_Depth (Standard_Standard));
+ return Make_Level_Literal (Scope_Depth (Standard_Standard));
end if;
- return Make_Level_Literal
- (Innermost_Master_Scope_Depth (Expr));
+ return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr));
-- Otherwise, continue recursing over the expression prefixes
end case;
end Accessibility_Level;
- -------------------------------
- -- Apply_Accessibility_Check --
- -------------------------------
-
- procedure Apply_Accessibility_Check
- (N : Node_Id;
- Typ : Entity_Id;
- Insert_Node : Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (N);
-
- Check_Cond : Node_Id;
- Param_Ent : Entity_Id := Param_Entity (N);
- Param_Level : Node_Id;
- Type_Level : Node_Id;
-
- begin
- -- Verify we haven't tried to add a dynamic accessibility check when we
- -- shouldn't.
-
- pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N));
-
- if Ada_Version >= Ada_2012
- and then No (Param_Ent)
- and then Is_Entity_Name (N)
- and then Ekind (Entity (N)) in E_Constant | E_Variable
- and then Present (Effective_Extra_Accessibility (Entity (N)))
- then
- Param_Ent := Entity (N);
- while Present (Renamed_Object (Param_Ent)) loop
- -- Renamed_Object must return an Entity_Name here
- -- because of preceding "Present (E_E_A (...))" test.
-
- Param_Ent := Entity (Renamed_Object (Param_Ent));
- end loop;
- end if;
-
- if Inside_A_Generic then
- return;
-
- -- Only apply the run-time check if the access parameter has an
- -- associated extra access level parameter and when accessibility checks
- -- are enabled.
-
- elsif Present (Param_Ent)
- and then Present (Get_Dynamic_Accessibility (Param_Ent))
- and then not Accessibility_Checks_Suppressed (Param_Ent)
- and then not Accessibility_Checks_Suppressed (Typ)
- then
- -- Obtain the parameter's accessibility level
-
- Param_Level :=
- New_Occurrence_Of (Get_Dynamic_Accessibility (Param_Ent), Loc);
-
- -- Use the dynamic accessibility parameter for the function's result
- -- when one has been created instead of statically referring to the
- -- deepest type level so as to appropriatly handle the rules for
- -- RM 3.10.2 (10.1/3).
-
- if Ekind (Scope (Param_Ent)) = E_Function
- and then In_Return_Value (N)
- and then Ekind (Typ) = E_Anonymous_Access_Type
- then
- -- Associate the level of the result type to the extra result
- -- accessibility parameter belonging to the current function.
-
- if Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then
- Type_Level :=
- New_Occurrence_Of
- (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc);
-
- -- In Ada 2005 and earlier modes, a result extra accessibility
- -- parameter is not generated and no dynamic check is performed.
-
- else
- return;
- end if;
-
- -- Otherwise get the type's accessibility level normally
-
- else
- Type_Level :=
- Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
- end if;
-
- -- Raise Program_Error if the accessibility level of the access
- -- parameter is deeper than the level of the target access type.
-
- Check_Cond :=
- Make_Op_Gt (Loc,
- Left_Opnd => Param_Level,
- Right_Opnd => Type_Level);
-
- Insert_Action (Insert_Node,
- Make_Raise_Program_Error (Loc,
- Condition => Check_Cond,
- Reason => PE_Accessibility_Check_Failed));
-
- Analyze_And_Resolve (N);
-
- -- If constant folding has happened on the condition for the
- -- generated error, then warn about it being unconditional.
-
- if Nkind (Check_Cond) = N_Identifier
- and then Entity (Check_Cond) = Standard_True
- then
- Error_Msg_Warn := SPARK_Mode /= On;
- Error_Msg_N ("accessibility check fails<<", N);
- Error_Msg_N ("\Program_Error [<<", N);
- end if;
- end if;
- end Apply_Accessibility_Check;
-
---------------------------------------------
-- Apply_Accessibility_Check_For_Allocator --
---------------------------------------------
end if;
end Apply_Accessibility_Check_For_Allocator;
+ ---------------------------------------------
+ -- Apply_Accessibility_Check_For_Anonymous --
+ ---------------------------------------------
+
+ procedure Apply_Accessibility_Check_For_Anonymous
+ (Exp : Node_Id;
+ Func : Entity_Id;
+ Insert_Node : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Exp);
+
+ function Has_Level_Tied_To_Explicitly_Aliased_Parameter
+ (Exp : Node_Id) return Boolean;
+ -- Exp is an anonymous access value. Return True iff the accessibility
+ -- of the type of Exp is the level of an explicitly aliased parameter
+ -- of Func. If true, this indicates that no check should be performed
+ -- for Exp.
+
+ -----------------------------------------------------
+ -- Has_Level_Tied_To_Explicitly_Aliased_Parameter --
+ -----------------------------------------------------
+
+ function Has_Level_Tied_To_Explicitly_Aliased_Parameter
+ (Exp : Node_Id) return Boolean
+ is
+ E, P : Node_Id;
+
+ begin
+ E := Exp;
+
+ -- Look through constants
+
+ while Is_Entity_Name (E)
+ and then Ekind (Entity (E)) = E_Constant
+ and then Present (Constant_Value (Entity (E)))
+ loop
+ E := Constant_Value (Entity (E));
+ end loop;
+
+ if Nkind (E) = N_Attribute_Reference
+ and then Get_Attribute_Id (Attribute_Name (E)) = Attribute_Access
+ then
+ P := Ultimate_Prefix (E);
+ if Is_Entity_Name (P)
+ and then Is_Explicitly_Aliased (Entity (P))
+ and then Scope (Entity (P)) = Func
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Has_Level_Tied_To_Explicitly_Aliased_Parameter;
+
+ -- Start of processing for Apply_Accessibility_Check_For_Anonymous
+
+ begin
+ if Present (Extra_Accessibility_Of_Result (Func))
+ and then not Has_Level_Tied_To_Explicitly_Aliased_Parameter (Exp)
+ then
+ declare
+ Discrim_Level : constant Node_Id :=
+ Accessibility_Level (Expr => Exp,
+ Level => Dynamic_Level,
+ In_Return_Context => True);
+
+ begin
+ if Nkind (Discrim_Level) = N_Integer_Literal
+ and then Intval (Discrim_Level) > Scope_Depth (Func)
+ then
+ Error_Msg_N
+ ("level of type of access value of return expression "
+ & "is statically too deep",
+ Enclosing_Declaration_Or_Statement (Exp));
+ end if;
+
+ Insert_Action (Insert_Node,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Discrim_Level,
+ Right_Opnd => New_Occurrence_Of
+ (Extra_Accessibility_Of_Result (Func), Loc)),
+ Reason => PE_Accessibility_Check_Failed),
+ Suppress => Access_Check);
+ end;
+ end if;
+ end Apply_Accessibility_Check_For_Anonymous;
+
+ ----------------------------------------------
+ -- Apply_Accessibility_Check_For_Class_Wide --
+ ----------------------------------------------
+
+ procedure Apply_Accessibility_Check_For_Class_Wide
+ (Exp : Node_Id;
+ Func : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Exp);
+
+ begin
+ -- CodePeer does not do anything useful on Ada.Tags.Type_Specific_Data
+ -- components.
+
+ if Ada_Version >= Ada_2005
+ and then not CodePeer_Mode
+ and then Tagged_Type_Expansion
+ and then not Scope_Suppress.Suppress (Accessibility_Check)
+ and then
+ (Is_Class_Wide_Type (Etype (Exp))
+ or else Nkind (Exp) in
+ N_Type_Conversion | N_Unchecked_Type_Conversion
+ or else (Is_Entity_Name (Exp)
+ and then Is_Formal (Entity (Exp)))
+ or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
+ Subprogram_Access_Level (Func))
+ then
+ declare
+ Tag_Node : Node_Id;
+
+ begin
+ -- Ada 2005 (AI-251): In class-wide interface objects we displace
+ -- "this" to reference the base of the object. This is required to
+ -- get access to the TSD of the object.
+
+ if Is_Class_Wide_Type (Etype (Exp))
+ and then Is_Interface (Etype (Exp))
+ then
+ -- If the expression is an explicit dereference then we can
+ -- directly displace the pointer to reference the base of
+ -- the object.
+
+ if Nkind (Exp) = N_Explicit_Dereference then
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ Duplicate_Subexpr (Prefix (Exp)))))));
+
+ -- Similar case to the previous one but the expression is a
+ -- renaming of an explicit dereference.
+
+ elsif Nkind (Exp) = N_Identifier
+ and then Present (Renamed_Object (Entity (Exp)))
+ and then Nkind (Renamed_Object (Entity (Exp)))
+ = N_Explicit_Dereference
+ then
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ Duplicate_Subexpr
+ (Prefix
+ (Renamed_Object (Entity (Exp)))))))));
+
+ -- Common case: obtain the address of the actual object and
+ -- displace the pointer to reference the base of the object.
+
+ else
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Exp),
+ Attribute_Name => Name_Address)))));
+ end if;
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Exp),
+ Attribute_Name => Name_Tag);
+ end if;
+
+ -- Suppress junk access chacks on RE_Tag_Ptr
+
+ Insert_Action (Exp,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Subprogram_Access_Level (Func))),
+ Reason => PE_Accessibility_Check_Failed),
+ Suppress => Access_Check);
+ end;
+ end if;
+ end Apply_Accessibility_Check_For_Class_Wide;
+
+ ------------------------------------------------
+ -- Apply_Accessibility_Check_For_Discriminant --
+ ------------------------------------------------
+
+ -- A case that is not addressed today is the case where we need to check
+ -- an access discriminant subcomponent of the function result other than
+ -- a discriminant of the function result. This case can only happen if the
+ -- function result type has an unconstrained subcomponent subtype that has
+ -- an access discriminant (which implies that the function result type must
+ -- be limited).
+
+ -- A further corner case of that corner case arises if the limited result
+ -- type is class-wide and it is not known statically whether this access
+ -- discriminant subcomponent exists. The easiest way to address it properly
+ -- would probably involve adding a compiler-generated dispatching procedure
+ -- and a dispatching call could be used to perform the check in a context
+ -- where we know statically the specific type of the function result.
+ -- Finding a less important unimplemented case would be challenging.
+
+ procedure Apply_Accessibility_Check_For_Discriminant
+ (Exp : Node_Id; Func : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Exp);
+
+ function Constraint_Bearing_Subtype_If_Any
+ (Exp : Node_Id) return Node_Id;
+ -- If we can locate a constrained subtype whose constraint applies
+ -- to Exp, then return that. Otherwise, return Etype (Exp).
+
+ function Discr_Expression
+ (Typ : Entity_Id; Discr_Index : Positive) return Node_Id;
+ -- Typ is a constrained discriminated subtype.
+ -- Return the constraint expression for the indexed discriminant.
+
+ ---------------------------------------
+ -- Constraint_Bearing_Subtype_If_Any --
+ ---------------------------------------
+
+ function Constraint_Bearing_Subtype_If_Any
+ (Exp : Node_Id) return Entity_Id
+ is
+ Result : Entity_Id := Etype (Exp);
+
+ begin
+ if Is_Constrained (Result) then
+ return Result;
+ end if;
+
+ -- Look through expansion-generated levels of indirection
+ -- to find a constrained subtype. Yuck. This comes up in
+ -- some cases when the unexpanded source returns an aggregate.
+
+ if Nkind (Exp) = N_Explicit_Dereference then
+ declare
+ P : Node_Id := Prefix (Exp);
+
+ begin
+ while Is_Entity_Name (P)
+ and then Ekind (Entity (P)) = E_Constant
+ and then Present (Constant_Value (Entity (P)))
+ loop
+ P := Constant_Value (Entity (P));
+ end loop;
+
+ if Nkind (P) = N_Allocator
+ and then Nkind (Expression (P)) = N_Qualified_Expression
+ then
+ Result := Etype (Expression (P));
+ end if;
+ end;
+ end if;
+
+ if Is_Constrained (Result) then
+ return Result;
+ end if;
+
+ -- No constrained subtype found
+
+ return Etype (Exp);
+ end Constraint_Bearing_Subtype_If_Any;
+
+ ----------------------
+ -- Discr_Expression --
+ ----------------------
+
+ function Discr_Expression
+ (Typ : Entity_Id; Discr_Index : Positive) return Node_Id
+ is
+ Constraint_Elmt : Elmt_Id :=
+ First_Elmt (Discriminant_Constraint (Typ));
+ begin
+ for Skip in 1 .. Discr_Index - 1 loop
+ Next_Elmt (Constraint_Elmt);
+ end loop;
+
+ return Node (Constraint_Elmt);
+ end Discr_Expression;
+
+ -- Local variables
+
+ Constrained_Subtype : constant Entity_Id :=
+ Constraint_Bearing_Subtype_If_Any (Exp);
+
+ Discr : Entity_Id := First_Discriminant (Etype (Func));
+ Discr_Index : Positive := 1;
+ Discr_Exp : Node_Id;
+
+ -- Start of processing for Apply_Accessibility_Check_For_Discriminant
+
+ begin
+ -- ??? Do not generate a check if version is Ada 95 (or earlier).
+ -- It is unclear whether this is really correct, or is just a stopgap
+ -- measure. Investigation is needed to decide how post-Ada-95 binding
+ -- interpretation changes in RM 3.10.2 should interact with Ada 95's
+ -- return-by-reference model for functions with limited result types
+ -- (which was abandoned in Ada 2005).
+
+ if Ada_Version <= Ada_95 then
+ return;
+ end if;
+
+ -- If we are returning a function call then that function will
+ -- perform the needed check.
+
+ if Nkind (Unqualify (Exp)) = N_Function_Call then
+ return;
+ end if;
+
+ -- ??? Cope with the consequences of the Disable_Tagged_Cases flag
+ -- in accessibility.adb (which can cause the extra formal parameter
+ -- needed for the check(s) generated here to be missing in the case
+ -- of a tagged result type); this is a workaround and can
+ -- prevent generation of a required check (or even a required
+ -- legality check - see "statically too deep" check below).
+
+ if No (Extra_Accessibility_Of_Result (Func)) then
+ return;
+ end if;
+
+ Remove_Side_Effects (Exp);
+
+ while Present (Discr) loop
+ if Is_Anonymous_Access_Type (Etype (Discr)) then
+ if Is_Constrained (Constrained_Subtype) then
+ Discr_Exp :=
+ New_Copy_Tree
+ (Discr_Expression (Constrained_Subtype, Discr_Index));
+ else
+ Discr_Exp :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Exp),
+ Selector_Name => New_Occurrence_Of (Discr, Loc));
+ end if;
+
+ Analyze (Discr_Exp);
+
+ Apply_Accessibility_Check_For_Anonymous (Discr_Exp, Func, Exp);
+ end if;
+
+ Next_Discriminant (Discr);
+ Discr_Index := Discr_Index + 1;
+ end loop;
+ end Apply_Accessibility_Check_For_Discriminant;
+
+ ---------------------------------------------
+ -- Apply_Accessibility_Check_For_Parameter --
+ ---------------------------------------------
+
+ procedure Apply_Accessibility_Check_For_Parameter
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Insert_Node : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Check_Cond : Node_Id;
+ Param_Ent : Entity_Id := Param_Entity (N);
+ Param_Level : Node_Id;
+ Type_Level : Node_Id;
+
+ begin
+ -- Verify we haven't tried to add a dynamic accessibility check when we
+ -- shouldn't.
+
+ pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N));
+
+ if Ada_Version >= Ada_2012
+ and then No (Param_Ent)
+ and then Is_Entity_Name (N)
+ and then Ekind (Entity (N)) in E_Constant | E_Variable
+ and then Present (Effective_Extra_Accessibility (Entity (N)))
+ then
+ Param_Ent := Entity (N);
+ while Present (Renamed_Object (Param_Ent)) loop
+ -- Renamed_Object must return an Entity_Name here
+ -- because of preceding "Present (E_E_A (...))" test.
+
+ Param_Ent := Entity (Renamed_Object (Param_Ent));
+ end loop;
+ end if;
+
+ if Inside_A_Generic then
+ return;
+
+ -- Only apply the run-time check if the access parameter has an
+ -- associated extra access level parameter and when accessibility checks
+ -- are enabled.
+
+ elsif Present (Param_Ent)
+ and then Present (Get_Dynamic_Accessibility (Param_Ent))
+ and then not Accessibility_Checks_Suppressed (Param_Ent)
+ and then not Accessibility_Checks_Suppressed (Typ)
+ then
+ -- Obtain the parameter's accessibility level
+
+ Param_Level :=
+ New_Occurrence_Of (Get_Dynamic_Accessibility (Param_Ent), Loc);
+
+ -- Use the dynamic accessibility parameter for the function's result
+ -- when one has been created instead of statically referring to the
+ -- deepest type level so as to appropriatly handle the rules for
+ -- RM 3.10.2 (10.1/3).
+
+ if Ekind (Scope (Param_Ent)) = E_Function
+ and then In_Return_Value (N)
+ and then Ekind (Typ) = E_Anonymous_Access_Type
+ then
+ -- Associate the level of the result type to the extra result
+ -- accessibility parameter belonging to the current function.
+
+ if Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then
+ Type_Level :=
+ New_Occurrence_Of
+ (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc);
+
+ -- In Ada 2005 and earlier modes, a result extra accessibility
+ -- parameter is not generated and no dynamic check is performed.
+
+ else
+ return;
+ end if;
+
+ -- Otherwise get the type's accessibility level normally
+
+ else
+ Type_Level :=
+ Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
+ end if;
+
+ -- Raise Program_Error if the accessibility level of the access
+ -- parameter is deeper than the level of the target access type.
+
+ Check_Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd => Param_Level,
+ Right_Opnd => Type_Level);
+
+ Insert_Action (Insert_Node,
+ Make_Raise_Program_Error (Loc,
+ Condition => Check_Cond,
+ Reason => PE_Accessibility_Check_Failed));
+
+ Analyze_And_Resolve (N);
+
+ -- If constant folding has happened on the condition for the
+ -- generated error, then warn about it being unconditional.
+
+ if Nkind (Check_Cond) = N_Identifier
+ and then Entity (Check_Cond) = Standard_True
+ then
+ Error_Msg_Warn := SPARK_Mode /= On;
+ Error_Msg_N ("accessibility check fails<<", N);
+ Error_Msg_N ("\Program_Error [<<", N);
+ end if;
+ end if;
+ end Apply_Accessibility_Check_For_Parameter;
+
+ ------------------------------------------
+ -- Apply_Accessibility_Check_For_Return --
+ ------------------------------------------
+
+ procedure Apply_Accessibility_Check_For_Return
+ (Exp : Node_Id;
+ Func : Entity_Id)
+ is
+ Typ : constant Entity_Id := Etype (Func);
+
+ begin
+ -- Ada 2005 (AI95-344): If the result type is class-wide, then insert
+ -- a check that the level of the return expression's underlying type
+ -- is not deeper than the level of the master enclosing the function.
+
+ if Is_Class_Wide_Type (Typ) then
+ Apply_Accessibility_Check_For_Class_Wide (Exp, Func);
+
+ -- Check that the access result does not designate an entity that
+ -- the function result could outlive.
+
+ elsif Ekind (Typ) = E_Anonymous_Access_Type then
+ Apply_Accessibility_Check_For_Anonymous (Exp, Func, Exp);
+
+ -- Check that result's access discriminants (if any) do not designate
+ -- entities that the function result could outlive.
+
+ elsif Has_Anonymous_Access_Discriminant (Typ) then
+ Apply_Accessibility_Check_For_Discriminant (Exp, Func);
+ end if;
+ end Apply_Accessibility_Check_For_Return;
+
------------------------------------------
-- Check_Return_Construct_Accessibility --
------------------------------------------
In_Return_Context : Boolean := False) return Uint
is
begin
- return Intval
- (Accessibility_Level (Expr, Level, In_Return_Context));
+ return Intval (Accessibility_Level (Expr, Level, In_Return_Context));
end Static_Accessibility_Level;
-----------------------
-- The Allow_Alt_Model parameter allows the alternative level calculation
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
- procedure Apply_Accessibility_Check
- (N : Node_Id;
- Typ : Entity_Id;
- Insert_Node : Node_Id);
- -- Given a name N denoting an access parameter, emits a run-time
- -- accessibility check (if necessary), checking that the level of
- -- the object denoted by the access parameter is not deeper than the
- -- level of the type Typ. Program_Error is raised if the check fails.
- -- Insert_Node indicates the node where the check should be inserted.
-
procedure Apply_Accessibility_Check_For_Allocator
(N : Node_Id;
Exp : Node_Id;
-- case seems to be an actual gap in the language rules that needs to
-- be fixed by the ARG. ???
+ procedure Apply_Accessibility_Check_For_Parameter
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Insert_Node : Node_Id);
+ -- Given a name N denoting an access parameter, insert a run-time check
+ -- that the accessibility level of the object denoted by the parameter
+ -- is not deeper than the level of the type Typ. Insert_Node indicates
+ -- the node where the check should be inserted.
+
+ procedure Apply_Accessibility_Check_For_Return
+ (Exp : Node_Id;
+ Func : Entity_Id);
+ -- Insert the required run-time accessibility checks for an expression Exp
+ -- that is being returned from function Func.
+
procedure Check_Return_Construct_Accessibility
(Return_Stmt : Node_Id;
Stm_Entity : Entity_Id);
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id;
- -- Same as Einfo.Extra_Accessibility except thtat object renames
- -- are looked through.
+ -- Same as Extra_Accessibility in Einfo, but looks through object renamings
function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id;
-- Obtain the accessibility level for a given entity formal taking into
(Entity (Prefix (Enc_Object))))
and then not No_Dynamic_Accessibility_Checks_Enabled (Enc_Object)
then
- Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
+ Apply_Accessibility_Check_For_Parameter
+ (Prefix (Enc_Object), Typ, N);
-- Ada 2005 (AI-251): If the designated type is an interface we
-- add an implicit conversion to force the displacement of the
and then not Is_Delayed_Aggregate (Expr)
and then not No_Initialization (N)
then
- -- Ada 2005 (AI95-344): If the result type is class-wide, insert
- -- a check that the level of the return expression's underlying
- -- type is not deeper than the level of the master enclosing the
- -- function.
-
-- AI12-043: The check is made immediately after the return object
-- is created.
- if Is_Class_Wide_Type (Etype (Func_Id)) then
- Apply_CW_Accessibility_Check (Expr, Func_Id);
- end if;
-
- if Has_Anonymous_Access_Discriminant (Etype (Expr)) then
- -- Check that access discrims do not designate entities
- -- that the function result could outlive.
- Apply_Access_Discrims_Accessibility_Check (Expr, Func_Id);
- end if;
+ Apply_Accessibility_Check_For_Return (Expr, Func_Id);
Alloc_Expr := New_Copy_Tree (Expr);
Insert_Action_After (Init_After, Tag_Assign);
end if;
- -- Ada 2005 (AI95-344): If the result type is class-wide,
- -- insert a check that the level of the return expression's
- -- underlying type is not deeper than the level of the master
- -- enclosing the function.
-
-- AI12-043: The check is made immediately after the return
-- object is created.
- if Is_Class_Wide_Type (Etype (Func_Id)) then
- Apply_CW_Accessibility_Check (Expr_Q, Func_Id);
- end if;
-
- -- ??? Usually calls to Apply_CW_Accessibility_Check and to
- -- Apply_Access_Discrims_Accessibility_Check come in pairs.
- -- Do we need a (conditional) call here to A_A_D_A_C ?
+ Apply_Accessibility_Check_For_Return (Expr_Q, Func_Id);
end;
end if;
null;
else
- Apply_Accessibility_Check
+ Apply_Accessibility_Check_For_Parameter
(Operand, Target_Type, Insert_Node => Operand);
end if;
with Elists; use Elists;
with Expander; use Expander;
with Exp_Aggr; use Exp_Aggr;
-with Exp_Atag; use Exp_Atag;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch4; use Exp_Ch4;
with Exp_Ch7; use Exp_Ch7;
Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual);
end Add_Task_Actuals_To_Build_In_Place_Call;
- ----------------------------------------------
- -- Apply_Access_Discrims_Accesibility_Check --
- ----------------------------------------------
-
- procedure Apply_Access_Discrims_Accessibility_Check
- (Exp : Node_Id; Func : Entity_Id)
- is
- Loc : constant Source_Ptr := Sloc (Exp);
-
- -- Some of the code here in this procedure may need to be factored
- -- out at some point because it seems like some of the same
- -- functionality would be needed for accessibility checking of a
- -- return statement when the function result type is an anonymous
- -- access type (as opposed to a type that has an anonymous access
- -- discriminant).
- --
- -- Another case that is not addressed today is the case where
- -- we need to check an access discriminant subcomponent of the
- -- function result other than a discriminant of the function result.
- -- This can only happen if the function result type has an unconstrained
- -- subcomponent subtype that has an access discriminant (which implies
- -- that the function result type must be limited).
- --
- -- A further corner case of that corner case arises if the limited
- -- function result type is class-wide and it is not known statically
- -- that this access-discriminant-bearing subcomponent exists. The
- -- easiest way to address this properly would probably involve adding
- -- a new compiler-generated dispatching procedure; a dispatching call
- -- could then be used to perform the check in a context where we know
- -- statically the specific type of the function result. Finding a
- -- less important unimplemented case would be challenging.
-
- function Constraint_Bearing_Subtype_If_Any
- (Exp : Node_Id) return Node_Id;
- -- If we can locate a constrained subtype whose constraint applies
- -- to Exp, then return that. Otherwise, return Etype (Exp).
-
- function Discr_Expression
- (Typ : Entity_Id; Discr_Index : Positive) return Node_Id;
- -- Typ is a constrained discriminated subtype.
- -- Return the constraint expression for the indexed discriminant.
-
- function Has_Level_Tied_To_Explicitly_Aliased_Param
- (Constraint_Exp : Node_Id) return Boolean;
- -- Constraint_Exp is the value given for an access discriminant
- -- in a discriminant constraint for Exp. Return True iff the
- -- accessibility of the type of that discriminant of Exp is the level
- -- of an explicitly aliased parameter of Func. If true, this indicates
- -- that no check should be performed for this discriminant.
-
- ---------------------------------------
- -- Constraint_Bearing_Subtype_If_Any --
- ---------------------------------------
-
- function Constraint_Bearing_Subtype_If_Any
- (Exp : Node_Id) return Entity_Id
- is
- Result : Entity_Id := Etype (Exp);
- begin
- if Is_Constrained (Result) then
- return Result;
- end if;
-
- -- Look through expansion-generated levels of indirection
- -- to find a constrained subtype. Yuck. This comes up in
- -- some cases when the unexpanded source returns an aggregate.
-
- if Nkind (Exp) = N_Explicit_Dereference
- and then Nkind (Prefix (Exp)) = N_Identifier
- and then Ekind (Entity (Prefix (Exp))) = E_Constant
- then
- declare
- Acc_Const : Entity_Id := Entity (Prefix (Exp));
- Acc_Const_Value : Node_Id := Empty;
- begin
- -- look through constants initialized to constants
- loop
- exit when Nkind (Parent (Acc_Const)) /= N_Object_Declaration;
-
- Acc_Const_Value := Expression (Parent (Acc_Const));
-
- if Nkind (Acc_Const_Value) = N_Identifier
- and then Ekind (Entity (Acc_Const_Value)) = E_Constant
- then
- Acc_Const := Entity (Acc_Const_Value);
- else
- exit;
- end if;
- end loop;
-
- if Nkind (Acc_Const_Value) = N_Allocator
- and then Nkind (Expression (Acc_Const_Value))
- = N_Qualified_Expression
- then
- Result :=
- Etype (Expression (Acc_Const_Value));
- end if;
- end;
- end if;
-
- if Is_Constrained (Result) then
- return Result;
- end if;
-
- -- no constrained subtype found
- return Etype (Exp);
- end Constraint_Bearing_Subtype_If_Any;
-
- ----------------------
- -- Discr_Expression --
- ----------------------
-
- function Discr_Expression
- (Typ : Entity_Id; Discr_Index : Positive) return Node_Id
- is
- Constraint_Elmt : Elmt_Id :=
- First_Elmt (Discriminant_Constraint (Typ));
- begin
- for Skip in 1 .. Discr_Index - 1 loop
- Next_Elmt (Constraint_Elmt);
- end loop;
- return Node (Constraint_Elmt);
- end Discr_Expression;
-
- -------------------------------------------------
- -- Has_Level_Tied_To_Explicitly_Aliased_Param --
- -------------------------------------------------
-
- function Has_Level_Tied_To_Explicitly_Aliased_Param
- (Constraint_Exp : Node_Id) return Boolean
- is
- Discr_Exp : Node_Id := Constraint_Exp;
- Attr_Prefix : Node_Id;
- begin
- -- look through constants
- while Nkind (Discr_Exp) = N_Identifier
- and then Ekind (Entity (Discr_Exp)) = E_Constant
- and then Nkind (Parent (Entity (Discr_Exp))) = N_Object_Declaration
- loop
- Discr_Exp := Expression (Parent (Entity (Discr_Exp)));
- end loop;
-
- if Nkind (Discr_Exp) = N_Attribute_Reference
- and then Get_Attribute_Id
- (Attribute_Name (Discr_Exp)) = Attribute_Access
- then
- Attr_Prefix := Ultimate_Prefix (Prefix (Discr_Exp));
- if Is_Entity_Name (Attr_Prefix)
- and then Is_Explicitly_Aliased (Entity (Attr_Prefix))
- and then Scope (Entity (Attr_Prefix)) = Func
- then
- return True;
- end if;
- end if;
-
- return False;
- end Has_Level_Tied_To_Explicitly_Aliased_Param;
-
- Discr : Entity_Id := First_Discriminant (Etype (Exp));
- Discr_Index : Positive := 1;
- Discr_Exp : Node_Id;
-
- Constrained_Subtype : constant Entity_Id :=
- Constraint_Bearing_Subtype_If_Any (Exp);
- begin
- -- ??? Do not generate a check if version is Ada 95 (or earlier).
- -- It is unclear whether this is really correct, or is just a stopgap
- -- measure. Investigation is needed to decide how post-Ada-95 binding
- -- interpretation changes in RM 3.10.2 should interact with Ada 95's
- -- return-by-reference model for functions with limited result types
- -- (which was abandoned in Ada 2005).
-
- if Ada_Version <= Ada_95 then
- return;
- end if;
-
- -- If we are returning a function call then that function will
- -- perform the needed check.
-
- if Nkind (Unqualify (Exp)) = N_Function_Call then
- return;
- end if;
-
- -- ??? Cope with the consequences of the Disable_Tagged_Cases flag
- -- in accessibility.adb (which can cause the extra formal parameter
- -- needed for the check(s) generated here to be missing in the case
- -- of a tagged result type); this is a workaround and can
- -- prevent generation of a required check (or even a required
- -- legality check - see "statically too deep" check below).
-
- if No (Extra_Accessibility_Of_Result (Func)) then
- return;
- end if;
-
- Remove_Side_Effects (Exp);
-
- while Present (Discr) loop
- if Is_Anonymous_Access_Type (Etype (Discr)) then
- if Is_Constrained (Constrained_Subtype) then
- Discr_Exp :=
- New_Copy_Tree
- (Discr_Expression (Constrained_Subtype, Discr_Index));
- else
- Discr_Exp :=
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Exp),
- Selector_Name => New_Occurrence_Of (Discr, Loc));
- end if;
-
- if not Has_Level_Tied_To_Explicitly_Aliased_Param (Discr_Exp) then
- declare
- -- We could do this min operation earlier, as is done
- -- for other implicit level parameters. Motivation for
- -- doing this min operation (earlier or not) is as for
- -- Generate_Minimum_Accessibility (see sem_ch6.adb):
- -- if a level value is too big, then the caller and the
- -- callee disagree about what it means.
-
- Level_Of_Master_Of_Call : constant Node_Id :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Standard_Natural, Loc),
- Attribute_Name => Name_Min,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Scope_Depth (Func)),
- New_Occurrence_Of
- (Extra_Accessibility_Of_Result (Func), Loc)));
-
- Discrim_Level : Node_Id;
- begin
- Analyze (Level_Of_Master_Of_Call);
- Analyze (Discr_Exp);
-
- Discrim_Level :=
- Accessibility_Level (Discr_Exp, Level => Dynamic_Level);
- Analyze (Discrim_Level);
-
- if Nkind (Discrim_Level) = N_Integer_Literal
- and then Intval (Discrim_Level) > Scope_Depth (Func)
- then
- Error_Msg_N
- ("level of type of access discriminant value of "
- & "return expression is statically too deep",
- Enclosing_Declaration_Or_Statement (Exp));
- end if;
-
- Insert_Action (Exp,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => Discrim_Level,
- Right_Opnd => Level_Of_Master_Of_Call),
- Reason => PE_Accessibility_Check_Failed),
- Suppress => Access_Check);
- end;
- end if;
- end if;
-
- Next_Discriminant (Discr);
- Discr_Index := Discr_Index + 1;
- end loop;
- end Apply_Access_Discrims_Accessibility_Check;
-
- ----------------------------------
- -- Apply_CW_Accessibility_Check --
- ----------------------------------
-
- procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (Exp);
-
- begin
- -- CodePeer does not do anything useful on Ada.Tags.Type_Specific_Data
- -- components.
-
- if Ada_Version >= Ada_2005
- and then not CodePeer_Mode
- and then Tagged_Type_Expansion
- and then not Scope_Suppress.Suppress (Accessibility_Check)
- and then
- (Is_Class_Wide_Type (Etype (Exp))
- or else Nkind (Exp) in
- N_Type_Conversion | N_Unchecked_Type_Conversion
- or else (Is_Entity_Name (Exp)
- and then Is_Formal (Entity (Exp)))
- or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
- Scope_Depth (Enclosing_Dynamic_Scope (Func)))
- then
- declare
- Tag_Node : Node_Id;
-
- begin
- -- Ada 2005 (AI-251): In class-wide interface objects we displace
- -- "this" to reference the base of the object. This is required to
- -- get access to the TSD of the object.
-
- if Is_Class_Wide_Type (Etype (Exp))
- and then Is_Interface (Etype (Exp))
- then
- -- If the expression is an explicit dereference then we can
- -- directly displace the pointer to reference the base of
- -- the object.
-
- if Nkind (Exp) = N_Explicit_Dereference then
- Tag_Node :=
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Base_Address), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Address),
- Duplicate_Subexpr (Prefix (Exp)))))));
-
- -- Similar case to the previous one but the expression is a
- -- renaming of an explicit dereference.
-
- elsif Nkind (Exp) = N_Identifier
- and then Present (Renamed_Object (Entity (Exp)))
- and then Nkind (Renamed_Object (Entity (Exp)))
- = N_Explicit_Dereference
- then
- Tag_Node :=
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Base_Address), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Address),
- Duplicate_Subexpr
- (Prefix
- (Renamed_Object (Entity (Exp)))))))));
-
- -- Common case: obtain the address of the actual object and
- -- displace the pointer to reference the base of the object.
-
- else
- Tag_Node :=
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Base_Address), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Exp),
- Attribute_Name => Name_Address)))));
- end if;
- else
- Tag_Node :=
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Exp),
- Attribute_Name => Name_Tag);
- end if;
-
- -- Suppress junk access chacks on RE_Tag_Ptr
-
- Insert_Action (Exp,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Scope_Depth (Enclosing_Dynamic_Scope (Func)))),
- Reason => PE_Accessibility_Check_Failed),
- Suppress => Access_Check);
- end;
- end if;
- end Apply_CW_Accessibility_Check;
-
-----------------------
-- BIP_Formal_Suffix --
-----------------------
pragma Assert (Ada_Version >= Ada_2012);
- Apply_Accessibility_Check (Lhs, E_Formal, N);
+ Apply_Accessibility_Check_For_Parameter (Lhs, E_Formal, N);
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
end;
end if;
- -- Ada 2005 (AI95-344): If the result type is class-wide, then insert
- -- a check that the level of the return expression's underlying type
- -- is not deeper than the level of the master enclosing the function.
-
- -- AI12-043: The check is made immediately after the return object is
- -- created. This means that we do not apply it to the simple return
- -- generated by the expansion of an extended return statement.
-
- -- No runtime check needed in interface thunks since it is performed
- -- by the target primitive associated with the thunk.
-
- elsif Is_Class_Wide_Type (R_Type)
- and then not Comes_From_Extended_Return_Statement (N)
- and then not Is_Thunk (Scope_Id)
- then
- Apply_CW_Accessibility_Check (Exp, Scope_Id);
-
- -- Check that result's access discrims (if any) do not designate
- -- entities that the function result could outlive. See preceding
- -- comment about extended return statements and thunks.
-
- elsif Has_Anonymous_Access_Discriminant (Exp_Typ)
- and then not Comes_From_Extended_Return_Statement (N)
- and then not Is_Thunk (Scope_Id)
- then
- Apply_Access_Discrims_Accessibility_Check (Exp, Scope_Id);
-
-- Ada 2012 (AI05-0073): If the result subtype of the function is
-- defined by an access_definition designating a specific tagged
-- type T, a check is made that the result value is null or the tag
Suppress => All_Checks);
end if;
+ -- Generate a run-time accessibility check if needed
+
+ -- AI12-043: The check is made immediately after the return object is
+ -- created. This means that we do not apply it to the simple return
+ -- generated by the expansion of an extended return statement.
+
+ -- No run-time check needed in interface thunks since it is performed
+ -- by the target primitive associated with the thunk.
+
+ if not Comes_From_Extended_Return_Statement (N)
+ and then not Is_Thunk (Scope_Id)
+ then
+ Apply_Accessibility_Check_For_Return (Exp, Scope_Id);
+ end if;
+
-- If the result is of an unconstrained array subtype with fixed lower
-- bound, then sliding to that bound may be needed.
-- Create the extra actuals of the given call and add them to its
-- actual parameters list.
- procedure Apply_Access_Discrims_Accessibility_Check
- (Exp : Node_Id; Func : Entity_Id);
- -- Exp is an expression being returned from a function Func.
- -- If the result type of the function has access discriminants, insert
- -- checks that the accessibility level of each entity designated by an
- -- access discriminant of the result is not deeper than the level of the
- -- master of the call.
-
- procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id);
- -- Exp is an expression being returned from a function Func.
- -- Ada 2005 (AI95-344): If the result type is class-wide, insert a check
- -- that the level of the return expression's underlying type is not deeper
- -- than the level of the master enclosing the function. Always generate the
- -- check when the type of the return expression is class-wide, when it's a
- -- type conversion, or when it's a formal parameter. Otherwise suppress the
- -- check in the case where the return expression has a specific type whose
- -- level is known not to be statically deeper than the result type of the
- -- function.
-
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String;
-- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names
-- for build-in-place formal parameters of the given kind.
-- means that it is equivalent to Is_Expression_Function_Or_Completion
-- invoked on Spec_Id declared below and not to Is_Expression_Function.
- Body_Nod : Node_Id := Empty;
- Minimum_Acc_Objs : List_Id := No_List;
-
- Conformant : Boolean;
+ Acc_Objs : List_Id := No_List;
Desig_View : Entity_Id := Empty;
Exch_Views : Elist_Id := No_Elist;
Prot_Typ : Entity_Id := Empty;
-- body must be expanded separately to create a subprogram declaration
-- for it, in order to resolve internal calls to it from other protected
-- operations.
- --
- -- Possibly factor this with Exp_Dist.Copy_Specification ???
procedure Build_Subprogram_Declaration;
-- Create a matching subprogram declaration for subprogram body N
-- 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.
+ function Subprogram_Entity return Entity_Id is
+ (if Present (Spec_Id) then
+ (if Is_Protected_Type (Scope (Spec_Id))
+ and then Present (Protected_Body_Subprogram (Spec_Id))
+ then Protected_Body_Subprogram (Spec_Id)
+ else Spec_Id)
+ else Body_Id);
+ -- Return the entity of the subprogram whose N is the body, in other
+ -- words the E_Function or E_Procedure entity to be used as a scope.
+
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
(Extra_Access : Entity_Id;
Related_Form : Entity_Id := Empty)
is
- Loc : constant Source_Ptr := Sloc (Body_Nod);
- Form : Entity_Id;
- Obj_Node : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Decl : Node_Id;
+ Form : Entity_Id;
+
begin
-- When no related formal exists then we are dealing with an
-- extra accessibility formal for a function result.
Form := Related_Form;
end if;
- -- Create the minimum accessibility object
-
- Obj_Node :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Temporary
- (Loc, 'A', Extra_Access),
- Object_Definition => New_Occurrence_Of
- (Standard_Natural, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of
- (Standard_Natural, Loc),
- Attribute_Name => Name_Min,
- Expressions => New_List (
- Make_Integer_Literal (Loc,
- Scope_Depth (Body_Id)),
- New_Occurrence_Of
- (Extra_Access, Loc))));
-
- -- Add the new local object to the Minimum_Acc_Obj to
- -- be later prepended to the subprogram's list of
- -- declarations after we are sure all expansion is
- -- done.
-
- if Present (Minimum_Acc_Objs) then
- Prepend (Obj_Node, Minimum_Acc_Objs);
+ -- Declare the minimum accessibility object
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'A', Extra_Access),
+ Object_Definition => New_Occurrence_Of (Standard_Natural, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Standard_Natural, Loc),
+ Attribute_Name => Name_Min,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Scope_Depth (Body_Id)),
+ New_Occurrence_Of (Extra_Access, Loc))));
+
+ -- Add the new local object to the Minimum_Acc_Obj to be later
+ -- prepended to the subprogram's list of declarations after we
+ -- are sure all expansion is done.
+
+ if Present (Acc_Objs) then
+ Prepend (Decl, Acc_Objs);
else
- Minimum_Acc_Objs := New_List (Obj_Node);
+ Acc_Objs := New_List (Decl);
end if;
-- Register the object and analyze it
- Set_Minimum_Accessibility
- (Form, Defining_Identifier (Obj_Node));
+ Set_Minimum_Accessibility (Form, Defining_Identifier (Decl));
- Analyze (Obj_Node);
+ Analyze (Decl);
end Generate_Minimum_Accessibility;
-------------------------------------
Ignore_SPARK_Mode_Pragmas_In_Instance;
-- Save the Ghost and SPARK mode-related data to restore on exit
+ Conformant : Boolean;
Saved_In_Inlined_Body : Boolean;
-- Start of processing for Analyze_Subprogram_Body_Helper
-- in an actual to a call to a nested subprogram.
-- This method is used to supplement our "small integer model" for
- -- accessibility-check generation (for more information see
+ -- accessibility check generation (for more information see
-- Accessibility_Level).
-- Because we allow accessibility values greater than our expected value
-- This generated object is referred to as a "minimum accessibility
-- level."
- if Present (Spec_Id) or else Present (Body_Id) then
- Body_Nod := Unit_Declaration_Node (Body_Id);
+ -- Loop through formals if the subprogram is capable of accepting
+ -- a generated local object. If it is not, then it is also not
+ -- capable of having local subprograms meaning it would not need
+ -- a minimum accessibility level object anyway.
+ if Has_Declarations (N) then
declare
- Form : Entity_Id;
- begin
- -- Grab the appropriate formal depending on whether there exists
- -- an actual spec for the subprogram or whether we are dealing
- -- with a protected subprogram.
+ Subp_Id : constant Entity_Id := Subprogram_Entity;
- if Present (Spec_Id) then
- if Present (Protected_Body_Subprogram (Spec_Id)) then
- Form := First_Formal (Protected_Body_Subprogram (Spec_Id));
- else
- Form := First_Formal (Spec_Id);
- end if;
- else
- Form := First_Formal (Body_Id);
- end if;
-
- -- Loop through formals if the subprogram is capable of accepting
- -- a generated local object. If it is not then it is also not
- -- capable of having local subprograms meaning it would not need
- -- a minimum accessibility level object anyway.
+ Formal : Node_Id;
- if Present (Body_Nod)
- and then Has_Declarations (Body_Nod)
- and then Nkind (Body_Nod) /= N_Package_Specification
- then
- while Present (Form) loop
-
- if Present (Extra_Accessibility (Form))
- and then No (Minimum_Accessibility (Form))
- then
- -- Generate the minimum accessibility level object
+ begin
+ Formal := First_Formal (Subp_Id);
+ while Present (Formal) loop
+ -- Generate the minimum accessibility level object:
- -- A60b : constant natural := natural'min(1, paramL);
+ -- Ann : constant natural := natural'min(1, paramL);
- Generate_Minimum_Accessibility
- (Extra_Accessibility (Form), Form);
- end if;
+ if Present (Extra_Accessibility (Formal)) then
+ Generate_Minimum_Accessibility
+ (Extra_Accessibility (Formal), Formal);
+ end if;
- Next_Formal (Form);
- end loop;
+ Next_Formal (Formal);
+ end loop;
- -- Generate the minimum accessibility level object for the
- -- function's Extra_Accessibility_Of_Result.
+ -- Generate the minimum accessibility level object for the
+ -- function's Extra_Accessibility_Of_Result:
- -- A31b : constant natural := natural'min (2, funcL);
+ -- Ann : constant natural := natural'min (1, funcL);
- if Ekind (Body_Id) = E_Function
- and then Present (Extra_Accessibility_Of_Result (Body_Id))
- then
- Generate_Minimum_Accessibility
- (Extra_Accessibility_Of_Result (Body_Id));
+ if Ekind (Subp_Id) = E_Function
+ and then Present (Extra_Accessibility_Of_Result (Subp_Id))
+ then
+ Generate_Minimum_Accessibility
+ (Extra_Accessibility_Of_Result (Subp_Id));
- -- Replace the Extra_Accessibility_Of_Result with the new
- -- minimum accessibility object.
+ -- Replace the Extra_Accessibility_Of_Result with the new
+ -- minimum accessibility object.
- Set_Extra_Accessibility_Of_Result
- (Body_Id, Minimum_Accessibility
- (Extra_Accessibility_Of_Result (Body_Id)));
- end if;
+ Set_Extra_Accessibility_Of_Result
+ (Subp_Id, Minimum_Accessibility
+ (Extra_Accessibility_Of_Result (Subp_Id)));
end if;
end;
end if;
Inspect_Deferred_Constant_Completion (Declarations (N));
Analyze (Handled_Statement_Sequence (N));
- -- Add the generated minimum accessibility objects to the subprogram
- -- body's list of declarations after analysis of the statements and
- -- contracts.
+ -- Prepend the declaration of minimum accessibility objects to the list
+ -- of declarations after analysis of the statements and contracts.
- while Is_Non_Empty_List (Minimum_Acc_Objs) loop
- if Present (Declarations (Body_Nod)) then
- Prepend (Remove_Head (Minimum_Acc_Objs), Declarations (Body_Nod));
- else
- Set_Declarations
- (Body_Nod, New_List (Remove_Head (Minimum_Acc_Objs)));
- end if;
- end loop;
+ Prepend_List (Acc_Objs, Declarations (N));
-- Deal with end of scope processing for the body
end if;
end if;
+ -- Restore the Extra_Accessibility_Of_Result object that was clobbered
+ -- earlier, so that the name of the local temporary does not leak.
+
+ if Has_Declarations (N) then
+ declare
+ Subp_Id : constant Entity_Id := Subprogram_Entity;
+
+ begin
+ if Ekind (Subp_Id) = E_Function
+ and then Present (Extra_Accessibility_Of_Result (Subp_Id))
+ then
+ Set_Extra_Accessibility_Of_Result (Subp_Id,
+ Related_Expression (Extra_Accessibility_Of_Result (Subp_Id)));
+ end if;
+ end;
+ end if;
+
-- If we are compiling an entry wrapper, remove the enclosing
-- synchronized object from the stack.
Original : Entity_Id;
Root : Entity_Id;
- function Has_No_Task_Parts_Enabled (E : Entity_Id) return Boolean
- is (Has_Enabled_Aspect (E, Aspect_No_Task_Parts));
+ function Has_No_Task_Parts_Enabled (E : Entity_Id) return Boolean is
+ (Has_Enabled_Aspect (E, Aspect_No_Task_Parts));
function Collect_Ancestors_With_No_Task_Parts is new
Collect_Types_In_Hierarchy (Predicate => Has_No_Task_Parts_Enabled);
projects / thirdparty / gcc.git / commitdiff
