-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, 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- --
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Dbug; use Exp_Dbug;
-with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
-- Create the declaration for an inequality operator that is implicitly
-- created by a user-defined equality operator that yields a boolean.
+ procedure Preanalyze_Formal_Expression (N : Node_Id; T : Entity_Id);
+ -- Preanalysis of default expressions of subprogram formals. N is the
+ -- expression to be analyzed and T is the expected type.
+
procedure Set_Formal_Validity (Formal_Id : Entity_Id);
-- Formal_Id is an formal parameter entity. This procedure deals with
-- setting the proper validity status for this entity, which depends on
Analyze_Subprogram_Specification (Specification (N));
begin
- Check_SPARK_05_Restriction ("abstract subprogram is not allowed", N);
-
Generate_Definition (Subp_Id);
-- Set the SPARK mode from the current context (may be overwritten later
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
- (N_Id => Subp_Id,
- Checks => True);
+ (N_Id => Subp_Id,
+ Checks => True,
+ Warnings => True);
Set_Is_Abstract_Subprogram (Subp_Id);
New_Overloaded_Entity (Subp_Id);
LocX : constant Source_Ptr := Sloc (Expr);
Spec : constant Node_Id := Specification (N);
- procedure Freeze_Expr_Types (Def_Id : Entity_Id);
- -- N is an expression function that is a completion and Def_Id its
- -- defining entity. Freeze before N all the types referenced by the
- -- expression of the function.
-
- -----------------------
- -- Freeze_Expr_Types --
- -----------------------
-
- procedure Freeze_Expr_Types (Def_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), Def_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 (Def_Id);
- Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id);
- Dup_Expr : constant Node_Id := Cloned_Expression;
-
- -- Start of processing for Freeze_Expr_Types
-
- begin
- -- 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 (Def_Id);
- Install_Formals (Def_Id);
- Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
-
- Preanalyze_Spec_Expression (Dup_Expr, Etype (Def_Id));
-
- Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
- End_Scope;
-
- -- Restore certain attributes of Def_Id since the preanalysis may
- -- have introduced itypes to this scope, thus modifying attributes
- -- First_Entity and Last_Entity.
-
- Set_First_Entity (Def_Id, Saved_First_Entity);
- Set_Last_Entity (Def_Id, Saved_Last_Entity);
-
- if Present (Last_Entity (Def_Id)) then
- Set_Next_Entity (Last_Entity (Def_Id), Empty);
- end if;
-
- -- Freeze all types referenced in the expression
-
- Freeze_References (Dup_Expr);
- end Freeze_Expr_Types;
-
-- Local variables
Asp : Node_Id;
Orig_N : Node_Id;
Ret : Node_Id;
- Def_Id : Entity_Id := Empty;
- Prev : Entity_Id;
+ Def_Id : Entity_Id := Empty;
+ 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.
-- As elsewhere, we do not emit freeze nodes within a generic unit.
if not Inside_A_Generic then
- Freeze_Expr_Types (Def_Id);
+ Freeze_Expr_Types
+ (Def_Id => Def_Id,
+ Typ => Etype (Def_Id),
+ Expr => Expr,
+ N => N);
end if;
-- For navigation purposes, indicate that the function is a body
-- Once the aspects of the generated body have been analyzed, create
-- a copy for ASIS purposes and associate it with the original node.
+ -- Is this still needed???
if Has_Aspects (N) then
Set_Aspect_Specifications (Orig_N,
-- Once the aspects of the generated spec have been analyzed, create
-- a copy for ASIS purposes and associate it with the original node.
+ -- Is this still needed???
if Has_Aspects (N) then
Set_Aspect_Specifications (Orig_N,
Set_Corresponding_Body (N, Defining_Entity (New_Body));
Set_Corresponding_Spec (New_Body, Def_Id);
- -- Within a generic pre-analyze the original expression for name
+ -- Within a generic preanalyze the original expression for name
-- capture. The body is also generated but plays no role in
-- this because it is not part of the original source.
if not Inside_A_Generic then
Push_Scope (Def_Id);
Install_Formals (Def_Id);
- Preanalyze_Spec_Expression (Expr, Typ);
+ Preanalyze_Formal_Expression (Expr, Typ);
Check_Limited_Return (Original_Node (N), Expr, Typ);
End_Scope;
end if;
Related_Nod => Original_Node (N));
end if;
- -- If the return expression is a static constant, we suppress warning
- -- messages on unused formals, which in most cases will be noise.
+ -- We must enforce checks for unreferenced formals in our newly
+ -- generated function, so we propagate the referenced flag from the
+ -- original spec to the new spec as well as setting Comes_From_Source.
+
+ if Present (Parameter_Specifications (New_Spec)) then
+ declare
+ Form_New_Def : Entity_Id;
+ Form_New_Spec : Entity_Id;
+ Form_Old_Def : Entity_Id;
+ Form_Old_Spec : Entity_Id;
+
+ begin
+ Form_New_Spec := First (Parameter_Specifications (New_Spec));
+ Form_Old_Spec := First (Parameter_Specifications (Spec));
+
+ while Present (Form_New_Spec) and then Present (Form_Old_Spec) loop
+ Form_New_Def := Defining_Identifier (Form_New_Spec);
+ Form_Old_Def := Defining_Identifier (Form_Old_Spec);
+
+ Set_Comes_From_Source (Form_New_Def, True);
+
+ -- Because of the usefulness of unreferenced controlling
+ -- formals we exempt them from unreferenced warnings by marking
+ -- them as always referenced.
+
+ Set_Referenced (Form_Old_Def,
+ (Is_Formal (Form_Old_Def)
+ and then Is_Controlling_Formal (Form_Old_Def))
+ or else Referenced (Form_Old_Def));
- Set_Is_Trivial_Subprogram
- (Defining_Entity (New_Body), Is_OK_Static_Expression (Expr));
+ Next (Form_New_Spec);
+ Next (Form_Old_Spec);
+ end loop;
+ end;
+ end if;
end Analyze_Expression_Function;
----------------------------------------
R_Type : constant Entity_Id := Etype (Scope_Id);
-- Function result subtype
- procedure Check_Aggregate_Accessibility (Aggr : Node_Id);
- -- Apply legality rule of 6.5 (5.8) to the access discriminants of an
+ procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id);
+ -- Apply legality rule of 6.5 (5.9) to the access discriminants of an
-- aggregate in a return statement.
procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
-- Check that the return_subtype_indication properly matches the result
-- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
- -----------------------------------
- -- Check_Aggregate_Accessibility --
- -----------------------------------
+ ------------------------------------------
+ -- Check_Return_Construct_Accessibility --
+ ------------------------------------------
- procedure Check_Aggregate_Accessibility (Aggr : Node_Id) is
- Typ : constant Entity_Id := Etype (Aggr);
- Assoc : Node_Id;
- Discr : Entity_Id;
- Expr : Node_Id;
- Obj : Node_Id;
+ procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is
+ Assoc : Node_Id;
+ Agg : Node_Id := Empty;
+ Discr : Entity_Id;
+ Expr : Node_Id;
+ Obj : Node_Id;
+ Process_Exprs : Boolean := False;
+ Return_Con : Node_Id;
begin
- if Is_Record_Type (Typ) and then Has_Discriminants (Typ) then
- Discr := First_Discriminant (Typ);
- Assoc := First (Component_Associations (Aggr));
- while Present (Discr) loop
- if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
+ -- Only perform checks on record types with access discriminants and
+ -- non-internally generated functions.
+
+ if not Is_Record_Type (R_Type)
+ or else not Has_Discriminants (R_Type)
+ or else not Comes_From_Source (Return_Stmt)
+ then
+ return;
+ end if;
+
+ -- We are only interested in return statements
+
+ if not Nkind_In (Return_Stmt, N_Extended_Return_Statement,
+ N_Simple_Return_Statement)
+ then
+ return;
+ end if;
+
+ -- Fetch the object from the return statement, in the case of a
+ -- simple return statement the expression is part of the node.
+
+ if Nkind (Return_Stmt) = N_Extended_Return_Statement then
+ -- Obtain the object definition from the expanded extended return
+
+ Return_Con := First (Return_Object_Declarations (Return_Stmt));
+ while Present (Return_Con) loop
+ -- Inspect the original node to avoid object declarations
+ -- expanded into renamings.
+
+ if Nkind (Original_Node (Return_Con)) = N_Object_Declaration
+ and then Comes_From_Source (Original_Node (Return_Con))
+ then
+ exit;
+ end if;
+
+ Nlists.Next (Return_Con);
+ end loop;
+
+ pragma Assert (Present (Return_Con));
+
+ -- Could be dealing with a renaming
+
+ Return_Con := Original_Node (Return_Con);
+ else
+ Return_Con := Return_Stmt;
+ end if;
+
+ -- We may need to check an aggregate or a subtype indication
+ -- depending on how the discriminants were specified and whether
+ -- we are looking at an extended return statement.
+
+ if Nkind (Return_Con) = N_Object_Declaration
+ and then Nkind (Object_Definition (Return_Con))
+ = N_Subtype_Indication
+ then
+ Assoc := Original_Node
+ (First
+ (Constraints
+ (Constraint (Object_Definition (Return_Con)))));
+ else
+ -- Qualified expressions may be nested
+
+ Agg := Original_Node (Expression (Return_Con));
+ while Nkind (Agg) = N_Qualified_Expression loop
+ Agg := Original_Node (Expression (Agg));
+ end loop;
+
+ -- If we are looking at an aggregate instead of a function call we
+ -- can continue checking accessibility for the supplied
+ -- discriminant associations.
+
+ if Nkind (Agg) = N_Aggregate then
+ if Present (Expressions (Agg)) then
+ Assoc := First (Expressions (Agg));
+ Process_Exprs := True;
+ else
+ Assoc := First (Component_Associations (Agg));
+ end if;
+
+ -- Otherwise the expression is not of interest ???
+
+ else
+ return;
+ end if;
+ end if;
+
+ -- Move through the discriminants checking the accessibility level
+ -- of each co-extension's associated expression.
+
+ Discr := First_Discriminant (R_Type);
+ while Present (Discr) loop
+ if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
+
+ if Nkind (Assoc) = N_Attribute_Reference then
+ Expr := Assoc;
+ elsif Nkind_In (Assoc, N_Component_Association,
+ N_Discriminant_Association)
+ then
Expr := Expression (Assoc);
+ else
+ Expr := Empty;
+ end if;
- if Nkind (Expr) = N_Attribute_Reference
- and then Attribute_Name (Expr) /= Name_Unrestricted_Access
- then
- Obj := Prefix (Expr);
- while Nkind_In (Obj, N_Indexed_Component,
+ -- This anonymous access discriminant has an associated
+ -- expression which needs checking.
+
+ if Present (Expr)
+ and then Nkind (Expr) = N_Attribute_Reference
+ and then Attribute_Name (Expr) /= Name_Unrestricted_Access
+ then
+ -- Obtain the object to perform static checks on by moving
+ -- up the prefixes in the expression taking into account
+ -- named access types and renamed objects within the
+ -- expression.
+
+ Obj := Original_Node (Prefix (Expr));
+ loop
+ while Nkind_In (Obj, N_Explicit_Dereference,
+ N_Indexed_Component,
N_Selected_Component)
loop
- Obj := Prefix (Obj);
+ -- When we encounter a named access type then we can
+ -- ignore accessibility checks on the dereference.
+
+ if Ekind (Etype (Original_Node (Prefix (Obj))))
+ in E_Access_Type ..
+ E_Access_Protected_Subprogram_Type
+ then
+ if Nkind (Obj) = N_Selected_Component then
+ Obj := Selector_Name (Obj);
+ else
+ Obj := Original_Node (Prefix (Obj));
+ end if;
+ exit;
+ end if;
+
+ Obj := Original_Node (Prefix (Obj));
end loop;
- -- Do not check aliased formals or function calls. A
- -- run-time check may still be needed ???
+ if Nkind (Obj) = N_Selected_Component then
+ Obj := Selector_Name (Obj);
+ end if;
- if Is_Entity_Name (Obj)
- and then Comes_From_Source (Obj)
- then
- if Is_Formal (Entity (Obj))
- and then Is_Aliased (Entity (Obj))
- then
- null;
+ -- Check for renamings
- elsif Object_Access_Level (Obj) >
- Scope_Depth (Scope (Scope_Id))
- then
- Error_Msg_N
- ("access discriminant in return aggregate would "
- & "be a dangling reference", Obj);
- end if;
+ pragma Assert (Is_Entity_Name (Obj));
+
+ if Present (Renamed_Object (Entity (Obj))) then
+ Obj := Renamed_Object (Entity (Obj));
+ else
+ exit;
end if;
+ end loop;
+
+ -- Do not check aliased formals or function calls. A
+ -- run-time check may still be needed ???
+
+ if Is_Formal (Entity (Obj))
+ and then Is_Aliased (Entity (Obj))
+ then
+ null;
+
+ elsif Object_Access_Level (Obj) >
+ Scope_Depth (Scope (Scope_Id))
+ then
+ Error_Msg_N
+ ("access discriminant in return aggregate would "
+ & "be a dangling reference", Obj);
end if;
end if;
+ end if;
- Next_Discriminant (Discr);
- end loop;
- end if;
- end Check_Aggregate_Accessibility;
+ Next_Discriminant (Discr);
+
+ if not Is_List_Member (Assoc) then
+ Assoc := Empty;
+ else
+ Nlists.Next (Assoc);
+ end if;
+
+ -- After aggregate expressions, examine component associations if
+ -- present.
+
+ if No (Assoc) then
+ if Present (Agg)
+ and then Process_Exprs
+ and then Present (Component_Associations (Agg))
+ then
+ Assoc := First (Component_Associations (Agg));
+ Process_Exprs := False;
+ else
+ exit;
+ end if;
+ end if;
+ end loop;
+ end Check_Return_Construct_Accessibility;
-------------------------------------
-- Check_Return_Subtype_Indication --
---------------------
Expr : Node_Id;
- Obj_Decl : Node_Id;
+ Obj_Decl : Node_Id := Empty;
-- Start of processing for Analyze_Function_Return
Resolve (Expr, R_Type);
Check_Limited_Return (N, Expr, R_Type);
- if Present (Expr) and then Nkind (Expr) = N_Aggregate then
- Check_Aggregate_Accessibility (Expr);
- end if;
- end if;
-
- -- RETURN only allowed in SPARK as the last statement in function
-
- if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
- and then
- (Nkind (Parent (Parent (N))) /= N_Subprogram_Body
- or else Present (Next (N)))
- then
- Check_SPARK_05_Restriction
- ("RETURN should be the last statement in function", N);
+ Check_Return_Construct_Accessibility (N);
end if;
-
else
- Check_SPARK_05_Restriction ("extended RETURN is not allowed", N);
Obj_Decl := Last (Return_Object_Declarations (N));
-- Analyze parts specific to extended_return_statement:
Check_References (Stm_Entity);
+ Check_Return_Construct_Accessibility (N);
+
-- Check RM 6.5 (5.9/3)
if Has_Aliased then
-- Case of Expr present
- if Present (Expr)
+ if Present (Expr) then
- -- Defend against previous errors
+ -- Defend against previous errors
+
+ if Nkind (Expr) = N_Empty
+ or else No (Etype (Expr))
+ then
+ return;
+ end if;
- and then Nkind (Expr) /= N_Empty
- and then Present (Etype (Expr))
- then
-- Apply constraint check. Note that this is done before the implicit
-- conversion of the expression done for anonymous access types to
-- ensure correct generation of the null-excluding check associated
- -- with null-excluding expressions found in return statements.
+ -- with null-excluding expressions found in return statements. We
+ -- don't need a check if the subtype of the return object is the
+ -- same as the result subtype of the function.
+
+ if Nkind (N) /= N_Extended_Return_Statement
+ or else Nkind (Obj_Decl) /= N_Object_Declaration
+ or else Nkind (Object_Definition (Obj_Decl)) not in N_Has_Entity
+ or else Entity (Object_Definition (Obj_Decl)) /= R_Type
+ then
+ Apply_Constraint_Check (Expr, R_Type);
+ end if;
- Apply_Constraint_Check (Expr, R_Type);
+ -- The return value is converted to the return type of the function,
+ -- which implies a predicate check if the return type is predicated.
+ -- We do not apply the check to a case expression because it will
+ -- be expanded into a series of return statements, each of which
+ -- will receive a predicate check.
+
+ if Nkind (Expr) /= N_Case_Expression then
+ Apply_Predicate_Check (Expr, R_Type);
+ end if;
-- Ada 2005 (AI-318-02): When the result type is an anonymous access
-- type, apply an implicit conversion of the expression to that type
-- subprogram body.
if Has_Aspects (N) then
- Analyze_Aspect_Specifications_On_Body_Or_Stub (N);
+ Analyze_Aspects_On_Subprogram_Body_Or_Stub (N);
end if;
Analyze_Declarations (Declarations (N));
Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);
Update_Use_Clause_Chain;
+ Validate_Categorization_Dependency (N, Gen_Id);
End_Scope;
Check_Subprogram_Order (N);
-- Analyze_Null_Procedure --
----------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos that jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Null_Procedure
(N : Node_Id;
Is_Completion : out Boolean)
is
- Loc : constant Source_Ptr := Sloc (N);
- Spec : constant Node_Id := Specification (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Spec : constant Node_Id := Specification (N);
+
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
+ Saved_ISMP : constant Boolean :=
+ Ignore_SPARK_Mode_Pragmas_In_Instance;
+ -- Save the Ghost and SPARK mode-related data to restore on exit
+
Designator : Entity_Id;
Form : Node_Id;
Null_Body : Node_Id := Empty;
Prev : Entity_Id;
begin
+ Prev := Current_Entity_In_Scope (Defining_Entity (Spec));
+
+ -- A null procedure is Ghost when it is stand-alone and is subject to
+ -- pragma Ghost, or when the corresponding spec is Ghost. Set the mode
+ -- now, to ensure that any nodes generated during analysis and expansion
+ -- are properly marked as Ghost.
+
+ if Present (Prev) then
+ Mark_And_Set_Ghost_Body (N, Prev);
+ end if;
+
-- Capture the profile of the null procedure before analysis, for
-- expansion at the freeze point and at each point of call. The body is
-- used if the procedure has preconditions, or if it is a completion. In
-- and set minimal semantic information on the original declaration,
-- which is rewritten as a null statement.
- Prev := Current_Entity_In_Scope (Defining_Entity (Spec));
-
if Present (Prev) and then Is_Generic_Subprogram (Prev) then
Insert_Before (N, Null_Body);
Set_Ekind (Defining_Entity (N), Ekind (Prev));
Rewrite (N, Make_Null_Statement (Loc));
Analyze_Generic_Subprogram_Body (Null_Body, Prev);
Is_Completion := True;
- return;
+
+ goto Leave;
else
-- Resolve the types of the formals now, because the freeze point may
Rewrite (N, Null_Body);
Analyze (N);
end if;
+
+ <<Leave>>
+ Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
+ Restore_Ghost_Region (Saved_GM, Saved_IGR);
end Analyze_Null_Procedure;
-----------------------------
----------------------------
-- WARNING: This routine manages Ghost regions. Return statements must be
- -- replaced by gotos which jump to the end of the routine and restore the
+ -- replaced by gotos that jump to the end of the routine and restore the
-- Ghost mode.
procedure Analyze_Procedure_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Name (N);
- Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
- -- Save the Ghost mode to restore on exit
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
+ -- Save the Ghost-related attributes to restore on exit
Actual : Node_Id;
New_N : Node_Id;
begin
if Is_Tagged_Type (Typ)
and then Present (First_Formal (Subp))
- and then Etype (First_Formal (Subp)) = Typ
+ and then (Etype (First_Formal (Subp)) = Typ
+ or else
+ Class_Wide_Type (Etype (First_Formal (Subp))) = Typ)
and then Try_Object_Operation (P)
then
return;
end if;
<<Leave>>
- Restore_Ghost_Mode (Saved_GM);
+ Restore_Ghost_Region (Saved_GM, Saved_IGR);
end Analyze_Procedure_Call;
------------------------------
if Result_Definition (N) /= Error then
if Nkind (Result_Definition (N)) = N_Access_Definition then
- Check_SPARK_05_Restriction
- ("access result is not allowed", Result_Definition (N));
-- Ada 2005 (AI-254): Handle anonymous access to subprograms
Typ := Entity (Result_Definition (N));
Set_Etype (Designator, Typ);
- -- Unconstrained array as result is not allowed in SPARK
-
- if Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
- Check_SPARK_05_Restriction
- ("returning an unconstrained array is not allowed",
- Result_Definition (N));
- end if;
-
-- Ada 2005 (AI-231): Ensure proper usage of null exclusion
Null_Exclusion_Static_Checks (N);
-- the subprogram, or to perform conformance checks.
-- WARNING: This routine manages Ghost regions. Return statements must be
- -- replaced by gotos which jump to the end of the routine and restore the
+ -- replaced by gotos that jump to the end of the routine and restore the
-- Ghost mode.
procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is
Specification => Copy_Subprogram_Spec (Body_Spec));
Set_Comes_From_Source (Subp_Decl, True);
+ -- Also mark parameters as coming from source
+
+ if Present (Parameter_Specifications (Specification (Subp_Decl))) then
+ declare
+ Form : Entity_Id;
+ begin
+ Form :=
+ First (Parameter_Specifications (Specification (Subp_Decl)));
+
+ while Present (Form) loop
+ Set_Comes_From_Source (Defining_Identifier (Form), True);
+ Next (Form);
+ end loop;
+ end;
+ end if;
+
-- Relocate the aspects and relevant pragmas from the subprogram body
-- to the generated spec because it acts as the initial declaration.
-- If procedure with No_Return, check returns
- elsif Nkind (Body_Spec) = N_Procedure_Specification
- and then Present (Spec_Id)
- and then No_Return (Spec_Id)
- then
- Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
- end if;
-
- -- Special checks in SPARK mode
-
- if Nkind (Body_Spec) = N_Function_Specification then
-
- -- In SPARK mode, last statement of a function should be a return
-
- declare
- Stat : constant Node_Id := Last_Source_Statement (HSS);
- begin
- if Present (Stat)
- and then not Nkind_In (Stat, N_Simple_Return_Statement,
- N_Extended_Return_Statement)
- then
- Check_SPARK_05_Restriction
- ("last statement in function should be RETURN", Stat);
- end if;
- end;
-
- -- In SPARK mode, verify that a procedure has no return
-
elsif Nkind (Body_Spec) = N_Procedure_Specification then
if Present (Spec_Id) then
Id := Spec_Id;
Id := Body_Id;
end if;
- -- Would be nice to point to return statement here, can we
- -- borrow the Check_Returns procedure here ???
-
- if Return_Present (Id) then
- Check_SPARK_05_Restriction
- ("procedure should not have RETURN", N);
+ if No_Return (Id) then
+ Check_Returns (HSS, 'P', Missing_Ret, Id);
end if;
end if;
end Check_Missing_Return;
end if;
if not Is_Frozen (Typ) then
- Set_Is_Frozen (Typ);
- Append_New_Elmt (Typ, Result);
+ if Scope (Typ) /= Current_Scope then
+ Set_Is_Frozen (Typ);
+ Append_New_Elmt (Typ, Result);
+ else
+ Freeze_Before (N, Typ);
+ end if;
end if;
end Mask_Type;
then
null;
- elsif not Present (Overridden_Operation (Spec_Id)) then
+ -- Overridden controlled primitives may have had their
+ -- Overridden_Operation field cleared according to the setting of
+ -- the Is_Hidden flag. An issue arises, however, when analyzing
+ -- an instance that may have manipulated the flag during
+ -- expansion. As a result, we add an exception for this case.
+
+ elsif not Present (Overridden_Operation (Spec_Id))
+ and then not (Nam_In (Chars (Spec_Id), Name_Adjust,
+ Name_Finalize,
+ Name_Initialize)
+ and then In_Instance)
+ then
Error_Msg_NE
("subprogram& is not overriding", Body_Spec, Spec_Id);
-- Local variables
+ Body_Nod : Node_Id := Empty;
+ Minimum_Acc_Objs : List_Id := No_List;
+
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
+ Saved_EA : constant Boolean := Expander_Active;
Saved_ISMP : constant Boolean :=
Ignore_SPARK_Mode_Pragmas_In_Instance;
-- Save the Ghost and SPARK mode-related data to restore on exit
-- Start of processing for Analyze_Subprogram_Body_Helper
begin
- -- A [generic] subprogram body "freezes" the contract of the nearest
+ -- A [generic] subprogram body freezes the contract of the nearest
-- enclosing package body and all other contracts encountered in the
-- same declarative part up to and excluding the subprogram body:
-- with Refined_Depends => (Input => Constit) ...
-- This ensures that any annotations referenced by the contract of the
- -- [generic] subprogram body are available. This form of "freezing" is
+ -- [generic] subprogram body are available. This form of freezing is
-- decoupled from the usual Freeze_xxx mechanism because it must also
-- work in the context of generics where normal freezing is disabled.
- -- Only bodies coming from source should cause this type of "freezing".
+ -- Only bodies coming from source should cause this type of freezing.
-- Expression functions that act as bodies and complete an initial
-- declaration must be included in this category, hence the use of
-- Original_Node.
if Comes_From_Source (Original_Node (N)) then
- Analyze_Previous_Contracts (N);
+ Freeze_Previous_Contracts (N);
end if;
-- Generic subprograms are handled separately. They always have a
if Is_Generic_Subprogram (Prev_Id) then
Spec_Id := Prev_Id;
- -- A subprogram body is Ghost when it is stand alone and subject
+ -- A subprogram body is Ghost when it is stand-alone and subject
-- to pragma Ghost or when the corresponding spec is Ghost. Set
-- the mode now to ensure that any nodes generated during analysis
-- and expansion are properly marked as Ghost.
Mark_And_Set_Ghost_Body (N, Spec_Id);
+ -- If the body completes the initial declaration of a compilation
+ -- unit which is subject to pragma Elaboration_Checks, set the
+ -- model specified by the pragma because it applies to all parts
+ -- of the unit.
+
+ Install_Elaboration_Model (Spec_Id);
+
Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
if Is_Private_Concurrent_Primitive (Body_Id) then
Spec_Id := Disambiguate_Spec;
- -- A subprogram body is Ghost when it is stand alone and
+ -- A subprogram body is Ghost when it is stand-alone and
-- subject to pragma Ghost or when the corresponding spec is
-- Ghost. Set the mode now to ensure that any nodes generated
-- during analysis and expansion are properly marked as Ghost.
Mark_And_Set_Ghost_Body (N, Spec_Id);
+ -- If the body completes a compilation unit which is subject
+ -- to pragma Elaboration_Checks, set the model specified by
+ -- the pragma because it applies to all parts of the unit.
+
+ Install_Elaboration_Model (Spec_Id);
+
else
Spec_Id := Find_Corresponding_Spec (N);
- -- A subprogram body is Ghost when it is stand alone and
+ -- A subprogram body is Ghost when it is stand-alone and
-- subject to pragma Ghost or when the corresponding spec is
-- Ghost. Set the mode now to ensure that any nodes generated
-- during analysis and expansion are properly marked as Ghost.
Mark_And_Set_Ghost_Body (N, Spec_Id);
+ -- If the body completes a compilation unit which is subject
+ -- to pragma Elaboration_Checks, set the model specified by
+ -- the pragma because it applies to all parts of the unit.
+
+ Install_Elaboration_Model (Spec_Id);
+
-- In GNATprove mode, if the body has no previous spec, create
-- one so that the inlining machinery can operate properly.
-- Transfer aspects, if any, to the new spec, so that they
if No (Spec_Id) and then GNATprove_Mode
- -- Inlining does not apply during pre-analysis of code
+ -- Inlining does not apply during preanalysis of code
and then Full_Analysis
else
Spec_Id := Corresponding_Spec (N);
- -- A subprogram body is Ghost when it is stand alone and subject
+ -- A subprogram body is Ghost when it is stand-alone and subject
-- to pragma Ghost or when the corresponding spec is Ghost. Set
-- the mode now to ensure that any nodes generated during analysis
-- and expansion are properly marked as Ghost.
Mark_And_Set_Ghost_Body (N, Spec_Id);
+
+ -- If the body completes the initial declaration of a compilation
+ -- unit which is subject to pragma Elaboration_Checks, set the
+ -- model specified by the pragma because it applies to all parts
+ -- of the unit.
+
+ Install_Elaboration_Model (Spec_Id);
end if;
end if;
+ -- Deactivate expansion inside the body of ignored Ghost entities,
+ -- as this code will ultimately be ignored. This avoids requiring the
+ -- presence of run-time units which are not needed. Only do this for
+ -- user entities, as internally generated entitities might still need
+ -- to be expanded (e.g. those generated for types).
+
+ if Present (Ignored_Ghost_Region)
+ and then Comes_From_Source (Body_Id)
+ then
+ Expander_Active := False;
+ end if;
+
-- Previously we scanned the body to look for nested subprograms, and
-- rejected an inline directive if nested subprograms were present,
-- because the back-end would generate conflicting symbols for the
-- the freeze actions that include the bodies. In particular, extra
-- formals for accessibility or for return-in-place may need to be
-- generated. Freeze nodes, if any, are inserted before the current
- -- body. These freeze actions are also needed in ASIS mode and in
- -- Compile_Only mode to enable the proper back-end type annotations.
- -- They are necessary in any case to insure order of elaboration
+ -- body. These freeze actions are also needed in Compile_Only mode to
+ -- enable the proper back-end type annotations.
+ -- They are necessary in any case to ensure proper elaboration order
-- in gigi.
- if not Is_Frozen (Spec_Id)
+ if Nkind (N) = N_Subprogram_Body
+ and then Was_Expression_Function (N)
+ and then not Has_Completion (Spec_Id)
+ and then Serious_Errors_Detected = 0
and then (Expander_Active
- or else ASIS_Mode
- or else (Operating_Mode = Check_Semantics
- and then Serious_Errors_Detected = 0))
+ or else Operating_Mode = Check_Semantics
+ or else Is_Ignored_Ghost_Entity (Spec_Id))
then
-- The body generated for an expression function that is not a
-- completion is a freeze point neither for the profile nor for
-- anything else. That's why, in order to prevent any freezing
-- during analysis, we need to mask types declared outside the
- -- expression that are not yet frozen.
+ -- expression (and in an outer scope) that are not yet frozen.
+ -- This also needs to be done in the case of an ignored Ghost
+ -- expression function, where the expander isn't active.
- if Nkind (N) = N_Subprogram_Body
- and then Was_Expression_Function (N)
- and then not Has_Completion (Spec_Id)
- then
- Set_Is_Frozen (Spec_Id);
- Mask_Types := Mask_Unfrozen_Types (Spec_Id);
- else
- Set_Has_Delayed_Freeze (Spec_Id);
- Freeze_Before (N, Spec_Id);
- end if;
+ Set_Is_Frozen (Spec_Id);
+ Mask_Types := Mask_Unfrozen_Types (Spec_Id);
+
+ elsif not Is_Frozen (Spec_Id)
+ and then Serious_Errors_Detected = 0
+ then
+ Set_Has_Delayed_Freeze (Spec_Id);
+ Freeze_Before (N, Spec_Id);
end if;
end if;
-- If the subprogram has a class-wide clone, build its body as a copy
-- of the original body, and rewrite body of original subprogram as a
- -- wrapper that calls the clone.
+ -- wrapper that calls the clone. If N is a stub, this construction will
+ -- take place when the proper body is analyzed. No action needed if this
+ -- subprogram has been eliminated.
if Present (Spec_Id)
and then Present (Class_Wide_Clone (Spec_Id))
and then (Comes_From_Source (N) or else Was_Expression_Function (N))
+ and then Nkind (N) /= N_Subprogram_Body_Stub
+ and then not (Expander_Active and then Is_Eliminated (Spec_Id))
then
Build_Class_Wide_Clone_Body (Spec_Id, N);
end if;
end if;
- if Spec_Id /= Body_Id then
+ -- In the case we are dealing with an expression function we check
+ -- the formals attached to the spec instead of the body - so we don't
+ -- reference body formals.
+
+ if Spec_Id /= Body_Id
+ and then not Is_Expression_Function (Spec_Id)
+ then
Reference_Body_Formals (Spec_Id, Body_Id);
end if;
-- Within an instance, add local renaming declarations so that
-- gdb can retrieve the values of actuals more easily. This is
- -- only relevant if generating code (and indeed we definitely
- -- do not want these definitions -gnatc mode, because that would
- -- confuse ASIS).
+ -- only relevant if generating code.
if Is_Generic_Instance (Spec_Id)
and then Is_Wrapper_Package (Current_Scope)
end if;
end if;
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ if No (Spec_Id) then
+ Mark_Elaboration_Attributes
+ (N_Id => Body_Id,
+ Checks => True,
+ Warnings => True);
+ end if;
+
-- If this is the proper body of a stub, we must verify that the stub
-- conforms to the body, and to the previous spec if one was present.
-- We know already that the body conforms to that spec. This test is
if Nkind (N) = N_Subprogram_Body_Stub then
if Has_Aspects (N) then
- Analyze_Aspect_Specifications_On_Body_Or_Stub (N);
+ Analyze_Aspects_On_Subprogram_Body_Or_Stub (N);
end if;
goto Leave;
-- Legacy implementation (relying on front-end inlining)
if not Back_End_Inlining then
- if (Has_Pragma_Inline_Always (Spec_Id)
- and then not Opt.Disable_FE_Inline_Always)
+ if Has_Pragma_Inline_Always (Spec_Id)
or else (Front_End_Inlining
and then not Opt.Disable_FE_Inline)
then
end;
end if;
+ -- Generate minimum accessibility local objects to correspond with
+ -- any extra formal added for anonymous access types. This new local
+ -- object can then be used instead of the formal in case it is used
+ -- 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
+ -- Dynamic_Accessibility_Level).
+
+ -- Because we allow accessibility values greater than our expected value
+ -- passing along the same extra accessibility formal as an actual
+ -- to a nested subprogram becomes a problem because high values mean
+ -- different things to the callee even though they are the same to the
+ -- caller. So, as described in the first section, we create a local
+ -- object representing the minimum of the accessibility level value that
+ -- is passed in and the accessibility level of the callee's parameter
+ -- and locals and use it in the case of a call to a nested subprogram.
+ -- This generated object is refered to as a "minimum accessiblity
+ -- level."
+
+ if Present (Spec_Id) or else Present (Body_Id) then
+ Body_Nod := Unit_Declaration_Node (Body_Id);
+
+ 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.
+
+ 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.
+
+ 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
+
+ -- A60b : integer := integer'min(2, paramL);
+
+ declare
+ Loc : constant Source_Ptr := Sloc (Body_Nod);
+ Obj_Node : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Temporary
+ (Loc, 'A', Extra_Accessibility (Form)),
+ Object_Definition => New_Occurrence_Of
+ (Standard_Integer, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of
+ (Standard_Integer, Loc),
+ Attribute_Name => Name_Min,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc,
+ Object_Access_Level (Form)),
+ New_Occurrence_Of
+ (Extra_Accessibility (Form), Loc))));
+ begin
+ -- 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);
+ else
+ Minimum_Acc_Objs := New_List (Obj_Node);
+ end if;
+
+ -- Register the object and analyze it
+
+ Set_Minimum_Accessibility
+ (Form, Defining_Identifier (Obj_Node));
+
+ Analyze (Obj_Node);
+ end;
+ end if;
+
+ Next_Formal (Form);
+ end loop;
+ end if;
+ end;
+ end if;
+
-- Now we can go on to analyze the body
HSS := Handled_Statement_Sequence (N);
-- Analyze any aspect specifications that appear on the subprogram body
if Has_Aspects (N) then
- Analyze_Aspect_Specifications_On_Body_Or_Stub (N);
+ Analyze_Aspects_On_Subprogram_Body_Or_Stub (N);
end if;
Analyze_Declarations (Declarations (N));
elsif Nkind (Parent (Parent (Spec_Id))) = N_Subprogram_Body_Stub then
null;
+ -- SPARK_Mode Off could complete no SPARK_Mode in a generic, either
+ -- as specified in source code, or because SPARK_Mode On is ignored
+ -- in an instance where the context is SPARK_Mode Off/Auto.
+
+ elsif Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Body_Id)) = Off
+ and then (Is_Generic_Unit (Spec_Id) or else In_Instance)
+ then
+ null;
+
else
Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id));
Error_Msg_N ("incorrect application of SPARK_Mode #", N);
end if;
end if;
- -- A subprogram body "freezes" its own contract. Analyze the contract
+ -- A subprogram body freezes its own contract. Analyze the contract
-- after the declarations of the body have been processed as pragmas
-- are now chained on the contract of the subprogram body.
Inspect_Deferred_Constant_Completion (Declarations (N));
Analyze (HSS);
+ -- Add the generated minimum accessibility objects to the subprogram
+ -- body's 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;
+
-- Deal with end of scope processing for the body
Process_End_Label (HSS, 't', Current_Scope);
-- Body entities present (formals), so chain stuff past them
else
- Set_Next_Entity
+ Link_Entities
(Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity));
end if;
Set_First_Entity (Spec_Id, Empty);
Set_Last_Entity (Spec_Id, Empty);
end if;
+
+ -- Otherwise the body does not complete a previous declaration. Check
+ -- the categorization of the body against the units it withs.
+
+ else
+ Validate_Categorization_Dependency (N, Body_Id);
end if;
Check_Missing_Return;
end loop;
end if;
- -- Check references in body
+ -- Check references of the subprogram spec when we are dealing with
+ -- an expression function due to it having a generated body.
+ -- Otherwise, we simply check the formals of the subprogram body.
- Check_References (Body_Id);
+ if Present (Spec_Id)
+ and then Is_Expression_Function (Spec_Id)
+ then
+ Check_References (Spec_Id);
+ else
+ Check_References (Body_Id);
+ end if;
end;
-- Check for nested subprogram, and mark outer level subprogram if so
end if;
<<Leave>>
+ if Present (Ignored_Ghost_Region) then
+ Expander_Active := Saved_EA;
+ end if;
+
Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
- Restore_Ghost_Mode (Saved_GM);
+ Restore_Ghost_Region (Saved_GM, Saved_IGR);
end Analyze_Subprogram_Body_Helper;
------------------------------------
if Nkind (Specification (N)) = N_Procedure_Specification
and then Null_Present (Specification (N))
then
- Check_SPARK_05_Restriction ("null procedure is not allowed", N);
-
-- Null procedures are allowed in protected types, following the
-- recent AI12-0147.
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
- (N_Id => Designator,
- Checks => True);
+ (N_Id => Designator,
+ Checks => True,
+ Warnings => True);
if Debug_Flag_C then
Write_Str ("==> subprogram spec ");
Set_Kill_Elaboration_Checks (Designator);
end if;
- if Scop /= Standard_Standard and then not Is_Child_Unit (Designator) then
- Set_Categorization_From_Scope (Designator, Scop);
-
- else
- -- For a compilation unit, check for library-unit pragmas
-
- Push_Scope (Designator);
- Set_Categorization_From_Pragmas (N);
- Validate_Categorization_Dependency (N, Designator);
- Pop_Scope;
- end if;
-
-- For a compilation unit, set body required. This flag will only be
-- reset if a valid Import or Interface pragma is processed later on.
Write_Eol;
end if;
- if Is_Protected_Type (Current_Scope) then
-
- -- Indicate that this is a protected operation, because it may be
- -- used in subsequent declarations within the protected type.
+ -- Indicate that this is a protected operation, because it may be used
+ -- in subsequent declarations within the protected type.
+ if Is_Protected_Type (Current_Scope) then
Set_Convention (Designator, Convention_Protected);
end if;
List_Inherited_Pre_Post_Aspects (Designator);
+ -- Process the aspects before establishing the proper categorization in
+ -- case the subprogram is a compilation unit and one of its aspects is
+ -- converted into a categorization pragma.
+
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Designator);
end if;
+
+ if Scop /= Standard_Standard and then not Is_Child_Unit (Designator) then
+ Set_Categorization_From_Scope (Designator, Scop);
+
+ -- Otherwise the unit is a compilation unit and/or a child unit. Set the
+ -- proper categorization of the unit based on its pragmas.
+
+ else
+ Push_Scope (Designator);
+ Set_Categorization_From_Pragmas (N);
+ Validate_Categorization_Dependency (N, Designator);
+ Pop_Scope;
+ end if;
end Analyze_Subprogram_Declaration;
--------------------------------------
-- Start of processing for Analyze_Subprogram_Specification
begin
- -- User-defined operator is not allowed in SPARK, except as a renaming
-
- if Nkind (Defining_Unit_Name (N)) = N_Defining_Operator_Symbol
- and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
- then
- Check_SPARK_05_Restriction
- ("user-defined operator is not allowed", N);
- end if;
-
-- Proceed with analysis. Do not emit a cross-reference entry if the
-- specification comes from an expression function, because it may be
- -- the completion of a previous declaration. It is not, the cross-
+ -- the completion of a previous declaration. If it is not, the cross-
-- reference entry will be emitted for the new subprogram declaration.
if Nkind (Parent (N)) /= N_Expression_Function then
elsif Is_Formal_Subprogram (Old_Id)
or else Is_Formal_Subprogram (New_Id)
+ or else (Is_Subprogram (New_Id)
+ and then Present (Alias (New_Id))
+ and then Is_Formal_Subprogram (Alias (New_Id)))
then
- Conformance_Error ("\formal subprograms not allowed!");
- return;
+ Conformance_Error
+ ("\formal subprograms are not subtype conformant "
+ & "(RM 6.3.1 (17/3))");
end if;
end if;
and then Directly_Designated_Type (Old_Formal_Base) =
Directly_Designated_Type (New_Formal_Base)
and then ((Is_Itype (Old_Formal_Base)
- and then Can_Never_Be_Null (Old_Formal_Base))
+ and then (Can_Never_Be_Null (Old_Formal_Base)
+ or else Is_Access_Constant
+ (Old_Formal_Base)))
or else
(Is_Itype (New_Formal_Base)
- and then Can_Never_Be_Null (New_Formal_Base)));
+ and then (Can_Never_Be_Null (New_Formal_Base)
+ or else Is_Access_Constant
+ (New_Formal_Base))));
-- Types must always match. In the visible part of an instance,
-- usual overloading rules for dispatching operations apply, and
------------------------------
procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
- F : Entity_Id;
-
procedure Possible_Freeze (T : Entity_Id);
- -- T is the type of either a formal parameter or of the return type.
- -- If T is not yet frozen and needs a delayed freeze, then the
- -- subprogram itself must be delayed.
+ -- T is the type of either a formal parameter or of the return type. If
+ -- T is not yet frozen and needs a delayed freeze, then the subprogram
+ -- itself must be delayed.
---------------------
-- Possible_Freeze --
---------------------
procedure Possible_Freeze (T : Entity_Id) is
+ Scop : constant Entity_Id := Scope (Designator);
+
begin
- if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
+ -- If the subprogram appears within a package instance (which may be
+ -- the wrapper package of a subprogram instance) the freeze node for
+ -- that package will freeze the subprogram at the proper place, so
+ -- do not emit a freeze node for the subprogram, given that it may
+ -- appear in the wrong scope.
+
+ if Ekind (Scop) = E_Package
+ and then not Comes_From_Source (Scop)
+ and then Is_Generic_Instance (Scop)
+ then
+ null;
+
+ elsif Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
Set_Has_Delayed_Freeze (Designator);
elsif Is_Access_Type (T)
then
Set_Has_Delayed_Freeze (Designator);
end if;
-
end Possible_Freeze;
+ -- Local variables
+
+ F : Entity_Id;
+
-- Start of processing for Check_Delayed_Subprogram
begin
Possible_Freeze (Etype (Designator));
Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
- -- Need delayed freeze if any of the formal types themselves need
- -- a delayed freeze and are not yet frozen.
+ -- Need delayed freeze if any of the formal types themselves need a
+ -- delayed freeze and are not yet frozen.
F := First_Formal (Designator);
while Present (F) loop
Next_Formal (F);
end loop;
- -- Mark functions that return by reference. Note that it cannot be
- -- done for delayed_freeze subprograms because the underlying
- -- returned type may not be known yet (for private types)
+ -- Mark functions that return by reference. Note that it cannot be done
+ -- for delayed_freeze subprograms because the underlying returned type
+ -- may not be known yet (for private types).
if not Has_Delayed_Freeze (Designator) and then Expander_Active then
declare
Typ : constant Entity_Id := Etype (Designator);
Utyp : constant Entity_Id := Underlying_Type (Typ);
+
begin
if Is_Limited_View (Typ) then
Set_Returns_By_Ref (Designator);
+
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Designator);
end if;
Access_Definition (N, Discriminant_Type (New_Discr));
else
- Analyze (Discriminant_Type (New_Discr));
+ Find_Type (Discriminant_Type (New_Discr));
New_Discr_Type := Etype (Discriminant_Type (New_Discr));
-- Ada 2005: if the discriminant definition carries a null
-- If there is an overridden subprogram, then check that there is no
-- "not overriding" indicator, and mark the subprogram as overriding.
+
-- This is not done if the overridden subprogram is marked as hidden,
-- which can occur for the case of inherited controlled operations
-- (see Derive_Subprogram), unless the inherited subprogram's parent
- -- subprogram is not itself hidden. (Note: This condition could probably
- -- be simplified, leaving out the testing for the specific controlled
- -- cases, but it seems safer and clearer this way, and echoes similar
- -- special-case tests of this kind in other places.)
+ -- subprogram is not itself hidden or we are within a generic instance,
+ -- in which case the hidden flag may have been modified for the
+ -- expansion of the instance.
+
+ -- (Note: This condition could probably be simplified, leaving out the
+ -- testing for the specific controlled cases, but it seems safer and
+ -- clearer this way, and echoes similar special-case tests of this
+ -- kind in other places.)
if Present (Overridden_Subp)
and then (not Is_Hidden (Overridden_Subp)
Name_Adjust,
Name_Finalize)
and then Present (Alias (Overridden_Subp))
- and then not Is_Hidden (Alias (Overridden_Subp))))
+ and then (not Is_Hidden (Alias (Overridden_Subp))
+ or else In_Instance)))
then
if Must_Not_Override (Spec) then
Error_Msg_Sloc := Sloc (Overridden_Subp);
In_Scope : Boolean;
Typ : Entity_Id;
+ function Is_Valid_Formal (F : Entity_Id) return Boolean;
+ -- Predicate for legality rule in 9.4 (11.9/2): If an inherited
+ -- subprogram is implemented by a protected procedure or entry,
+ -- its first parameter must be out, in out, or access-to-variable.
+
function Matches_Prefixed_View_Profile
(Prim_Params : List_Id;
Iface_Params : List_Id) return Boolean;
-- Iface_Params. Also determine if the type of first parameter of
-- Iface_Params is an implemented interface.
+ ----------------------
+ -- Is_Valid_Formal --
+ ----------------------
+
+ function Is_Valid_Formal (F : Entity_Id) return Boolean is
+ begin
+ return
+ Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter)
+ or else
+ (Nkind (Parameter_Type (Parent (F))) = N_Access_Definition
+ and then not Constant_Present (Parameter_Type (Parent (F))));
+ end Is_Valid_Formal;
+
-----------------------------------
-- Matches_Prefixed_View_Profile --
-----------------------------------
if Ekind_In (Candidate, E_Entry, E_Procedure)
and then Is_Protected_Type (Typ)
- and then Ekind (Formal) /= E_In_Out_Parameter
- and then Ekind (Formal) /= E_Out_Parameter
- and then Nkind (Parameter_Type (Parent (Formal))) /=
- N_Access_Definition
+ and then not Is_Valid_Formal (Formal)
then
null;
end if;
end;
- -- Functions can override abstract interface functions
+ -- Functions can override abstract interface functions. Return
+ -- types must be subtype conformant.
elsif Ekind (Def_Id) = E_Function
and then Ekind (Subp) = E_Function
and then Matches_Prefixed_View_Profile
(Parameter_Specifications (Parent (Def_Id)),
Parameter_Specifications (Parent (Subp)))
- and then Etype (Def_Id) = Etype (Subp)
+ and then Conforming_Types
+ (Etype (Def_Id), Etype (Subp), Subtype_Conformant)
then
Candidate := Subp;
return True;
-- In Ada 2012, incomplete types (including limited views) can appear
- -- as actuals in instantiations.
+ -- as actuals in instantiations, where they are conformant to the
+ -- corresponding incomplete formal.
elsif Is_Incomplete_Type (Type_1)
and then Is_Incomplete_Type (Type_2)
+ and then In_Instance
and then (Used_As_Generic_Actual (Type_1)
or else Used_As_Generic_Actual (Type_2))
then
if No (First_Extra) then
First_Extra := EF;
- Set_Extra_Formals (Scope, First_Extra);
+ Set_Extra_Formals (Scope, EF);
end if;
if Present (Last_Extra) then
-- If Extra_Formals were already created, don't do it again. This
-- situation may arise for subprogram types created as part of
- -- dispatching calls (see Expand_Dispatching_Call)
+ -- dispatching calls (see Expand_Dispatching_Call).
if Present (Last_Extra) and then Present (Extra_Formal (Last_Extra)) then
return;
if Is_Build_In_Place_Function (E) then
declare
Result_Subt : constant Entity_Id := Etype (E);
- Full_Subt : constant Entity_Id := Available_View (Result_Subt);
Formal_Typ : Entity_Id;
Subp_Decl : Node_Id;
-
- Discard : Entity_Id;
- pragma Warnings (Off, Discard);
+ Discard : Entity_Id;
begin
-- In the case of functions with unconstrained result subtypes,
-- master of the tasks to be created, and the caller's activation
-- chain.
- if Has_Task (Full_Subt) then
+ if Needs_BIP_Task_Actuals (E) then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Master_Id),
Formal_Typ :=
Create_Itype (E_Anonymous_Access_Type, E, Scope_Id => Scope (E));
- Set_Directly_Designated_Type (Formal_Typ, Result_Subt);
+ -- Incomplete_View_From_Limited_With is needed here because
+ -- gigi gets confused if the designated type is the full view
+ -- coming from a limited-with'ed package. In the normal case,
+ -- (no limited with) Incomplete_View_From_Limited_With
+ -- returns Result_Subt.
+
+ Set_Directly_Designated_Type
+ (Formal_Typ, Incomplete_View_From_Limited_With (Result_Subt));
Set_Etype (Formal_Typ, Formal_Typ);
Set_Depends_On_Private
(Formal_Typ, Has_Private_Component (Formal_Typ));
(E, Formal_Typ, E, BIP_Formal_Suffix (BIP_Object_Access));
end;
end if;
+
+ -- If this is an instance of a generic, we need to have extra formals
+ -- for the Alias.
+
+ if Is_Generic_Instance (E) and then Present (Alias (E)) then
+ Set_Extra_Formals (Alias (E), Extra_Formals (E));
+ end if;
end Create_Extra_Formals;
-----------------------------
begin
-- This check applies only if we have a subprogram declaration with an
- -- untagged record type.
+ -- untagged record type that is conformant to the predefined op.
if Nkind (Decl) /= N_Subprogram_Declaration
or else not Is_Record_Type (Typ)
or else Is_Tagged_Type (Typ)
+ or else Etype (Next_Formal (First_Formal (Eq_Op))) /= Typ
then
return;
end if;
if Is_Frozen (Typ) then
- -- If the type is not declared in a package, or if we are in the body
- -- of the package or in some other scope, the new operation is not
- -- primitive, and therefore legal, though suspicious. Should we
- -- generate a warning in this case ???
+ -- The check applies to a primitive operation, so check that type
+ -- and equality operation are in the same scope.
- if Ekind (Scope (Typ)) /= E_Package
- or else Scope (Typ) /= Current_Scope
- then
+ if Scope (Typ) /= Current_Scope then
return;
-- If the type is a generic actual (sub)type, the operation is not
("\move declaration to package spec (Ada 2012)?y?", Eq_Op);
end if;
- -- Otherwise try to find the freezing point
+ -- Otherwise try to find the freezing point for better message.
else
Obj_Decl := Next (Parent (Typ));
end if;
exit;
+
+ -- If we reach generated code for subprogram declaration
+ -- or body, it is the body that froze the type and the
+ -- declaration is legal.
+
+ elsif Sloc (Obj_Decl) = Sloc (Decl) then
+ return;
end if;
Next (Obj_Decl);
function Fully_Conformant_Expressions
(Given_E1 : Node_Id;
- Given_E2 : Node_Id) return Boolean
+ Given_E2 : Node_Id;
+ Report : Boolean := False) return Boolean
is
E1 : constant Node_Id := Original_Node (Given_E1);
E2 : constant Node_Id := Original_Node (Given_E2);
-- for analysis and/or expansion to make things look as though they
-- conform when they do not, e.g. by converting 1+2 into 3.
- function FCE (Given_E1, Given_E2 : Node_Id) return Boolean
- renames Fully_Conformant_Expressions;
+ function FCE (Given_E1 : Node_Id; Given_E2 : Node_Id) return Boolean;
+ -- ???
- function FCL (L1, L2 : List_Id) return Boolean;
+ function FCL (L1 : List_Id; L2 : List_Id) return Boolean;
-- Compare elements of two lists for conformance. Elements have to be
-- conformant, and actuals inserted as default parameters do not match
-- explicit actuals with the same value.
- function FCO (Op_Node, Call_Node : Node_Id) return Boolean;
+ function FCO (Op_Node : Node_Id; Call_Node : Node_Id) return Boolean;
-- Compare an operator node with a function call
+ ---------
+ -- FCE --
+ ---------
+
+ function FCE (Given_E1 : Node_Id; Given_E2 : Node_Id) return Boolean is
+ begin
+ return Fully_Conformant_Expressions (Given_E1, Given_E2, Report);
+ end FCE;
+
---------
-- FCL --
---------
- function FCL (L1, L2 : List_Id) return Boolean is
- N1, N2 : Node_Id;
+ function FCL (L1 : List_Id; L2 : List_Id) return Boolean is
+ N1 : Node_Id;
+ N2 : Node_Id;
begin
if L1 = No_List then
-- FCO --
---------
- function FCO (Op_Node, Call_Node : Node_Id) return Boolean is
+ function FCO (Op_Node : Node_Id; Call_Node : Node_Id) return Boolean is
Actuals : constant List_Id := Parameter_Associations (Call_Node);
Act : Node_Id;
end if;
end FCO;
+ -- Local variables
+
+ Result : Boolean;
+
-- Start of processing for Fully_Conformant_Expressions
begin
+ Result := True;
+
-- Nonconformant if paren count does not match. Note: if some idiot
-- complains that we don't do this right for more than 3 levels of
-- parentheses, they will be treated with the respect they deserve.
elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
if Present (Entity (E1)) then
- return Entity (E1) = Entity (E2)
+ Result := Entity (E1) = Entity (E2)
-- One may be a discriminant that has been replaced by the
-- corresponding discriminal.
and then Discriminal_Link (Entity (E1)) =
Discriminal_Link (Entity (E2)))
- -- AI12-050: The loop variables of quantified expressions
- -- match if they have the same identifier, even though they
- -- are different entities.
+ -- AI12-050: The loop variables of quantified expressions match
+ -- if they have the same identifier, even though they may have
+ -- different entities.
or else
(Chars (Entity (E1)) = Chars (Entity (E2))
and then Ekind (Entity (E1)) = E_Loop_Parameter
- and then Ekind (Entity (E2)) = E_Loop_Parameter);
+ and then Ekind (Entity (E2)) = E_Loop_Parameter)
+
+ -- A call to an instantiation of Unchecked_Conversion is
+ -- rewritten with the name of the generated function created for
+ -- the instance, and this must be special-cased.
+
+ or else
+ (Ekind (Entity (E1)) = E_Function
+ and then Is_Intrinsic_Subprogram (Entity (E1))
+ and then Is_Generic_Instance (Entity (E1))
+ and then Entity (E2) = Alias (Entity (E1)));
+ if Report and not Result then
+ Error_Msg_Sloc :=
+ Text_Ptr'Max (Sloc (Entity (E1)), Sloc (Entity (E2)));
+ Error_Msg_NE
+ ("Meaning of& differs because of declaration#", E1, E2);
+ end if;
+
+ return Result;
elsif Nkind (E1) = N_Expanded_Name
and then Nkind (E2) = N_Expanded_Name
E : Entity_Id;
-- Entity that S overrides
- Prev_Vis : Entity_Id := Empty;
- -- Predecessor of E in Homonym chain
-
procedure Check_For_Primitive_Subprogram
(Is_Primitive : out Boolean;
Is_Overriding : Boolean := False);
-- Here, S is "function ... return T;" declared in
-- the private part, not overriding some visible
- -- operation. That's illegal in the tagged case
+ -- operation. That's illegal in the tagged case
-- (but not if the private type is untagged).
if ((Present (Partial_View)
function Visible_Part_Type (T : Entity_Id) return Boolean is
P : constant Node_Id := Unit_Declaration_Node (Scope (T));
- N : Node_Id;
begin
-- If the entity is a private type, then it must be declared in a
if Ekind (T) in Private_Kind then
return True;
- end if;
-
- -- Otherwise, we traverse the visible part looking for its
- -- corresponding declaration. We cannot use the declaration
- -- node directly because in the private part the entity of a
- -- private type is the one in the full view, which does not
- -- indicate that it is the completion of something visible.
-
- N := First (Visible_Declarations (Specification (P)));
- while Present (N) loop
- if Nkind (N) = N_Full_Type_Declaration
- and then Present (Defining_Identifier (N))
- and then T = Defining_Identifier (N)
- then
- return True;
- elsif Nkind_In (N, N_Private_Type_Declaration,
- N_Private_Extension_Declaration)
- and then Present (Defining_Identifier (N))
- and then T = Full_View (Defining_Identifier (N))
- then
- return True;
- end if;
+ elsif Is_Type (T) and then Has_Private_Declaration (T) then
+ return True;
- Next (N);
- end loop;
+ elsif Is_List_Member (Declaration_Node (T))
+ and then List_Containing (Declaration_Node (T)) =
+ Visible_Declarations (Specification (P))
+ then
+ return True;
- return False;
+ else
+ return False;
+ end if;
end Visible_Part_Type;
-- Start of processing for Check_For_Primitive_Subprogram
is
function Check_Conforming_Parameters
(E1_Param : Node_Id;
- E2_Param : Node_Id) return Boolean;
+ E2_Param : Node_Id;
+ Ctype : Conformance_Type) return Boolean;
-- Starting from the given parameters, check that all the parameters
- -- of two entries or subprograms are subtype conformant. Used to skip
+ -- of two entries or subprograms are conformant. Used to skip
-- the check on the controlling argument.
function Matching_Entry_Or_Subprogram
-- whose name matches the original name of Subp and has a profile
-- conformant with the profile of Subp; return Empty if not found.
+ function Normalized_First_Parameter_Type
+ (E : Entity_Id) return Entity_Id;
+ -- Return the type of the first parameter unless that type
+ -- is an anonymous access type, in which case return the
+ -- designated type. Used to treat anonymous-access-to-synchronized
+ -- the same as synchronized for purposes of checking for
+ -- prefixed view profile conflicts.
+
---------------------------------
- -- Check_Confirming_Parameters --
+ -- Check_Conforming_Parameters --
---------------------------------
function Check_Conforming_Parameters
(E1_Param : Node_Id;
- E2_Param : Node_Id) return Boolean
+ E2_Param : Node_Id;
+ Ctype : Conformance_Type) return Boolean
is
Param_E1 : Node_Id := E1_Param;
Param_E2 : Node_Id := E2_Param;
begin
while Present (Param_E1) and then Present (Param_E2) loop
- if Ekind (Defining_Identifier (Param_E1)) /=
- Ekind (Defining_Identifier (Param_E2))
- or else not
+ if (Ctype >= Mode_Conformant) and then
+ Ekind (Defining_Identifier (Param_E1)) /=
+ Ekind (Defining_Identifier (Param_E2))
+ then
+ return False;
+ elsif not
Conforming_Types
(Find_Parameter_Type (Param_E1),
Find_Parameter_Type (Param_E2),
- Subtype_Conformant)
+ Ctype)
then
return False;
end if;
and then
Check_Conforming_Parameters
(First (Parameter_Specifications (Parent (E))),
- Next (First (Parameter_Specifications (Parent (Subp)))))
+ Next (First (Parameter_Specifications (Parent (Subp)))),
+ Type_Conformant)
then
return E;
end if;
and then
Check_Conforming_Parameters
(First (Parameter_Specifications (Parent (Ent))),
- Next (First (Parameter_Specifications (Parent (E)))))
+ Next (First (Parameter_Specifications (Parent (E)))),
+ Subtype_Conformant)
then
return E;
end if;
return Empty;
end Matching_Original_Protected_Subprogram;
+ -------------------------------------
+ -- Normalized_First_Parameter_Type --
+ -------------------------------------
+
+ function Normalized_First_Parameter_Type
+ (E : Entity_Id) return Entity_Id
+ is
+ Result : Entity_Id := Etype (First_Entity (E));
+ begin
+ if Ekind (Result) = E_Anonymous_Access_Type then
+ Result := Designated_Type (Result);
+ end if;
+ return Result;
+ end Normalized_First_Parameter_Type;
+
-- Start of processing for Has_Matching_Entry_Or_Subprogram
begin
if Comes_From_Source (E)
and then Is_Subprogram (E)
and then Present (First_Entity (E))
- and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
+ and then Is_Concurrent_Record_Type
+ (Normalized_First_Parameter_Type (E))
then
if Scope (E) =
Scope (Corresponding_Concurrent_Type
- (Etype (First_Entity (E))))
+ (Normalized_First_Parameter_Type (E)))
and then
Present
(Matching_Entry_Or_Subprogram
- (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ (Corresponding_Concurrent_Type
+ (Normalized_First_Parameter_Type (E)),
Subp => E))
then
Report_Conflict (E,
Matching_Entry_Or_Subprogram
- (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ (Corresponding_Concurrent_Type
+ (Normalized_First_Parameter_Type (E)),
Subp => E));
return True;
end if;
Inherit_Subprogram_Contract (E, S);
end if;
+ -- When a dispatching operation overrides an inherited
+ -- subprogram, it shall be subtype conformant with the
+ -- inherited subprogram (RM 3.9.2 (10.2)).
+
+ if Comes_From_Source (E)
+ and then Is_Dispatching_Operation (E)
+ and then Find_Dispatching_Type (S)
+ = Find_Dispatching_Type (E)
+ then
+ Check_Subtype_Conformant (E, S);
+ end if;
+
if Comes_From_Source (E) then
Check_Overriding_Indicator (E, S, Is_Primitive => False);
Overridden_Subp := E;
- declare
- Prev : Entity_Id;
-
- begin
- Prev := First_Entity (Current_Scope);
- while Present (Prev) and then Next_Entity (Prev) /= E loop
- Next_Entity (Prev);
- end loop;
-
- -- It is possible for E to be in the current scope and
- -- yet not in the entity chain. This can only occur in a
- -- generic context where E is an implicit concatenation
- -- in the formal part, because in a generic body the
- -- entity chain starts with the formals.
-
- -- In GNATprove mode, a wrapper for an operation with
- -- axiomatization may be a homonym of another declaration
- -- for an actual subprogram (needs refinement ???).
-
- if No (Prev) then
- if In_Instance
- and then GNATprove_Mode
- and then
- Nkind (Original_Node (Unit_Declaration_Node (S))) =
- N_Subprogram_Renaming_Declaration
- then
- return;
- else
- pragma Assert (Chars (E) = Name_Op_Concat);
- null;
- end if;
- end if;
+ -- It is possible for E to be in the current scope and
+ -- yet not in the entity chain. This can only occur in a
+ -- generic context where E is an implicit concatenation
+ -- in the formal part, because in a generic body the
+ -- entity chain starts with the formals.
- -- E must be removed both from the entity_list of the
- -- current scope, and from the visibility chain.
+ -- In GNATprove mode, a wrapper for an operation with
+ -- axiomatization may be a homonym of another declaration
+ -- for an actual subprogram (needs refinement ???).
- if Debug_Flag_E then
- Write_Str ("Override implicit operation ");
- Write_Int (Int (E));
- Write_Eol;
+ if No (Prev_Entity (E)) then
+ if In_Instance
+ and then GNATprove_Mode
+ and then
+ Nkind (Original_Node (Unit_Declaration_Node (S))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ return;
+ else
+ pragma Assert (Chars (E) = Name_Op_Concat);
+ null;
end if;
+ end if;
- -- If E is a predefined concatenation, it stands for four
- -- different operations. As a result, a single explicit
- -- declaration does not hide it. In a possible ambiguous
- -- situation, Disambiguate chooses the user-defined op,
- -- so it is correct to retain the previous internal one.
+ -- E must be removed both from the entity_list of the
+ -- current scope, and from the visibility chain.
- if Chars (E) /= Name_Op_Concat
- or else Ekind (E) /= E_Operator
- then
- -- For nondispatching derived operations that are
- -- overridden by a subprogram declared in the private
- -- part of a package, we retain the derived subprogram
- -- but mark it as not immediately visible. If the
- -- derived operation was declared in the visible part
- -- then this ensures that it will still be visible
- -- outside the package with the proper signature
- -- (calls from outside must also be directed to this
- -- version rather than the overriding one, unlike the
- -- dispatching case). Calls from inside the package
- -- will still resolve to the overriding subprogram
- -- since the derived one is marked as not visible
- -- within the package.
-
- -- If the private operation is dispatching, we achieve
- -- the overriding by keeping the implicit operation
- -- but setting its alias to be the overriding one. In
- -- this fashion the proper body is executed in all
- -- cases, but the original signature is used outside
- -- of the package.
-
- -- If the overriding is not in the private part, we
- -- remove the implicit operation altogether.
-
- if Is_Private_Declaration (S) then
- if not Is_Dispatching_Operation (E) then
- Set_Is_Immediately_Visible (E, False);
- else
- -- Work done in Override_Dispatching_Operation,
- -- so nothing else needs to be done here.
+ if Debug_Flag_E then
+ Write_Str ("Override implicit operation ");
+ Write_Int (Int (E));
+ Write_Eol;
+ end if;
- null;
- end if;
+ -- If E is a predefined concatenation, it stands for four
+ -- different operations. As a result, a single explicit
+ -- declaration does not hide it. In a possible ambiguous
+ -- situation, Disambiguate chooses the user-defined op,
+ -- so it is correct to retain the previous internal one.
+ if Chars (E) /= Name_Op_Concat
+ or else Ekind (E) /= E_Operator
+ then
+ -- For nondispatching derived operations that are
+ -- overridden by a subprogram declared in the private
+ -- part of a package, we retain the derived subprogram
+ -- but mark it as not immediately visible. If the
+ -- derived operation was declared in the visible part
+ -- then this ensures that it will still be visible
+ -- outside the package with the proper signature
+ -- (calls from outside must also be directed to this
+ -- version rather than the overriding one, unlike the
+ -- dispatching case). Calls from inside the package
+ -- will still resolve to the overriding subprogram
+ -- since the derived one is marked as not visible
+ -- within the package.
+
+ -- If the private operation is dispatching, we achieve
+ -- the overriding by keeping the implicit operation
+ -- but setting its alias to be the overriding one. In
+ -- this fashion the proper body is executed in all
+ -- cases, but the original signature is used outside
+ -- of the package.
+
+ -- If the overriding is not in the private part, we
+ -- remove the implicit operation altogether.
+
+ if Is_Private_Declaration (S) then
+ if not Is_Dispatching_Operation (E) then
+ Set_Is_Immediately_Visible (E, False);
else
- -- Find predecessor of E in Homonym chain
-
- if E = Current_Entity (E) then
- Prev_Vis := Empty;
- else
- Prev_Vis := Current_Entity (E);
- while Homonym (Prev_Vis) /= E loop
- Prev_Vis := Homonym (Prev_Vis);
- end loop;
- end if;
-
- if Prev_Vis /= Empty then
-
- -- Skip E in the visibility chain
-
- Set_Homonym (Prev_Vis, Homonym (E));
-
- else
- Set_Name_Entity_Id (Chars (E), Homonym (E));
- end if;
+ -- Work done in Override_Dispatching_Operation, so
+ -- nothing else needs to be done here.
- Set_Next_Entity (Prev, Next_Entity (E));
-
- if No (Next_Entity (Prev)) then
- Set_Last_Entity (Current_Scope, Prev);
- end if;
+ null;
end if;
+
+ else
+ Remove_Entity_And_Homonym (E);
end if;
+ end if;
- Enter_Overloaded_Entity (S);
+ Enter_Overloaded_Entity (S);
- -- For entities generated by Derive_Subprograms the
- -- overridden operation is the inherited primitive
- -- (which is available through the attribute alias).
+ -- For entities generated by Derive_Subprograms the
+ -- overridden operation is the inherited primitive
+ -- (which is available through the attribute alias).
- if not (Comes_From_Source (E))
- and then Is_Dispatching_Operation (E)
- and then Find_Dispatching_Type (E) =
- Find_Dispatching_Type (S)
- and then Present (Alias (E))
- and then Comes_From_Source (Alias (E))
- then
- Set_Overridden_Operation (S, Alias (E));
- Inherit_Subprogram_Contract (S, Alias (E));
+ if not (Comes_From_Source (E))
+ and then Is_Dispatching_Operation (E)
+ and then Find_Dispatching_Type (E) =
+ Find_Dispatching_Type (S)
+ and then Present (Alias (E))
+ and then Comes_From_Source (Alias (E))
+ then
+ Set_Overridden_Operation (S, Alias (E));
+ Inherit_Subprogram_Contract (S, Alias (E));
- -- Normal case of setting entity as overridden
+ -- Normal case of setting entity as overridden
- -- Note: Static_Initialization and Overridden_Operation
- -- attributes use the same field in subprogram entities.
- -- Static_Initialization is only defined for internal
- -- initialization procedures, where Overridden_Operation
- -- is irrelevant. Therefore the setting of this attribute
- -- must check whether the target is an init_proc.
+ -- Note: Static_Initialization and Overridden_Operation
+ -- attributes use the same field in subprogram entities.
+ -- Static_Initialization is only defined for internal
+ -- initialization procedures, where Overridden_Operation
+ -- is irrelevant. Therefore the setting of this attribute
+ -- must check whether the target is an init_proc.
- elsif not Is_Init_Proc (S) then
- Set_Overridden_Operation (S, E);
- Inherit_Subprogram_Contract (S, E);
- end if;
+ elsif not Is_Init_Proc (S) then
+ Set_Overridden_Operation (S, E);
+ Inherit_Subprogram_Contract (S, E);
+ end if;
- Check_Overriding_Indicator (S, E, Is_Primitive => True);
+ Check_Overriding_Indicator (S, E, Is_Primitive => True);
- -- The Ghost policy in effect at the point of declaration
- -- of a parent subprogram and an overriding subprogram
- -- must match (SPARK RM 6.9(17)).
+ -- The Ghost policy in effect at the point of declaration
+ -- of a parent subprogram and an overriding subprogram
+ -- must match (SPARK RM 6.9(17)).
- Check_Ghost_Overriding (S, E);
+ Check_Ghost_Overriding (S, E);
- -- If S is a user-defined subprogram or a null procedure
- -- expanded to override an inherited null procedure, or a
- -- predefined dispatching primitive then indicate that E
- -- overrides the operation from which S is inherited.
+ -- If S is a user-defined subprogram or a null procedure
+ -- expanded to override an inherited null procedure, or a
+ -- predefined dispatching primitive then indicate that E
+ -- overrides the operation from which S is inherited.
- if Comes_From_Source (S)
- or else
- (Present (Parent (S))
- and then
- Nkind (Parent (S)) = N_Procedure_Specification
- and then
- Null_Present (Parent (S)))
- or else
- (Present (Alias (E))
- and then
- Is_Predefined_Dispatching_Operation (Alias (E)))
- then
- if Present (Alias (E)) then
- Set_Overridden_Operation (S, Alias (E));
- Inherit_Subprogram_Contract (S, Alias (E));
- end if;
+ if Comes_From_Source (S)
+ or else
+ (Present (Parent (S))
+ and then Nkind (Parent (S)) = N_Procedure_Specification
+ and then Null_Present (Parent (S)))
+ or else
+ (Present (Alias (E))
+ and then
+ Is_Predefined_Dispatching_Operation (Alias (E)))
+ then
+ if Present (Alias (E)) then
+ Set_Overridden_Operation (S, Alias (E));
+ Inherit_Subprogram_Contract (S, Alias (E));
end if;
+ end if;
- if Is_Dispatching_Operation (E) then
+ if Is_Dispatching_Operation (E) then
- -- An overriding dispatching subprogram inherits the
- -- convention of the overridden subprogram (AI-117).
+ -- An overriding dispatching subprogram inherits the
+ -- convention of the overridden subprogram (AI-117).
- Set_Convention (S, Convention (E));
- Check_Dispatching_Operation (S, E);
+ Set_Convention (S, Convention (E));
+ Check_Dispatching_Operation (S, E);
- else
- Check_Dispatching_Operation (S, Empty);
- end if;
+ else
+ Check_Dispatching_Operation (S, Empty);
+ end if;
- Check_For_Primitive_Subprogram
- (Is_Primitive_Subp, Is_Overriding => True);
- goto Check_Inequality;
- end;
+ Check_For_Primitive_Subprogram
+ (Is_Primitive_Subp, Is_Overriding => True);
+ goto Check_Inequality;
-- Apparent redeclarations in instances can occur when two
-- formal types get the same actual type. The subprograms in
Check_Ghost_Overriding (S, Overridden_Subp);
- -- Overloading is not allowed in SPARK, except for operators
-
- if Nkind (S) /= N_Defining_Operator_Symbol then
- Error_Msg_Sloc := Sloc (Homonym (S));
- Check_SPARK_05_Restriction
- ("overloading not allowed with entity#", S);
- end if;
-
-- If S is a derived operation for an untagged type then by
-- definition it's not a dispatching operation (even if the parent
-- operation was dispatching), so Check_Dispatching_Operation is not
end if;
end New_Overloaded_Entity;
+ ----------------------------------
+ -- Preanalyze_Formal_Expression --
+ ----------------------------------
+
+ procedure Preanalyze_Formal_Expression (N : Node_Id; T : Entity_Id) is
+ Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
+ begin
+ In_Spec_Expression := True;
+ Preanalyze_With_Freezing_And_Resolve (N, T);
+ In_Spec_Expression := Save_In_Spec_Expression;
+ end Preanalyze_Formal_Expression;
+
---------------------
-- Process_Formals --
---------------------
goto Continue;
end if;
- Formal_Type := Entity (Ptype);
+ -- Protect against malformed parameter types
+
+ if Nkind (Ptype) not in N_Has_Entity then
+ Formal_Type := Any_Type;
+ else
+ Formal_Type := Entity (Ptype);
+ end if;
if Is_Incomplete_Type (Formal_Type)
or else
and then Aliased_Present (Param_Spec)
then
Set_Is_Aliased (Formal);
+
+ -- AI12-001: All aliased objects are considered to be specified
+ -- as independently addressable (RM C.6(8.1/4)).
+
+ Set_Is_Independent (Formal);
end if;
-- Ada 2005 (AI-231): Create and decorate an internal subtype
Default := Expression (Param_Spec);
if Present (Default) then
- Check_SPARK_05_Restriction
- ("default expression is not allowed", Default);
-
if Out_Present (Param_Spec) then
Error_Msg_N
("default initialization only allowed for IN parameters",
-- Do the special preanalysis of the expression (see section on
-- "Handling of Default Expressions" in the spec of package Sem).
- Preanalyze_Spec_Expression (Default, Formal_Type);
+ Preanalyze_Formal_Expression (Default, Formal_Type);
-- An access to constant cannot be the default for
-- an access parameter that is an access to variable.
-- predicate may come from an explicit aspect of be inherited.
elsif Has_Predicates (T) then
- Insert_List_Before_And_Analyze (Decl,
+ Insert_List_After_And_Analyze (Decl,
Freeze_Entity (Defining_Identifier (Decl), N));
end if;
projects / gcc.git / blobdiff