-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2018, 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- --
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
-- 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,
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 --
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;
+ Check_Return_Construct_Accessibility (N);
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);
- 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
-- 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.
-
- Apply_Constraint_Check (Expr, R_Type);
+ -- 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;
-- The return value is converted to the return type of the function,
-- which implies a predicate check if the return type is predicated.
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);
Check_Returns (HSS, 'P', Missing_Ret, Id);
end if;
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;
- else
- 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);
- end if;
- end if;
end Check_Missing_Return;
-----------------------
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
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 Nkind (N) = N_Subprogram_Body
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)
+ 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 (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.
Set_Is_Frozen (Spec_Id);
Mask_Types := Mask_Unfrozen_Types (Spec_Id);
-- 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)
-- 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);
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);
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);
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_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.
-- 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. If it is not, the cross-
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
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;
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;
-- 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),
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;
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 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
-- 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)
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_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);
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
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",
-- 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;