diff options
Diffstat (limited to 'gcc/ada/sem_ch12.adb')
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 1248 |
1 files changed, 755 insertions, 493 deletions
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index dc3a3c2..cbf27e2 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2019, 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- -- @@ -495,6 +495,22 @@ package body Sem_Ch12 is -- nodes or subprogram body and declaration nodes depending on the case). -- On return, the node N has been rewritten with the actual body. + function Build_Subprogram_Decl_Wrapper + (Formal_Subp : Entity_Id) return Node_Id; + -- Ada 2020 allows formal subprograms to carry pre/postconditions. + -- At the point of instantiation these contracts apply to uses of + -- the actual subprogram. This is implemented by creating wrapper + -- subprograms instead of the renamings previously used to link + -- formal subprograms and the corresponding actuals. If the actual + -- is not an entity (e.g. an attribute reference) a renaming is + -- created to handle the expansion of the attribute. + + function Build_Subprogram_Body_Wrapper + (Formal_Subp : Entity_Id; + Actual_Name : Node_Id) return Node_Id; + -- The body of the wrapper is a call to the actual, with the generated + -- pre/postconditon checks added. + procedure Check_Access_Definition (N : Node_Id); -- Subsidiary routine to null exclusion processing. Perform an assertion -- check on Ada version and the presence of an access definition in N. @@ -651,6 +667,10 @@ package body Sem_Ch12 is -- Traverse the Exchanged_Views list to see if a type was private -- and has already been flipped during this phase of instantiation. + function Has_Contracts (Decl : Node_Id) return Boolean; + -- Determine whether a formal subprogram has a Pre- or Postcondition, + -- in which case a subprogram wrapper has to be built for the actual. + procedure Hide_Current_Scope; -- When instantiating a generic child unit, the parent context must be -- present, but the instance and all entities that may be generated @@ -1078,6 +1098,14 @@ package body Sem_Ch12 is -- In Ada 2005, indicates partial parameterization of a formal -- package. As usual an other association must be last in the list. + procedure Build_Subprogram_Wrappers; + -- Ada 2020: AI12-0272 introduces pre/postconditions for formal + -- subprograms. The implementation of making the formal into a renaming + -- of the actual does not work, given that subprogram renaming cannot + -- carry aspect specifications. Instead we must create subprogram + -- wrappers whose body is a call to the actual, and whose declaration + -- carries the aspects of the formal. + procedure Check_Fixed_Point_Actual (Actual : Node_Id); -- Warn if an actual fixed-point type has user-defined arithmetic -- operations, but there is no corresponding formal in the generic, @@ -1101,7 +1129,7 @@ package body Sem_Ch12 is -- actuals are positional, return the next one, if any. If the actuals -- are named, scan the parameter associations to find the right one. -- A_F is the corresponding entity in the analyzed generic, which is - -- placed on the selector name for ASIS use. + -- placed on the selector name. -- -- In Ada 2005, a named association may be given with a box, in which -- case Matching_Actual sets Found_Assoc to the generic association, @@ -1131,6 +1159,70 @@ package body Sem_Ch12 is -- anonymous types, the presence a formal equality will introduce an -- implicit declaration for the corresponding inequality. + ----------------------------------------- + -- procedure Build_Subprogram_Wrappers -- + ----------------------------------------- + + procedure Build_Subprogram_Wrappers is + Formal : constant Entity_Id := + Defining_Unit_Name (Specification (Analyzed_Formal)); + Aspect_Spec : Node_Id; + Decl_Node : Node_Id; + Actual_Name : Node_Id; + + begin + -- Create declaration for wrapper subprogram + -- The actual can be overloaded, in which case it will be + -- resolved when the call in the wrapper body is analyzed. + -- We attach the possible interpretations of the actual to + -- the name to be used in the call in the wrapper body. + + if Is_Entity_Name (Match) then + Actual_Name := New_Occurrence_Of (Entity (Match), Sloc (Match)); + + if Is_Overloaded (Match) then + Save_Interps (Match, Actual_Name); + end if; + + else + -- Use renaming declaration created when analyzing actual. + -- This may be incomplete if there are several formal + -- subprograms whose actual is an attribute ??? + + declare + Renaming_Decl : constant Node_Id := Last (Assoc_List); + + begin + Actual_Name := New_Occurrence_Of + (Defining_Entity (Renaming_Decl), Sloc (Match)); + Set_Etype (Actual_Name, Get_Instance_Of (Etype (Formal))); + end; + end if; + + Decl_Node := Build_Subprogram_Decl_Wrapper (Formal); + + -- Transfer aspect specifications from formal subprogram to wrapper + + Set_Aspect_Specifications (Decl_Node, + New_Copy_List_Tree (Aspect_Specifications (Analyzed_Formal))); + + Aspect_Spec := First (Aspect_Specifications (Decl_Node)); + while Present (Aspect_Spec) loop + Set_Analyzed (Aspect_Spec, False); + Next (Aspect_Spec); + end loop; + + Append_To (Assoc_List, Decl_Node); + + -- Create corresponding body, and append it to association list + -- that appears at the head of the declarations in the instance. + -- The subprogram may be called in the analysis of subsequent + -- actuals. + + Append_To (Assoc_List, + Build_Subprogram_Body_Wrapper (Formal, Actual_Name)); + end Build_Subprogram_Wrappers; + ---------------------------------------- -- Check_Overloaded_Formal_Subprogram -- ---------------------------------------- @@ -1481,9 +1573,9 @@ package body Sem_Ch12 is (Defining_Unit_Name (Specification (Analyzed_Formal))); when N_Formal_Package_Declaration => - exit when Nkind_In (Kind, N_Formal_Package_Declaration, - N_Generic_Package_Declaration, - N_Package_Declaration); + exit when Kind in N_Formal_Package_Declaration + | N_Generic_Package_Declaration + | N_Package_Declaration; when N_Use_Package_Clause | N_Use_Type_Clause @@ -1497,10 +1589,10 @@ package body Sem_Ch12 is exit when Kind not in N_Formal_Subprogram_Declaration - and then not Nkind_In (Kind, N_Subprogram_Declaration, - N_Freeze_Entity, - N_Null_Statement, - N_Itype_Reference) + and then Kind not in N_Subprogram_Declaration + | N_Freeze_Entity + | N_Null_Statement + | N_Itype_Reference and then Chars (Defining_Identifier (Formal)) = Chars (Defining_Identifier (Analyzed_Formal)); end case; @@ -1626,7 +1718,7 @@ package body Sem_Ch12 is Assoc_List); -- For a defaulted in_parameter, create an entry in the - -- the list of defaulted actuals, for GNATProve use. Do + -- the list of defaulted actuals, for GNATprove use. Do -- not included these defaults for an instance nested -- within a generic, because the defaults are also used -- in the analysis of the enclosing generic, and only @@ -1685,7 +1777,7 @@ package body Sem_Ch12 is -- Warn when an actual is a fixed-point with user- -- defined promitives. The warning is superfluous - -- if the fornal is private, because there can be + -- if the formal is private, because there can be -- no arithmetic operations in the generic so there -- no danger of confusion. @@ -1793,6 +1885,16 @@ package body Sem_Ch12 is Instantiate_Formal_Subprogram (Formal, Match, Analyzed_Formal)); + -- If formal subprogram has contracts, create wrappers + -- for it. This is an expansion activity that cannot + -- take place e.g. within an enclosing generic unit. + + if Has_Contracts (Analyzed_Formal) + and then Expander_Active + then + Build_Subprogram_Wrappers; + end if; + -- An instantiation is a freeze point for the actuals, -- unless this is a rewritten formal package. @@ -1826,7 +1928,7 @@ package body Sem_Ch12 is end if; -- If this is a nested generic, preserve default for later - -- instantiations. We do this as well for GNATProve use, + -- instantiations. We do this as well for GNATprove use, -- so that the list of generic associations is complete. if No (Match) and then Box_Present (Formal) then @@ -1846,10 +1948,19 @@ package body Sem_Ch12 is end if; when N_Formal_Package_Declaration => - Match := - Matching_Actual - (Defining_Identifier (Formal), - Defining_Identifier (Original_Node (Analyzed_Formal))); + -- The name of the formal package may be hidden by the + -- formal parameter itself. + + if Error_Posted (Analyzed_Formal) then + Abandon_Instantiation (Instantiation_Node); + + else + Match := + Matching_Actual + (Defining_Identifier (Formal), + Defining_Identifier + (Original_Node (Analyzed_Formal))); + end if; if No (Match) then if Partial_Parameterization then @@ -1992,10 +2103,10 @@ package body Sem_Ch12 is S := Current_Scope; while Present (S) loop - if Ekind_In (S, E_Block, - E_Function, - E_Loop, - E_Procedure) + if Ekind (S) in E_Block + | E_Function + | E_Loop + | E_Procedure then Needs_Freezing := False; exit; @@ -2139,9 +2250,9 @@ package body Sem_Ch12 is if Nkind (Def) = N_Constrained_Array_Definition then DSS := First (Discrete_Subtype_Definitions (Def)); while Present (DSS) loop - if Nkind_In (DSS, N_Subtype_Indication, - N_Range, - N_Attribute_Reference) + if Nkind (DSS) in N_Subtype_Indication + | N_Range + | N_Attribute_Reference then Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); end if; @@ -3048,8 +3159,7 @@ package body Sem_Ch12 is Set_Has_Completion (Formal, True); - -- Add semantic information to the original defining identifier for ASIS - -- use. + -- Add semantic information to the original defining identifier. Set_Ekind (Pack_Id, E_Package); Set_Etype (Pack_Id, Standard_Void_Type); @@ -3476,6 +3586,12 @@ package body Sem_Ch12 is end loop; Generate_Reference_To_Generic_Formals (Current_Scope); + + -- For Ada 2020, some formal parameters can carry aspects, which must + -- be name-resolved at the end of the list of formal parameters (which + -- has the semantics of a declaration list). + + Analyze_Contracts (Generic_Formal_Declarations (N)); end Analyze_Generic_Formal_Part; ------------------------------------------ @@ -3493,8 +3609,6 @@ package body Sem_Ch12 is Save_Parent : Node_Id; begin - Check_SPARK_05_Restriction ("generic is not allowed", N); - -- A generic may grant access to its private enclosing context depending -- on the placement of its corresponding body. From elaboration point of -- view, the flow of execution may enter this private context, and then @@ -3699,8 +3813,6 @@ package body Sem_Ch12 is Typ : Entity_Id; begin - Check_SPARK_05_Restriction ("generic is not allowed", N); - -- A generic may grant access to its private enclosing context depending -- on the placement of its corresponding body. From elaboration point of -- view, the flow of execution may enter this private context, and then @@ -3748,13 +3860,6 @@ package body Sem_Ch12 is Enter_Name (Id); Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1); - -- Analyze the aspects of the generic copy to ensure that all generated - -- pragmas (if any) perform their semantic effects. - - if Has_Aspects (N) then - Analyze_Aspect_Specifications (N, Id); - end if; - Push_Scope (Id); Enter_Generic_Scope (Id); Set_Inner_Instances (Id, New_Elmt_List); @@ -3839,6 +3944,13 @@ package body Sem_Ch12 is Set_Etype (Id, Standard_Void_Type); end if; + -- Analyze the aspects of the generic copy to ensure that all generated + -- pragmas (if any) perform their semantic effects. + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Id); + end if; + -- For a library unit, we have reconstructed the entity for the unit, -- and must reset it in the library tables. We also make sure that -- Body_Required is set properly in the original compilation unit node. @@ -4032,8 +4144,6 @@ package body Sem_Ch12 is Modes => True, Warnings => True); - Check_SPARK_05_Restriction ("generic is not allowed", N); - -- Very first thing: check for Text_IO special unit in case we are -- instantiating one of the children of [[Wide_]Wide_]Text_IO. @@ -4348,8 +4458,7 @@ package body Sem_Ch12 is -- body if there is one and it needs to be instantiated here. -- We instantiate the body only if we are generating code, or if we - -- are generating cross-reference information, or if we are building - -- trees for ASIS use or GNATprove use. + -- are generating cross-reference information, or for GNATprove use. declare Enclosing_Body_Present : Boolean := False; @@ -4446,7 +4555,7 @@ package body Sem_Ch12 is and then not Inline_Now and then (Operating_Mode = Generate_Code or else (Operating_Mode = Check_Semantics - and then (ASIS_Mode or GNATprove_Mode))); + and then GNATprove_Mode)); -- If front-end inlining is enabled or there are any subprograms -- marked with Inline_Always, do not instantiate body when within @@ -4781,17 +4890,6 @@ package body Sem_Ch12 is Inline_Instance_Body (N, Gen_Unit, Act_Decl); end if; - -- The following is a tree patch for ASIS: ASIS needs separate nodes to - -- be used as defining identifiers for a formal package and for the - -- corresponding expanded package. - - if Nkind (N) = N_Formal_Package_Declaration then - Act_Decl_Id := New_Copy (Defining_Entity (N)); - Set_Comes_From_Source (Act_Decl_Id, True); - Set_Is_Generic_Instance (Act_Decl_Id, False); - Set_Defining_Identifier (N, Act_Decl_Id); - end if; - -- Check that if N is an instantiation of System.Dim_Float_IO or -- System.Dim_Integer_IO, the formal type has a dimension system. @@ -4934,7 +5032,7 @@ package body Sem_Ch12 is while Present (S) and then S /= Standard_Standard loop if Is_Generic_Instance (S) and then (In_Package_Body (S) - or else Ekind_In (S, E_Procedure, E_Function)) + or else Ekind (S) in E_Procedure | E_Function) then -- We still have to remove the entities of the enclosing -- instance from direct visibility. @@ -5103,7 +5201,7 @@ package body Sem_Ch12 is Set_Is_Generic_Instance (Inst, True); if In_Package_Body (Inst) - or else Ekind_In (S, E_Procedure, E_Function) + or else Ekind (S) in E_Procedure | E_Function then E := First_Entity (Instances (J)); while Present (E) loop @@ -5185,17 +5283,17 @@ package body Sem_Ch12 is if (Is_In_Main_Unit (N) or else Is_Inlined_Or_Child_Of_Inlined (Subp)) - -- Must be generating code or analyzing code in ASIS/GNATprove mode + -- Must be generating code or analyzing code in GNATprove mode and then (Operating_Mode = Generate_Code or else (Operating_Mode = Check_Semantics - and then (ASIS_Mode or GNATprove_Mode))) + and then GNATprove_Mode)) - -- The body is needed when generating code (full expansion), in ASIS - -- mode for other tools, and in GNATprove mode (special expansion) for - -- formal verification of the body itself. + -- The body is needed when generating code (full expansion) and in + -- in GNATprove mode (special expansion) for formal verification of + -- the body itself. - and then (Expander_Active or ASIS_Mode or GNATprove_Mode) + and then (Expander_Active or GNATprove_Mode) -- No point in inlining if ABE is inevitable @@ -5367,7 +5465,7 @@ package body Sem_Ch12 is -- Subprogram instance comes from source only if generic does - Set_Comes_From_Source (Act_Decl_Id, Comes_From_Source (Gen_Unit)); + Preserve_Comes_From_Source (Act_Decl_Id, Gen_Unit); -- If the instance is a child unit, mark the Id accordingly. Mark -- the anonymous entity as well, which is the real subprogram and @@ -5491,8 +5589,6 @@ package body Sem_Ch12 is Modes => True, Warnings => True); - Check_SPARK_05_Restriction ("generic is not allowed", N); - -- Very first thing: check for special Text_IO unit in case we are -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course -- such an instantiation is bogus (these are packages, not subprograms), @@ -5568,8 +5664,7 @@ package body Sem_Ch12 is -- If renaming, get original unit if Present (Renamed_Object (Gen_Unit)) - and then Ekind_In (Renamed_Object (Gen_Unit), E_Generic_Procedure, - E_Generic_Function) + and then Is_Generic_Subprogram (Renamed_Object (Gen_Unit)) then Gen_Unit := Renamed_Object (Gen_Unit); Set_Is_Instantiated (Gen_Unit); @@ -5814,8 +5909,7 @@ package body Sem_Ch12 is -- constitute a freeze point, but to insure that the freeze node -- is placed properly, it is created directly when instantiating -- the body (otherwise the freeze node might appear to early for - -- nested instantiations). For ASIS purposes, indicate that the - -- wrapper package has replaced the instantiation node. + -- nested instantiations). elsif Nkind (Parent (N)) = N_Compilation_Unit then Rewrite (N, Unit (Parent (N))); @@ -5823,7 +5917,7 @@ package body Sem_Ch12 is end if; -- Replace instance node for library-level instantiations of - -- intrinsic subprograms, for ASIS use. + -- intrinsic subprograms. elsif Nkind (Parent (N)) = N_Compilation_Unit then Rewrite (N, Unit (Parent (N))); @@ -5880,7 +5974,7 @@ package body Sem_Ch12 is if Nkind (Assoc) /= Nkind (N) then return Assoc; - elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then + elsif Nkind (Assoc) in N_Aggregate | N_Extension_Aggregate then return Assoc; else @@ -5900,11 +5994,11 @@ package body Sem_Ch12 is if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) and then Present (Associated_Node (Assoc)) - and then (Nkind_In (Associated_Node (Assoc), N_Function_Call, - N_Explicit_Dereference, - N_Integer_Literal, - N_Real_Literal, - N_String_Literal)) + and then Nkind (Associated_Node (Assoc)) in N_Function_Call + | N_Explicit_Dereference + | N_Integer_Literal + | N_Real_Literal + | N_String_Literal then Assoc := Associated_Node (Assoc); end if; @@ -6129,6 +6223,117 @@ package body Sem_Ch12 is return Decl; end Build_Operator_Wrapper; + ----------------------------------- + -- Build_Subprogram_Decl_Wrapper -- + ----------------------------------- + + function Build_Subprogram_Decl_Wrapper + (Formal_Subp : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Current_Scope); + Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp)); + Decl : Node_Id; + Subp : Entity_Id; + Parm_Spec : Node_Id; + Profile : List_Id := New_List; + Spec : Node_Id; + Form_F : Entity_Id; + New_F : Entity_Id; + + begin + + Subp := Make_Defining_Identifier (Loc, Chars (Formal_Subp)); + Set_Ekind (Subp, Ekind (Formal_Subp)); + Set_Is_Generic_Actual_Subprogram (Subp); + + Profile := Parameter_Specifications ( + New_Copy_Tree + (Specification (Unit_Declaration_Node (Formal_Subp)))); + + Form_F := First_Formal (Formal_Subp); + Parm_Spec := First (Profile); + + -- Create new entities for the formals. Reset entities so that + -- parameter types are properly resolved when wrapper declaration + -- is analyzed. + + while Present (Parm_Spec) loop + New_F := Make_Defining_Identifier (Loc, Chars (Form_F)); + Set_Defining_Identifier (Parm_Spec, New_F); + Set_Entity (Parameter_Type (Parm_Spec), Empty); + Next (Parm_Spec); + Next_Formal (Form_F); + end loop; + + if Ret_Type = Standard_Void_Type then + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Subp, + Parameter_Specifications => Profile); + else + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Subp, + Parameter_Specifications => Profile, + Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); + end if; + + Decl := + Make_Subprogram_Declaration (Loc, Specification => Spec); + + return Decl; + end Build_Subprogram_Decl_Wrapper; + + ----------------------------------- + -- Build_Subprogram_Body_Wrapper -- + ----------------------------------- + + function Build_Subprogram_Body_Wrapper + (Formal_Subp : Entity_Id; + Actual_Name : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Current_Scope); + Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp)); + Spec_Node : constant Node_Id := + Specification + (Build_Subprogram_Decl_Wrapper (Formal_Subp)); + Act : Node_Id; + Actuals : List_Id; + Body_Node : Node_Id; + Stmt : Node_Id; + begin + Actuals := New_List; + Act := First (Parameter_Specifications (Spec_Node)); + + while Present (Act) loop + Append_To (Actuals, + Make_Identifier (Loc, Chars (Defining_Identifier (Act)))); + Next (Act); + end loop; + + if Ret_Type = Standard_Void_Type then + Stmt := Make_Procedure_Call_Statement (Loc, + Name => Actual_Name, + Parameter_Associations => Actuals); + + else + Stmt := Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => Actual_Name, + Parameter_Associations => Actuals)); + end if; + + Body_Node := Make_Subprogram_Body (Loc, + Specification => Spec_Node, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Stmt))); + + return Body_Node; + end Build_Subprogram_Body_Wrapper; + ------------------------------------------- -- Build_Instance_Compilation_Unit_Nodes -- ------------------------------------------- @@ -6301,9 +6506,9 @@ package body Sem_Ch12 is if Kind = N_Formal_Type_Declaration then return; - elsif Nkind_In (Kind, N_Formal_Object_Declaration, - N_Formal_Package_Declaration) - or else Kind in N_Formal_Subprogram_Declaration + elsif Kind in N_Formal_Object_Declaration + | N_Formal_Package_Declaration + | N_Formal_Subprogram_Declaration then null; @@ -6496,9 +6701,8 @@ package body Sem_Ch12 is -- If the formal entity comes from a formal declaration, it was -- defaulted in the formal package, and no check is needed on it. - elsif Nkind_In (Original_Node (Parent (E2)), - N_Formal_Object_Declaration, - N_Formal_Type_Declaration) + elsif Nkind (Original_Node (Parent (E2))) in + N_Formal_Object_Declaration | N_Formal_Type_Declaration then -- If the formal is a tagged type the corresponding class-wide -- type has been generated as well, and it must be skipped. @@ -6808,48 +7012,6 @@ package body Sem_Ch12 is E : Entity_Id; Astype : Entity_Id; - function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean; - -- For a formal that is an array type, the component type is often a - -- previous formal in the same unit. The privacy status of the component - -- type will have been examined earlier in the traversal of the - -- corresponding actuals, and this status should not be modified for - -- the array (sub)type itself. However, if the base type of the array - -- (sub)type is private, its full view must be restored in the body to - -- be consistent with subsequent index subtypes, etc. - -- - -- To detect this case we have to rescan the list of formals, which is - -- usually short enough to ignore the resulting inefficiency. - - ----------------------------- - -- Denotes_Previous_Actual -- - ----------------------------- - - function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is - Prev : Entity_Id; - - begin - Prev := First_Entity (Instance); - while Present (Prev) loop - if Is_Type (Prev) - and then Nkind (Parent (Prev)) = N_Subtype_Declaration - and then Is_Entity_Name (Subtype_Indication (Parent (Prev))) - and then Entity (Subtype_Indication (Parent (Prev))) = Typ - then - return True; - - elsif Prev = E then - return False; - - else - Next_Entity (Prev); - end if; - end loop; - - return False; - end Denotes_Previous_Actual; - - -- Start of processing for Check_Generic_Actuals - begin E := First_Entity (Instance); while Present (E) loop @@ -6858,14 +7020,34 @@ package body Sem_Ch12 is and then Scope (Etype (E)) /= Instance and then Is_Entity_Name (Subtype_Indication (Parent (E))) then - if Is_Array_Type (E) - and then not Is_Private_Type (Etype (E)) - and then Denotes_Previous_Actual (Component_Type (E)) - then - null; - else - Check_Private_View (Subtype_Indication (Parent (E))); - end if; + -- Restore the proper view of the actual from the information + -- saved earlier by Instantiate_Type. + + Check_Private_View (Subtype_Indication (Parent (E))); + + -- If the actual is itself the formal of a parent instance, + -- then also restore the proper view of its actual and so on. + -- That's necessary for nested instantiations of the form + + -- generic + -- type Component is private; + -- type Array_Type is array (Positive range <>) of Component; + -- procedure Proc; + + -- when the outermost actuals have inconsistent views, because + -- the Component_Type of Array_Type of the inner instantiations + -- is the actual of Component of the outermost one and not that + -- of the corresponding inner instantiations. + + Astype := Ancestor_Subtype (E); + while Present (Astype) + and then Nkind (Parent (Astype)) = N_Subtype_Declaration + and then Present (Generic_Parent_Type (Parent (Astype))) + and then Is_Entity_Name (Subtype_Indication (Parent (Astype))) + loop + Check_Private_View (Subtype_Indication (Parent (Astype))); + Astype := Ancestor_Subtype (Astype); + end loop; Set_Is_Generic_Actual_Type (E); @@ -6900,15 +7082,6 @@ package body Sem_Ch12 is if Is_Discrete_Or_Fixed_Point_Type (E) then Set_RM_Size (E, RM_Size (Astype)); - - -- In nested instances, the base type of an access actual may - -- itself be private, and need to be exchanged. - - elsif Is_Access_Type (E) - and then Is_Private_Type (Etype (E)) - then - Check_Private_View - (New_Occurrence_Of (Etype (E), Sloc (Instance))); end if; elsif Ekind (E) = E_Package then @@ -7445,92 +7618,25 @@ package body Sem_Ch12 is and then Present (Full_View (T)) and then not In_Open_Scopes (Scope (T)) then - -- In the generic, the full type was visible. Save the private - -- entity, for subsequent exchange. + -- In the generic, the full declaration was visible Switch_View (T); elsif Has_Private_View (N) and then not Is_Private_Type (T) and then not Has_Been_Exchanged (T) - and then Etype (Get_Associated_Node (N)) /= T + and then (not In_Open_Scopes (Scope (T)) + or else Nkind (Parent (N)) = N_Subtype_Declaration) then - -- Only the private declaration was visible in the generic. If - -- the type appears in a subtype declaration, the subtype in the + -- In the generic, only the private declaration was visible + + -- If the type appears in a subtype declaration, the subtype in -- instance must have a view compatible with that of its parent, -- which must be exchanged (see corresponding code in Restore_ - -- Private_Views). Otherwise, if the type is defined in a parent - -- unit, leave full visibility within instance, which is safe. - - if In_Open_Scopes (Scope (Base_Type (T))) - and then not Is_Private_Type (Base_Type (T)) - and then Comes_From_Source (Base_Type (T)) - then - null; - - elsif Nkind (Parent (N)) = N_Subtype_Declaration - or else not In_Private_Part (Scope (Base_Type (T))) - then - Prepend_Elmt (T, Exchanged_Views); - Exchange_Declarations (Etype (Get_Associated_Node (N))); - end if; - - -- For composite types with inconsistent representation exchange - -- component types accordingly. - - elsif Is_Access_Type (T) - and then Is_Private_Type (Designated_Type (T)) - and then not Has_Private_View (N) - and then Present (Full_View (Designated_Type (T))) - then - Switch_View (Designated_Type (T)); - - elsif Is_Array_Type (T) then - if Is_Private_Type (Component_Type (T)) - and then not Has_Private_View (N) - and then Present (Full_View (Component_Type (T))) - then - Switch_View (Component_Type (T)); - end if; - - -- The normal exchange mechanism relies on the setting of a - -- flag on the reference in the generic. However, an additional - -- mechanism is needed for types that are not explicitly - -- mentioned in the generic, but may be needed in expanded code - -- in the instance. This includes component types of arrays and - -- designated types of access types. This processing must also - -- include the index types of arrays which we take care of here. - - declare - Indx : Node_Id; - Typ : Entity_Id; - - begin - Indx := First_Index (T); - while Present (Indx) loop - Typ := Base_Type (Etype (Indx)); - - if Is_Private_Type (Typ) - and then Present (Full_View (Typ)) - then - Switch_View (Typ); - end if; + -- Private_Views) so we make an exception to the open scope rule. - Next_Index (Indx); - end loop; - end; - - -- The following case does not test Has_Private_View (N) so it may - -- end up switching views when they are not supposed to be switched. - -- This might be in keeping with Set_Global_Type setting the flag - -- for an array type even if it is not private ??? - - elsif Is_Private_Type (T) - and then Present (Full_View (T)) - and then Is_Array_Type (Full_View (T)) - and then Is_Private_Type (Component_Type (Full_View (T))) - then - Switch_View (T); + Prepend_Elmt (T, Exchanged_Views); + Exchange_Declarations (Etype (Get_Associated_Node (N))); -- Finally, a non-private subtype may have a private base type, which -- must be exchanged for consistency. This can happen when a package @@ -7701,9 +7807,8 @@ package body Sem_Ch12 is function In_Defining_Unit_Name (Nam : Node_Id) return Boolean; -- True if an identifier is part of the defining program unit name of - -- a child unit. The entity of such an identifier must be kept (for - -- ASIS use) even though as the name of an enclosing generic it would - -- otherwise not be preserved in the generic tree. + -- a child unit. + -- Consider removing this subprogram now that ASIS no longer uses it. ---------------------- -- Copy_Descendants -- @@ -7852,11 +7957,11 @@ package body Sem_Ch12 is -- Special casing for identifiers and other entity names and operators - if Nkind_In (New_N, N_Character_Literal, - N_Expanded_Name, - N_Identifier, - N_Operator_Symbol) - or else Nkind (New_N) in N_Op + if Nkind (New_N) in N_Character_Literal + | N_Expanded_Name + | N_Identifier + | N_Operator_Symbol + | N_Op then if not Instantiating then @@ -7887,7 +7992,7 @@ package body Sem_Ch12 is -- The entities for parent units in the defining_program_unit of a -- generic child unit are established when the context of the unit -- is first analyzed, before the generic copy is made. They are - -- preserved in the copy for use in ASIS queries. + -- preserved in the copy for use in e.g. ASIS queries. Ent := Entity (New_N); @@ -7900,10 +8005,9 @@ package body Sem_Ch12 is end if; elsif No (Ent) - or else - not Nkind_In (Ent, N_Defining_Identifier, - N_Defining_Character_Literal, - N_Defining_Operator_Symbol) + or else Nkind (Ent) not in N_Defining_Identifier + | N_Defining_Character_Literal + | N_Defining_Operator_Symbol or else No (Scope (Ent)) or else (Scope (Ent) = Current_Instantiated_Parent.Gen_Id @@ -7936,6 +8040,117 @@ package body Sem_Ch12 is Set_Entity (New_N, Entity (Assoc)); Check_Private_View (N); + -- Here we deal with a very peculiar case for which the + -- Has_Private_View mechanism is not sufficient, because + -- the reference to the type is implicit in the tree, + -- that is to say, it's not referenced from a node but + -- only from another type, namely through Component_Type. + + -- package P is + + -- type Pt is private; + + -- generic + -- type Ft is array (Positive range <>) of Pt; + -- package G is + -- procedure Check (F1, F2 : Ft; Lt : Boolean); + -- end G; + + -- private + -- type Pt is new Boolean; + -- end P; + + -- package body P is + -- package body G is + -- procedure Check (F1, F2 : Ft; Lt : Boolean) is + -- begin + -- if (F1 < F2) /= Lt then + -- null; + -- end if; + -- end Check; + -- end G; + -- end P; + + -- type Arr is array (Positive range <>) of P.Pt; + + -- package Inst is new P.G (Arr); + + -- Pt is a global type for the generic package G and it + -- is not referenced in its body, but only as component + -- type of Ft, which is a local type. This means that no + -- references to Pt or Ft are seen during the copy of the + -- body, the only reference to Pt being seen is when the + -- actuals are checked by Check_Generic_Actuals, but Pt + -- is still private at this point. In the end, the views + -- of Pt are not switched in the body and, therefore, the + -- array comparison is rejected because the component is + -- still private. + + -- Adding e.g. a dummy variable of type Pt in the body is + -- sufficient to make everything work, so we generate an + -- artificial reference to Pt on the fly and thus force + -- the switching of views on the grounds that, if the + -- comparison was accepted during the semantic analysis + -- of the generic, this means that the component cannot + -- have been private (see Sem_Type.Valid_Comparison_Arg). + + if Nkind (Assoc) in N_Op_Compare + and then Present (Etype (Left_Opnd (Assoc))) + and then Is_Array_Type (Etype (Left_Opnd (Assoc))) + and then Present (Etype (Right_Opnd (Assoc))) + and then Is_Array_Type (Etype (Right_Opnd (Assoc))) + then + declare + Ltyp : constant Entity_Id := + Etype (Left_Opnd (Assoc)); + Rtyp : constant Entity_Id := + Etype (Right_Opnd (Assoc)); + begin + if Is_Private_Type (Component_Type (Ltyp)) then + Check_Private_View + (New_Occurrence_Of (Component_Type (Ltyp), + Sloc (N))); + end if; + if Is_Private_Type (Component_Type (Rtyp)) then + Check_Private_View + (New_Occurrence_Of (Component_Type (Rtyp), + Sloc (N))); + end if; + end; + + -- Here is a similar case, for the Designated_Type of an + -- access type that is present as target type in a type + -- conversion from another access type. In this case, if + -- the base types of the designated types are different + -- and the conversion was accepted during the semantic + -- analysis of the generic, this means that the target + -- type cannot have been private (see Valid_Conversion). + + elsif Nkind (Assoc) = N_Identifier + and then Nkind (Parent (Assoc)) = N_Type_Conversion + and then Subtype_Mark (Parent (Assoc)) = Assoc + and then Present (Etype (Assoc)) + and then Is_Access_Type (Etype (Assoc)) + and then Present (Etype (Expression (Parent (Assoc)))) + and then + Is_Access_Type (Etype (Expression (Parent (Assoc)))) + then + declare + Targ_Desig : constant Entity_Id := + Designated_Type (Etype (Assoc)); + Expr_Desig : constant Entity_Id := + Designated_Type + (Etype (Expression (Parent (Assoc)))); + begin + if Base_Type (Targ_Desig) /= Base_Type (Expr_Desig) + and then Is_Private_Type (Targ_Desig) + then + Check_Private_View + (New_Occurrence_Of (Targ_Desig, Sloc (N))); + end if; + end; + end if; + -- The node is a reference to a global type and acts as the -- subtype mark of a qualified expression created in order -- to aid resolution of accidental overloading in instances. @@ -7959,9 +8174,9 @@ package body Sem_Ch12 is then Set_Entity (New_N, Entity (Name (Assoc))); - elsif Nkind_In (Assoc, N_Defining_Identifier, - N_Defining_Character_Literal, - N_Defining_Operator_Symbol) + elsif Nkind (Assoc) in N_Defining_Identifier + | N_Defining_Character_Literal + | N_Defining_Operator_Symbol and then Expander_Active then -- Inlining case: we are copying a tree that contains @@ -8170,7 +8385,7 @@ package body Sem_Ch12 is Set_Assignment_OK (Name (New_N), True); end if; - elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then if not Instantiating then Set_Associated_Node (N, New_N); @@ -8290,7 +8505,7 @@ package body Sem_Ch12 is -- Do not copy Comment or Ident pragmas their content is relevant to -- the generic unit, not to the instantiating unit. - if Nam_In (Pragma_Name_Unmapped (N), Name_Comment, Name_Ident) then + if Pragma_Name_Unmapped (N) in Name_Comment | Name_Ident then New_N := Make_Null_Statement (Sloc (N)); -- Do not copy pragmas generated from aspects because the pragmas do @@ -8310,7 +8525,7 @@ package body Sem_Ch12 is Copy_Descendants; end if; - elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then + elsif Nkind (N) in N_Integer_Literal | N_Real_Literal then -- No descendant fields need traversing @@ -9009,10 +9224,10 @@ package body Sem_Ch12 is else Inst := Next (Decl); - while not Nkind_In (Inst, N_Formal_Package_Declaration, - N_Function_Instantiation, - N_Package_Instantiation, - N_Procedure_Instantiation) + while Nkind (Inst) not in N_Formal_Package_Declaration + | N_Function_Instantiation + | N_Package_Instantiation + | N_Procedure_Instantiation loop Next (Inst); end loop; @@ -9041,6 +9256,32 @@ package body Sem_Ch12 is return False; end Has_Been_Exchanged; + ------------------- + -- Has_Contracts -- + ------------------- + + function Has_Contracts (Decl : Node_Id) return Boolean is + A_List : constant List_Id := Aspect_Specifications (Decl); + A_Spec : Node_Id; + A_Id : Aspect_Id; + begin + if No (A_List) then + return False; + else + A_Spec := First (A_List); + while Present (A_Spec) loop + A_Id := Get_Aspect_Id (A_Spec); + if A_Id = Aspect_Pre or else A_Id = Aspect_Post then + return True; + end if; + + Next (A_Spec); + end loop; + + return False; + end if; + end Has_Contracts; + ---------- -- Hash -- ---------- @@ -9279,7 +9520,7 @@ package body Sem_Ch12 is while Present (P) and then Nkind (Parent (P)) /= N_Compilation_Unit loop - if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then + if Nkind (P) in N_Package_Body | N_Subprogram_Body then if Nkind (Parent (P)) = N_Subunit then return Corresponding_Stub (Parent (P)); else @@ -9377,8 +9618,8 @@ package body Sem_Ch12 is -- the current scope as well. elsif Present (Next (N)) - and then Nkind_In (Next (N), N_Subprogram_Body, - N_Package_Body) + and then Nkind (Next (N)) in N_Subprogram_Body + | N_Package_Body and then Comes_From_Source (Next (N)) then null; @@ -9592,8 +9833,8 @@ package body Sem_Ch12 is Must_Delay := (Gen_Unit = Act_Unit - and then (Nkind_In (Gen_Unit, N_Generic_Package_Declaration, - N_Package_Declaration) + and then (Nkind (Gen_Unit) in N_Generic_Package_Declaration + | N_Package_Declaration or else (Gen_Unit = Body_Unit and then True_Sloc (N, Act_Unit) < Sloc (Orig_Body))) @@ -9664,7 +9905,7 @@ package body Sem_Ch12 is -- Freeze package enclosing instance of inner generic after -- instance of enclosing generic. - elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body) + elsif Nkind (Parent (N)) in N_Package_Body | N_Subprogram_Body and then In_Same_Declarative_Part (Parent (Freeze_Node (Par)), Parent (N)) then @@ -10168,7 +10409,9 @@ package body Sem_Ch12 is => Formal_Ent := Defining_Identifier (F); - while Chars (Act) /= Chars (Formal_Ent) loop + while Present (Act) + and then Chars (Act) /= Chars (Formal_Ent) + loop Next_Entity (Act); end loop; @@ -10179,7 +10422,9 @@ package body Sem_Ch12 is => Formal_Ent := Defining_Entity (F); - while Chars (Act) /= Chars (Formal_Ent) loop + while Present (Act) + and then Chars (Act) /= Chars (Formal_Ent) + loop Next_Entity (Act); end loop; @@ -10364,7 +10609,7 @@ package body Sem_Ch12 is -- such as a parent generic within the body of a generic child. if not Is_Entity_Name (Actual) - or else not Ekind_In (Entity (Actual), E_Generic_Package, E_Package) + or else not Is_Package_Or_Generic_Package (Entity (Actual)) then Error_Msg_N ("expect package instance to instantiate formal", Actual); @@ -10663,10 +10908,10 @@ package body Sem_Ch12 is end if; if (Present (Act_E) and then Is_Overloadable (Act_E)) - or else Nkind_In (Act, N_Attribute_Reference, - N_Indexed_Component, - N_Character_Literal, - N_Explicit_Dereference) + or else Nkind (Act) in N_Attribute_Reference + | N_Indexed_Component + | N_Character_Literal + | N_Explicit_Dereference then return; end if; @@ -10699,7 +10944,23 @@ package body Sem_Ch12 is -- Create new entity for the actual (New_Copy_Tree does not), and -- indicate that it is an actual. - New_Subp := Make_Defining_Identifier (Loc, Chars (Formal_Sub)); + -- If the actual is not an entity (i.e. an attribute reference) + -- and the formal includes aspect specifications for contracts, + -- we create an internal name for the renaming declaration. The + -- constructed wrapper contains a call to the entity in the renaming. + -- This is an expansion activity, as is the wrapper creation. + + if Ada_Version >= Ada_2020 + and then Has_Contracts (Analyzed_Formal) + and then not Is_Entity_Name (Actual) + and then Expander_Active + then + New_Subp := Make_Temporary (Sloc (Actual), 'S'); + Set_Defining_Unit_Name (New_Spec, New_Subp); + else + New_Subp := Make_Defining_Identifier (Loc, Chars (Formal_Sub)); + end if; + Set_Ekind (New_Subp, Ekind (Analyzed_S)); Set_Is_Generic_Actual_Subprogram (New_Subp); Set_Defining_Unit_Name (New_Spec, New_Subp); @@ -10749,10 +11010,10 @@ package body Sem_Ch12 is Nam := Actual; elsif Present (Default_Name (Formal)) then - if not Nkind_In (Default_Name (Formal), N_Attribute_Reference, - N_Selected_Component, - N_Indexed_Component, - N_Character_Literal) + if Nkind (Default_Name (Formal)) not in N_Attribute_Reference + | N_Selected_Component + | N_Indexed_Component + | N_Character_Literal and then Present (Entity (Default_Name (Formal))) then Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); @@ -10788,7 +11049,13 @@ package body Sem_Ch12 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Make_Null_Statement (Loc)))); - Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec)); + -- RM 12.6 (16 2/2): The procedure has convention Intrinsic + + Set_Convention (Defining_Unit_Name (New_Spec), Convention_Intrinsic); + + -- Eliminate the calls to it when optimization is enabled + + Set_Is_Inlined (Defining_Unit_Name (New_Spec)); return Decl_Node; else @@ -10924,41 +11191,6 @@ package body Sem_Ch12 is Subt_Decl : Node_Id := Empty; Subt_Mark : Node_Id := Empty; - function Copy_Access_Def return Node_Id; - -- If formal is an anonymous access, copy access definition of formal - -- for generated object declaration. - - --------------------- - -- Copy_Access_Def -- - --------------------- - - function Copy_Access_Def return Node_Id is - begin - Def := New_Copy_Tree (Acc_Def); - - -- In addition, if formal is an access to subprogram we need to - -- generate new formals for the signature of the default, so that - -- the tree is properly formatted for ASIS use. - - if Present (Access_To_Subprogram_Definition (Acc_Def)) then - declare - Par_Spec : Node_Id; - begin - Par_Spec := - First (Parameter_Specifications - (Access_To_Subprogram_Definition (Def))); - while Present (Par_Spec) loop - Set_Defining_Identifier (Par_Spec, - Make_Defining_Identifier (Sloc (Acc_Def), - Chars => Chars (Defining_Identifier (Par_Spec)))); - Next (Par_Spec); - end loop; - end; - end if; - - return Def; - end Copy_Access_Def; - -- Start of processing for Instantiate_Object begin @@ -10990,8 +11222,9 @@ package body Sem_Ch12 is -- use the actual directly, rather than a copy, because it is not -- used further in the list of actuals, and because a copy or a use -- of relocate_node is incorrect if the instance is nested within a - -- generic. In order to simplify ASIS searches, the Generic_Parent - -- field links the declaration to the generic association. + -- generic. In order to simplify e.g. ASIS queries, the + -- Generic_Parent field links the declaration to the generic + -- association. if No (Actual) then Error_Msg_NE @@ -11103,10 +11336,8 @@ package body Sem_Ch12 is -- access type. if Ada_Version < Ada_2005 - or else Ekind (Base_Type (Ftyp)) /= - E_Anonymous_Access_Type - or else Ekind (Base_Type (Etype (Actual))) /= - E_Anonymous_Access_Type + or else not Is_Anonymous_Access_Type (Base_Type (Ftyp)) + or else not Is_Anonymous_Access_Type (Base_Type (Etype (Actual))) then Error_Msg_NE ("type of actual does not match type of&", Actual, Gen_Obj); @@ -11147,6 +11378,44 @@ package body Sem_Ch12 is Actual); end if; + -- Check actual/formal compatibility with respect to the four + -- volatility refinement aspects. + + declare + Actual_Obj : Entity_Id; + N : Node_Id := Actual; + begin + -- Similar to Sem_Util.Get_Enclosing_Object, but treat + -- pointer dereference like component selection. + loop + if Is_Entity_Name (N) then + Actual_Obj := Entity (N); + exit; + end if; + + case Nkind (N) is + when N_Indexed_Component + | N_Selected_Component + | N_Slice + | N_Explicit_Dereference + => + N := Prefix (N); + + when N_Type_Conversion => + N := Expression (N); + + when others => + Actual_Obj := Etype (N); + exit; + end case; + end loop; + + Check_Volatility_Compatibility + (Actual_Obj, A_Gen_Obj, "actual object", + "its corresponding formal object of mode in out", + Srcpos_Bearer => Actual); + end; + -- Formal in-parameter else @@ -11159,8 +11428,9 @@ package body Sem_Ch12 is if Present (Actual) then if Present (Subt_Mark) then Def := New_Copy_Tree (Subt_Mark); - else pragma Assert (Present (Acc_Def)); - Def := Copy_Access_Def; + else + pragma Assert (Present (Acc_Def)); + Def := New_Copy_Tree (Acc_Def); end if; Decl_Node := @@ -11241,8 +11511,9 @@ package body Sem_Ch12 is if Present (Subt_Mark) then Def := New_Copy (Subt_Mark); - else pragma Assert (Present (Acc_Def)); - Def := Copy_Access_Def; + else + pragma Assert (Present (Acc_Def)); + Def := New_Copy_Tree (Acc_Def); end if; Decl_Node := @@ -11299,23 +11570,32 @@ package body Sem_Ch12 is Actual_Decl := Parent (Entity (Actual)); end if; - -- Ada 2005 (AI-423): For a formal object declaration with a null - -- exclusion or an access definition that has a null exclusion: If the - -- actual matching the formal object declaration denotes a generic - -- formal object of another generic unit G, and the instantiation - -- containing the actual occurs within the body of G or within the body - -- of a generic unit declared within the declarative region of G, then - -- the declaration of the formal object of G must have a null exclusion. - -- Otherwise, the subtype of the actual matching the formal object - -- declaration shall exclude null. + -- Ada 2005 (AI-423) refined by AI12-0287: + -- For an object_renaming_declaration with a null_exclusion or an + -- access_definition that has a null_exclusion, the subtype of the + -- object_name shall exclude null. In addition, if the + -- object_renaming_declaration occurs within the body of a generic unit + -- G or within the body of a generic unit declared within the + -- declarative region of generic unit G, then: + -- * if the object_name statically denotes a generic formal object of + -- mode in out of G, then the declaration of that object shall have a + -- null_exclusion; + -- * if the object_name statically denotes a call of a generic formal + -- function of G, then the declaration of the result of that function + -- shall have a null_exclusion. if Ada_Version >= Ada_2005 and then Present (Actual_Decl) - and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration, - N_Object_Declaration) + and then Nkind (Actual_Decl) in N_Formal_Object_Declaration + | N_Object_Declaration and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration and then not Has_Null_Exclusion (Actual_Decl) and then Has_Null_Exclusion (Analyzed_Formal) + and then Ekind (Defining_Identifier (Analyzed_Formal)) + = E_Generic_In_Out_Parameter + and then ((In_Generic_Scope (Entity (Actual)) + and then In_Package_Body (Scope (Entity (Actual)))) + or else not Can_Never_Be_Null (Etype (Actual))) then Error_Msg_Sloc := Sloc (Analyzed_Formal); Error_Msg_N @@ -11331,6 +11611,7 @@ package body Sem_Ch12 is and then Present (Actual) and then Is_Object_Reference (Actual) and then Is_Effectively_Volatile_Object (Actual) + and then not Is_Effectively_Volatile (A_Gen_Obj) then Error_Msg_N ("volatile object cannot act as actual in generic instantiation", @@ -11622,7 +11903,7 @@ package body Sem_Ch12 is Act_Body_Id := Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); - Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); + Preserve_Comes_From_Source (Act_Body_Id, Act_Decl_Id); -- Some attributes of spec entity are not inherited by body entity @@ -11746,6 +12027,19 @@ package body Sem_Ch12 is end if; Restore_Hidden_Primitives (Vis_Prims_List); + + -- Restore the private views that were made visible when the body of + -- the instantiation was created. Note that, in the case where one of + -- these private views is declared in the parent, there is a nesting + -- issue with the calls to Install_Parent and Remove_Parent made in + -- between above with In_Body set to True, because these calls also + -- want to swap and restore this private view respectively. In this + -- case, the call to Install_Parent does nothing, but the call to + -- Remove_Parent does restore the private view, thus undercutting the + -- call to Restore_Private_Views. That's OK under the condition that + -- the two mechanisms swap exactly the same entities, in particular + -- the private entities dependent on the primary private entities. + Restore_Private_Views (Act_Decl_Id); -- Remove the current unit from visibility if this is an instance @@ -11989,7 +12283,7 @@ package body Sem_Ch12 is Act_Body_Id := Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); - Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); + Preserve_Comes_From_Source (Act_Body_Id, Act_Decl_Id); Set_Defining_Unit_Name (Specification (Act_Body), Act_Body_Id); Set_Corresponding_Spec (Act_Body, Act_Decl_Id); @@ -12183,7 +12477,7 @@ package body Sem_Ch12 is Subt : Entity_Id; procedure Check_Shared_Variable_Control_Aspects; - -- Ada_2020: Verify that shared variable control aspects (RM C.6) + -- Ada 2020: Verify that shared variable control aspects (RM C.6) -- that may be specified for a formal type are obeyed by the actual. procedure Diagnose_Predicated_Actual; @@ -12214,27 +12508,40 @@ package body Sem_Ch12 is -- Check_Shared_Variable_Control_Aspects -- -------------------------------------------- - -- Ada_2020: Verify that shared variable control aspects (RM C.6) + -- Ada 2020: Verify that shared variable control aspects (RM C.6) -- that may be specified for the formal are obeyed by the actual. + -- If the formal is a derived type the aspect specifications must match. + -- NOTE: AI12-0282 implies that matching of aspects is required between + -- formal and actual in all cases, but this is too restrictive. + -- In particular it violates a language design rule: a limited private + -- indefinite formal can be matched by any actual. The current code + -- reflects an older and more permissive version of RM C.6 (12/5). procedure Check_Shared_Variable_Control_Aspects is begin if Ada_Version >= Ada_2020 then if Is_Atomic (A_Gen_T) and then not Is_Atomic (Act_T) then Error_Msg_NE - ("actual for& must be an atomic type", Actual, A_Gen_T); + ("actual for& must have Atomic aspect", Actual, A_Gen_T); + + elsif Is_Derived_Type (A_Gen_T) + and then Is_Atomic (A_Gen_T) /= Is_Atomic (Act_T) + then + Error_Msg_NE + ("actual for& has different Atomic aspect", Actual, A_Gen_T); end if; if Is_Volatile (A_Gen_T) and then not Is_Volatile (Act_T) then Error_Msg_NE - ("actual for& must be a Volatile type", Actual, A_Gen_T); - end if; + ("actual for& has different Volatile aspect", + Actual, A_Gen_T); - if - Is_Independent (A_Gen_T) and then not Is_Independent (Act_T) + elsif Is_Derived_Type (A_Gen_T) + and then Is_Volatile (A_Gen_T) /= Is_Volatile (Act_T) then Error_Msg_NE - ("actual for& must be an Independent type", Actual, A_Gen_T); + ("actual for& has different Volatile aspect", + Actual, A_Gen_T); end if; -- We assume that an array type whose atomic component type @@ -12242,44 +12549,60 @@ package body Sem_Ch12 is -- aspect Has_Atomic_Components. This is a reasonable inference -- from the intent of AI12-0282, and makes it legal to use an -- actual that does not have the identical aspect as the formal. + -- Ditto for volatile components. - if Has_Atomic_Components (A_Gen_T) - and then not Has_Atomic_Components (Act_T) - then - if Is_Array_Type (Act_T) - and then Is_Atomic (Component_Type (Act_T)) - then - null; + declare + Actual_Atomic_Comp : constant Boolean := + Has_Atomic_Components (Act_T) + or else (Is_Array_Type (Act_T) + and then Is_Atomic (Component_Type (Act_T))); + begin + if Has_Atomic_Components (A_Gen_T) /= Actual_Atomic_Comp then + Error_Msg_NE + ("formal and actual for& must agree on atomic components", + Actual, A_Gen_T); + end if; + end; - else + declare + Actual_Volatile_Comp : constant Boolean := + Has_Volatile_Components (Act_T) + or else (Is_Array_Type (Act_T) + and then Is_Volatile (Component_Type (Act_T))); + begin + if Has_Volatile_Components (A_Gen_T) /= Actual_Volatile_Comp + then Error_Msg_NE - ("actual for& must have atomic components", + ("actual for& must have volatile components", Actual, A_Gen_T); end if; + end; + + -- The following two aspects do not require exact matching, + -- but only one-way agreement. See RM C.6. + + if Is_Independent (A_Gen_T) and then not Is_Independent (Act_T) + then + Error_Msg_NE + ("actual for& must have Independent aspect specified", + Actual, A_Gen_T); end if; if Has_Independent_Components (A_Gen_T) - and then not Has_Independent_Components (Act_T) + and then not Has_Independent_Components (Act_T) then Error_Msg_NE - ("actual for& must have independent components", - Actual, A_Gen_T); + ("actual for& must have Independent_Components specified", + Actual, A_Gen_T); end if; - if Has_Volatile_Components (A_Gen_T) - and then not Has_Volatile_Components (Act_T) - then - if Is_Array_Type (Act_T) - and then Is_Volatile (Component_Type (Act_T)) - then - null; + -- Check actual/formal compatibility with respect to the four + -- volatility refinement aspects. - else - Error_Msg_NE - ("actual for& must have volatile components", - Actual, A_Gen_T); - end if; - end if; + Check_Volatility_Compatibility + (Act_T, A_Gen_T, + "actual type", "its corresponding formal type", + Srcpos_Bearer => Act_T); end if; end Check_Shared_Variable_Control_Aspects; @@ -12327,8 +12650,8 @@ package body Sem_Ch12 is Root_Type (Act_T))) or else - (Ekind_In (Gen_T, E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Type) + (Ekind (Gen_T) in E_Anonymous_Access_Subprogram_Type + | E_Anonymous_Access_Type and then Ekind (Act_T) = Ekind (Gen_T) and then Subtypes_Statically_Match (Designated_Type (Gen_T), Designated_Type (Act_T))); @@ -12901,8 +13224,8 @@ package body Sem_Ch12 is -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1 -- removes the second instance of the phrase "or allow pass by copy". - -- In Ada_2020 the aspect may be specified explicitly for the formal - -- regardless of whether an ancestor obeys it. + -- For Ada 2020, the aspect may be specified explicitly for the + -- formal regardless of whether an ancestor obeys it. if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) @@ -13016,8 +13339,16 @@ package body Sem_Ch12 is if not Subtypes_Statically_Compatible (Act_T, Ancestor, Formal_Derived_Matching => True) then - Error_Msg_N - ("constraint on actual is incompatible with formal", Actual); + Error_Msg_NE + ("actual for & must be statically compatible with ancestor", + Actual, Gen_T); + + if not Predicates_Compatible (Act_T, Ancestor) then + Error_Msg_N + ("\predicate on actual is not compatible with ancestor", + Actual); + end if; + Abandon_Instantiation (Actual); end if; end if; @@ -13261,17 +13592,8 @@ package body Sem_Ch12 is -- explicitly so. If not declared limited, the actual cannot be -- limited (see AI05-0087). - -- Even though this AI is a binding interpretation, we enable the - -- check only in Ada 2012 mode, because this improper construct - -- shows up in user code and in existing B-tests. - - if Is_Limited_Type (Act_T) - and then not Is_Limited_Type (A_Gen_T) - and then Ada_Version >= Ada_2012 - then - if In_Instance then - null; - else + if Is_Limited_Type (Act_T) and then not Is_Limited_Type (A_Gen_T) then + if not In_Instance then Error_Msg_NE ("actual for non-limited & cannot be a limited type", Actual, Gen_T); @@ -13280,30 +13602,25 @@ package body Sem_Ch12 is end if; end if; - -- Don't check Ada_Version here (for now) because AI12-0036 is - -- a binding interpretation; this decision may be reversed if - -- the situation turns out to be similar to that of the preceding - -- Is_Limited_Type test (see preceding comment). + -- Check for AI12-0036 declare Formal_Is_Private_Extension : constant Boolean := Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration; Actual_Is_Tagged : constant Boolean := Is_Tagged_Type (Act_T); + begin if Actual_Is_Tagged /= Formal_Is_Private_Extension then - if In_Instance then - null; - else + if not In_Instance then if Actual_Is_Tagged then Error_Msg_NE - ("actual for & cannot be a tagged type", - Actual, Gen_T); + ("actual for & cannot be a tagged type", Actual, Gen_T); else Error_Msg_NE - ("actual for & must be a tagged type", - Actual, Gen_T); + ("actual for & must be a tagged type", Actual, Gen_T); end if; + Abandon_Instantiation (Actual); end if; end if; @@ -13696,12 +14013,11 @@ package body Sem_Ch12 is Defining_Identifier => Subt, Subtype_Indication => New_Occurrence_Of (Act_T, Loc)); - if Is_Private_Type (Act_T) then - Set_Has_Private_View (Subtype_Indication (Decl_Node)); + -- Record whether the actual is private at this point, so that + -- Check_Generic_Actuals can restore its proper view before the + -- semantic analysis of the instance. - elsif Is_Access_Type (Act_T) - and then Is_Private_Type (Designated_Type (Act_T)) - then + if Is_Private_Type (Act_T) then Set_Has_Private_View (Subtype_Indication (Decl_Node)); end if; @@ -13734,8 +14050,8 @@ package body Sem_Ch12 is Set_Generic_Parent_Type (Decl_Node, Ancestor); end if; - elsif Nkind_In (Def, N_Formal_Private_Type_Definition, - N_Formal_Incomplete_Type_Definition) + elsif Nkind (Def) in N_Formal_Private_Type_Definition + | N_Formal_Incomplete_Type_Definition then Set_Generic_Parent_Type (Decl_Node, A_Gen_T); end if; @@ -13886,8 +14202,8 @@ package body Sem_Ch12 is -- For a subprogram instantiation, omit instantiations intrinsic -- operations (Unchecked_Conversions, etc.) that have no bodies. - elsif Nkind_In (Decl, N_Function_Instantiation, - N_Procedure_Instantiation) + elsif Nkind (Decl) in N_Function_Instantiation + | N_Procedure_Instantiation and then not Is_Intrinsic_Subprogram (Entity (Name (Decl))) then Append_Elmt (Decl, Previous_Instances); @@ -13987,6 +14303,21 @@ package body Sem_Ch12 is exit; + -- If an ancestor of the generic comes from a formal package + -- there is no source for the ancestor body. This is detected + -- by examining the scope of the ancestor and its declaration. + -- The body, if any is needed, will be available when the + -- current unit (containing a formal package) is instantiated. + + elsif Nkind (True_Parent) = N_Package_Specification + and then Present (Generic_Parent (True_Parent)) + and then Nkind + (Original_Node (Unit_Declaration_Node + (Scope (Generic_Parent (True_Parent))))) + = N_Formal_Package_Declaration + then + return; + else True_Parent := Parent (True_Parent); end if; @@ -14114,10 +14445,10 @@ package body Sem_Ch12 is (Last (Visible_Declarations (Specification (Info.Act_Decl)))); begin - while Nkind_In (Decl, - N_Null_Statement, - N_Pragma, - N_Subprogram_Renaming_Declaration) + while Nkind (Decl) in + N_Null_Statement | + N_Pragma | + N_Subprogram_Renaming_Declaration loop Decl := Prev (Decl); end loop; @@ -14836,9 +15167,9 @@ package body Sem_Ch12 is -- explicitly now, in order to remain consistent with the view of the -- parent type. - if Ekind_In (Typ, E_Private_Type, - E_Limited_Private_Type, - E_Record_Type_With_Private) + if Ekind (Typ) in E_Private_Type + | E_Limited_Private_Type + | E_Record_Type_With_Private then Dep_Elmt := First_Elmt (Private_Dependents (Typ)); while Present (Dep_Elmt) loop @@ -15270,11 +15601,7 @@ package body Sem_Ch12 is -- If not a private type, nothing else to do if not Is_Private_Type (Typ) then - if Is_Array_Type (Typ) - and then Is_Private_Type (Component_Type (Typ)) - then - Set_Has_Private_View (N); - end if; + null; -- If it is a derivation of a private type in a context where no -- full view is needed, nothing to do either. @@ -15329,9 +15656,9 @@ package body Sem_Ch12 is -- preserve in this case, since the expansion will be redone in -- the instance. - if not Nkind_In (E, N_Defining_Character_Literal, - N_Defining_Identifier, - N_Defining_Operator_Symbol) + if Nkind (E) not in N_Defining_Character_Literal + | N_Defining_Identifier + | N_Defining_Operator_Symbol then Set_Associated_Node (N, Empty); Set_Etype (N, Empty); @@ -15353,38 +15680,7 @@ package body Sem_Ch12 is end if; if Is_Global (E) then - - -- If the entity is a package renaming that is the prefix of - -- an expanded name, it has been rewritten as the renamed - -- package, which is necessary semantically but complicates - -- ASIS tree traversal, so we recover the original entity to - -- expose the renaming. Take into account that the context may - -- be a nested generic, that the original node may itself have - -- an associated node that had better be an entity, and that - -- the current node is still a selected component. - - if Ekind (E) = E_Package - and then Nkind (N) = N_Selected_Component - and then Nkind (Parent (N)) = N_Expanded_Name - and then Present (Original_Node (N2)) - and then Is_Entity_Name (Original_Node (N2)) - and then Present (Entity (Original_Node (N2))) - then - if Is_Global (Entity (Original_Node (N2))) then - N2 := Original_Node (N2); - Set_Associated_Node (N, N2); - Set_Global_Type (N, N2); - - -- Renaming is local, and will be resolved in instance - - else - Set_Associated_Node (N, Empty); - Set_Etype (N, Empty); - end if; - - else - Set_Global_Type (N, N2); - end if; + Set_Global_Type (N, N2); elsif Nkind (N) = N_Op_Concat and then Is_Generic_Type (Etype (N2)) @@ -15453,7 +15749,7 @@ package body Sem_Ch12 is -- its value. Otherwise the folding will happen in any instantiation. elsif Nkind (Parent (N)) = N_Selected_Component - and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal) + and then Nkind (Parent (N2)) in N_Integer_Literal | N_Real_Literal then if Present (Entity (Original_Node (Parent (N2)))) and then Is_Global (Entity (Original_Node (Parent (N2)))) @@ -15755,12 +16051,12 @@ package body Sem_Ch12 is -- global references within their aspects due to the timing of -- annotation analysis. - if Nkind_In (Nod, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Body, - N_Package_Body_Stub, - N_Subprogram_Body, - N_Subprogram_Body_Stub) + if Nkind (Nod) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Body + | N_Package_Body_Stub + | N_Subprogram_Body + | N_Subprogram_Body_Stub then -- Since the capture of global references is done on the -- unanalyzed generic template, there is no information around @@ -15917,41 +16213,14 @@ package body Sem_Ch12 is -- The node did not undergo a transformation if Nkind (N) = Nkind (Get_Associated_Node (N)) then - declare - Aux_N2 : constant Node_Id := Get_Associated_Node (N); - Orig_N2_Parent : constant Node_Id := - Original_Node (Parent (Aux_N2)); - begin - -- The parent of this identifier is a selected component - -- which denotes a named number that was constant folded. - -- Preserve the original name for ASIS and link the parent - -- with its expanded name. The constant folding will be - -- repeated in the instance. - - if Nkind (Parent (N)) = N_Selected_Component - and then Nkind_In (Parent (Aux_N2), N_Integer_Literal, - N_Real_Literal) - and then Is_Entity_Name (Orig_N2_Parent) - and then Ekind (Entity (Orig_N2_Parent)) in Named_Kind - and then Is_Global (Entity (Orig_N2_Parent)) - then - N2 := Aux_N2; - Set_Associated_Node - (Parent (N), Original_Node (Parent (N2))); - - -- Common case + -- If this is a discriminant reference, always save it. + -- It is used in the instance to find the corresponding + -- discriminant positionally rather than by name. - else - -- If this is a discriminant reference, always save it. - -- It is used in the instance to find the corresponding - -- discriminant positionally rather than by name. - - Set_Original_Discriminant - (N, Original_Discriminant (Get_Associated_Node (N))); - end if; + Set_Original_Discriminant + (N, Original_Discriminant (Get_Associated_Node (N))); - Reset_Entity (N); - end; + Reset_Entity (N); -- The analysis of the generic copy transformed the identifier -- into another construct. Propagate the changes to the template. @@ -15975,8 +16244,9 @@ package body Sem_Ch12 is -- The identifier denotes a named number that was constant -- folded. Preserve the original name for ASIS and undo the -- constant folding which will be repeated in the instance. + -- Is this still needed??? - elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal) + elsif Nkind (N2) in N_Integer_Literal | N_Real_Literal and then Is_Entity_Name (Original_Node (N2)) then Set_Associated_Node (N, Original_Node (N2)); @@ -16078,16 +16348,17 @@ package body Sem_Ch12 is -- The operator was folded into a literal - elsif Nkind_In (N2, N_Integer_Literal, - N_Real_Literal, - N_String_Literal) + elsif Nkind (N2) in N_Integer_Literal + | N_Real_Literal + | N_String_Literal then if Present (Original_Node (N2)) and then Nkind (Original_Node (N2)) = Nkind (N) then -- Operation was constant-folded. Whenever possible, - -- recover semantic information from unfolded node, - -- for ASIS use. + -- recover semantic information from unfolded node. + -- This was initially done for ASIS but is apparently + -- needed also for e.g. compiling a-nbnbin.adb. Set_Associated_Node (N, Original_Node (N2)); @@ -16189,12 +16460,12 @@ package body Sem_Ch12 is -- Aggregates - elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then Save_References_In_Aggregate (N); -- Character literals, operator symbols - elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then + elsif Nkind (N) in N_Character_Literal | N_Operator_Symbol then Save_References_In_Char_Lit_Or_Op_Symbol (N); -- Defining identifiers @@ -16420,19 +16691,9 @@ package body Sem_Ch12 is end if; while Present (Priv_Elmt) loop - Priv_Sub := (Node (Priv_Elmt)); - - -- We avoid flipping the subtype if the Etype of its full view is - -- private because this would result in a malformed subtype. This - -- occurs when the Etype of the subtype full view is the full view of - -- the base type (and since the base types were just switched, the - -- subtype is pointing to the wrong view). This is currently the case - -- for tagged record types, access types (maybe more?) and needs to - -- be resolved. ??? - - if Present (Full_View (Priv_Sub)) - and then not Is_Private_Type (Etype (Full_View (Priv_Sub))) - then + Priv_Sub := Node (Priv_Elmt); + + if Present (Full_View (Priv_Sub)) then Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views); Exchange_Declarations (Priv_Sub); end if; @@ -16513,6 +16774,7 @@ package body Sem_Ch12 is OK := (Is_Fun and then Num_F = 1); when Attribute_Output + | Attribute_Put_Image | Attribute_Read | Attribute_Write => |